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 #include "feature.h"
 106
 107 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 108 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 109 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 110
 111 #if defined(PL_OP_SLAB_ALLOC)
 112
 113 #ifdef PERL_DEBUG_READONLY_OPS
 114 #  define PERL_SLAB_SIZE 4096
 115 #  include <sys/mman.h>
 116 #endif
 117
 118 #ifndef PERL_SLAB_SIZE
 119 #define PERL_SLAB_SIZE 2048
 120 #endif
 121
 122 void *
 123 Perl_Slab_Alloc(pTHX_ size_t sz)
 124 {
 125     dVAR;
 126     /*
 127      * To make incrementing use count easy PL_OpSlab is an I32 *
 128      * To make inserting the link to slab PL_OpPtr is I32 **
 129      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
 130      * Add an overhead for pointer to slab and round up as a number of pointers
 131      */
 132     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
 133     if ((PL_OpSpace -= sz) < 0) {
 134 #ifdef PERL_DEBUG_READONLY_OPS
 135         /* We need to allocate chunk by chunk so that we can control the VM
 136            mapping */
 137         PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
 138                         MAP_ANON|MAP_PRIVATE, -1, 0);
 139
 140         DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 141                               (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
 142                               PL_OpPtr));
 143         if(PL_OpPtr == MAP_FAILED) {
 144             perror("mmap failed");
 145             abort();
 146         }
 147 #else
 148
 149         PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
 150 #endif
 151         if (!PL_OpPtr) {
 152             return NULL;
 153         }
 154         /* We reserve the 0'th I32 sized chunk as a use count */
 155         PL_OpSlab = (I32 *) PL_OpPtr;
 156         /* Reduce size by the use count word, and by the size we need.
 157          * Latter is to mimic the '-=' in the if() above
 158          */
 159         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 160         /* Allocation pointer starts at the top.
 161            Theory: because we build leaves before trunk allocating at end
 162            means that at run time access is cache friendly upward
 163          */
 164         PL_OpPtr += PERL_SLAB_SIZE;
 165
 166 #ifdef PERL_DEBUG_READONLY_OPS
 167         /* We remember this slab.  */
 168         /* This implementation isn't efficient, but it is simple. */
 169         PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
 170         PL_slabs[PL_slab_count++] = PL_OpSlab;
 171         DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
 172 #endif
 173     }
 174     assert( PL_OpSpace >= 0 );
 175     /* Move the allocation pointer down */
 176     PL_OpPtr   -= sz;
 177     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 178     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 179     (*PL_OpSlab)++;             /* Increment use count of slab */
 180     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 181     assert( *PL_OpSlab > 0 );
 182     return (void *)(PL_OpPtr + 1);
 183 }
 184
 185 #ifdef PERL_DEBUG_READONLY_OPS
 186 void
 187 Perl_pending_Slabs_to_ro(pTHX) {
 188     /* Turn all the allocated op slabs read only.  */
 189     U32 count = PL_slab_count;
 190     I32 **const slabs = PL_slabs;
 191
 192     /* Reset the array of pending OP slabs, as we're about to turn this lot
 193        read only. Also, do it ahead of the loop in case the warn triggers,
 194        and a warn handler has an eval */
 195
 196     PL_slabs = NULL;
 197     PL_slab_count = 0;
 198
 199     /* Force a new slab for any further allocation.  */
 200     PL_OpSpace = 0;
 201
 202     while (count--) {
 203         void *const start = slabs[count];
 204         const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
 205         if(mprotect(start, size, PROT_READ)) {
 206             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
 207                       start, (unsigned long) size, errno);
 208         }
 209     }
 210
 211     free(slabs);
 212 }
 213
 214 STATIC void
 215 S_Slab_to_rw(pTHX_ void *op)
 216 {
 217     I32 * const * const ptr = (I32 **) op;
 218     I32 * const slab = ptr[-1];
 219
 220     PERL_ARGS_ASSERT_SLAB_TO_RW;
 221
 222     assert( ptr-1 > (I32 **) slab );
 223     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 224     assert( *slab > 0 );
 225     if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
 226         Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
 227                   slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
 228     }
 229 }
 230
 231 OP *
 232 Perl_op_refcnt_inc(pTHX_ OP *o)
 233 {
 234     if(o) {
 235         Slab_to_rw(o);
 236         ++o->op_targ;
 237     }
 238     return o;
 239
 240 }
 241
 242 PADOFFSET
 243 Perl_op_refcnt_dec(pTHX_ OP *o)
 244 {
 245     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 246     Slab_to_rw(o);
 247     return --o->op_targ;
 248 }
 249 #else
 250 #  define Slab_to_rw(op)
 251 #endif
 252
 253 void
 254 Perl_Slab_Free(pTHX_ void *op)
 255 {
 256     I32 * const * const ptr = (I32 **) op;
 257     I32 * const slab = ptr[-1];
 258     PERL_ARGS_ASSERT_SLAB_FREE;
 259     assert( ptr-1 > (I32 **) slab );
 260     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 261     assert( *slab > 0 );
 262     Slab_to_rw(op);
 263     if (--(*slab) == 0) {
 264 #  ifdef NETWARE
 265 #    define PerlMemShared PerlMem
 266 #  endif
 267
 268 #ifdef PERL_DEBUG_READONLY_OPS
 269         U32 count = PL_slab_count;
 270         /* Need to remove this slab from our list of slabs */
 271         if (count) {
 272             while (count--) {
 273                 if (PL_slabs[count] == slab) {
 274                     dVAR;
 275                     /* Found it. Move the entry at the end to overwrite it.  */
 276                     DEBUG_m(PerlIO_printf(Perl_debug_log,
 277                                           "Deallocate %p by moving %p from %lu to %lu\n",
 278                                           PL_OpSlab,
 279                                           PL_slabs[PL_slab_count - 1],
 280                                           PL_slab_count, count));
 281                     PL_slabs[count] = PL_slabs[--PL_slab_count];
 282                     /* Could realloc smaller at this point, but probably not
 283                        worth it.  */
 284                     if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
 285                         perror("munmap failed");
 286                         abort();
 287                     }
 288                     break;
 289                 }
 290             }
 291         }
 292 #else
 293     PerlMemShared_free(slab);
 294 #endif
 295         if (slab == PL_OpSlab) {
 296             PL_OpSpace = 0;
 297         }
 298     }
 299 }
 300 #endif
 301 /*
 302  * In the following definition, the ", (OP*)0" is just to make the compiler
 303  * think the expression is of the right type: croak actually does a Siglongjmp.
 304  */
 305 #define CHECKOP(type,o) \
 306     ((PL_op_mask && PL_op_mask[type])                           \
 307      ? ( op_free((OP*)o),                                       \
 308          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 309          (OP*)0 )                                               \
 310      : PL_check[type](aTHX_ (OP*)o))
 311
 312 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 313
 314 #define CHANGE_TYPE(o,type) \
 315     STMT_START {                                \
 316         o->op_type = (OPCODE)type;              \
 317         o->op_ppaddr = PL_ppaddr[type];         \
 318     } STMT_END
 319
 320 STATIC SV*
 321 S_gv_ename(pTHX_ GV *gv)
 322 {
 323     SV* const tmpsv = sv_newmortal();
 324
 325     PERL_ARGS_ASSERT_GV_ENAME;
 326
 327     gv_efullname3(tmpsv, gv, NULL);
 328     return tmpsv;
 329 }
 330
 331 STATIC OP *
 332 S_no_fh_allowed(pTHX_ OP *o)
 333 {
 334     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 335
 336     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 337                  OP_DESC(o)));
 338     return o;
 339 }
 340
 341 STATIC OP *
 342 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 343 {
 344     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
 345     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
 346                                     SvUTF8(namesv) | flags);
 347     return o;
 348 }
 349
 350 STATIC OP *
 351 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 352 {
 353     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 354     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 355     return o;
 356 }
 357
 358 STATIC OP *
 359 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 360 {
 361     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 362
 363     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 364     return o;
 365 }
 366
 367 STATIC OP *
 368 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 369 {
 370     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 371
 372     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
 373                 SvUTF8(namesv) | flags);
 374     return o;
 375 }
 376
 377 STATIC void
 378 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 379 {
 380     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 381
 382     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 383                  (int)n, name, t, OP_DESC(kid)), flags);
 384 }
 385
 386 STATIC void
 387 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
 388 {
 389     PERL_ARGS_ASSERT_BAD_TYPE_SV;
 390
 391     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 392                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 393 }
 394
 395 STATIC void
 396 S_no_bareword_allowed(pTHX_ OP *o)
 397 {
 398     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 399
 400     if (PL_madskills)
 401         return;         /* various ok barewords are hidden in extra OP_NULL */
 402     qerror(Perl_mess(aTHX_
 403                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 404                      SVfARG(cSVOPo_sv)));
 405     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 406 }
 407
 408 /* "register" allocation */
 409
 410 PADOFFSET
 411 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 412 {
 413     dVAR;
 414     PADOFFSET off;
 415     const bool is_our = (PL_parser->in_my == KEY_our);
 416
 417     PERL_ARGS_ASSERT_ALLOCMY;
 418
 419     if (flags & ~SVf_UTF8)
 420         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 421                    (UV)flags);
 422
 423     /* Until we're using the length for real, cross check that we're being
 424        told the truth.  */
 425     assert(strlen(name) == len);
 426
 427     /* complain about "my $<special_var>" etc etc */
 428     if (len &&
 429         !(is_our ||
 430           isALPHA(name[1]) ||
 431           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 432           (name[1] == '_' && (*name == '$' || len > 2))))
 433     {
 434         /* name[2] is true if strlen(name) > 2  */
 435         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 436          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 437             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 438                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 439                               PL_parser->in_my == KEY_state ? "state" : "my"));
 440         } else {
 441             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 442                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 443         }
 444     }
 445
 446     /* allocate a spare slot and store the name in that slot */
 447
 448     off = pad_add_name_pvn(name, len,
 449                        (is_our ? padadd_OUR :
 450                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 451                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 452                     PL_parser->in_my_stash,
 453                     (is_our
 454                         /* $_ is always in main::, even with our */
 455                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 456                         : NULL
 457                     )
 458     );
 459     /* anon sub prototypes contains state vars should always be cloned,
 460      * otherwise the state var would be shared between anon subs */
 461
 462     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 463         CvCLONE_on(PL_compcv);
 464
 465     return off;
 466 }
 467
 468 /* free the body of an op without examining its contents.
 469  * Always use this rather than FreeOp directly */
 470
 471 static void
 472 S_op_destroy(pTHX_ OP *o)
 473 {
 474     if (o->op_latefree) {
 475         o->op_latefreed = 1;
 476         return;
 477     }
 478     FreeOp(o);
 479 }
 480
 481 #ifdef USE_ITHREADS
 482 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 483 #else
 484 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 485 #endif
 486
 487 /* Destructor */
 488
 489 void
 490 Perl_op_free(pTHX_ OP *o)
 491 {
 492     dVAR;
 493     OPCODE type;
 494
 495     if (!o)
 496         return;
 497     if (o->op_latefreed) {
 498         if (o->op_latefree)
 499             return;
 500         goto do_free;
 501     }
 502
 503     type = o->op_type;
 504     if (o->op_private & OPpREFCOUNTED) {
 505         switch (type) {
 506         case OP_LEAVESUB:
 507         case OP_LEAVESUBLV:
 508         case OP_LEAVEEVAL:
 509         case OP_LEAVE:
 510         case OP_SCOPE:
 511         case OP_LEAVEWRITE:
 512             {
 513             PADOFFSET refcnt;
 514             OP_REFCNT_LOCK;
 515             refcnt = OpREFCNT_dec(o);
 516             OP_REFCNT_UNLOCK;
 517             if (refcnt) {
 518                 /* Need to find and remove any pattern match ops from the list
 519                    we maintain for reset().  */
 520                 find_and_forget_pmops(o);
 521                 return;
 522             }
 523             }
 524             break;
 525         default:
 526             break;
 527         }
 528     }
 529
 530     /* Call the op_free hook if it has been set. Do it now so that it's called
 531      * at the right time for refcounted ops, but still before all of the kids
 532      * are freed. */
 533     CALL_OPFREEHOOK(o);
 534
 535     if (o->op_flags & OPf_KIDS) {
 536         register OP *kid, *nextkid;
 537         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 538             nextkid = kid->op_sibling; /* Get before next freeing kid */
 539             op_free(kid);
 540         }
 541     }
 542
 543 #ifdef PERL_DEBUG_READONLY_OPS
 544     Slab_to_rw(o);
 545 #endif
 546
 547     /* COP* is not cleared by op_clear() so that we may track line
 548      * numbers etc even after null() */
 549     if (type == OP_NEXTSTATE || type == OP_DBSTATE
 550             || (type == OP_NULL /* the COP might have been null'ed */
 551                 && ((OPCODE)o->op_targ == OP_NEXTSTATE
 552                     || (OPCODE)o->op_targ == OP_DBSTATE))) {
 553         cop_free((COP*)o);
 554     }
 555
 556     if (type == OP_NULL)
 557         type = (OPCODE)o->op_targ;
 558
 559     op_clear(o);
 560     if (o->op_latefree) {
 561         o->op_latefreed = 1;
 562         return;
 563     }
 564   do_free:
 565     FreeOp(o);
 566 #ifdef DEBUG_LEAKING_SCALARS
 567     if (PL_op == o)
 568         PL_op = NULL;
 569 #endif
 570 }
 571
 572 void
 573 Perl_op_clear(pTHX_ OP *o)
 574 {
 575
 576     dVAR;
 577
 578     PERL_ARGS_ASSERT_OP_CLEAR;
 579
 580 #ifdef PERL_MAD
 581     mad_free(o->op_madprop);
 582     o->op_madprop = 0;
 583 #endif
 584
 585  retry:
 586     switch (o->op_type) {
 587     case OP_NULL:       /* Was holding old type, if any. */
 588         if (PL_madskills && o->op_targ != OP_NULL) {
 589             o->op_type = (Optype)o->op_targ;
 590             o->op_targ = 0;
 591             goto retry;
 592         }
 593     case OP_ENTERTRY:
 594     case OP_ENTEREVAL:  /* Was holding hints. */
 595         o->op_targ = 0;
 596         break;
 597     default:
 598         if (!(o->op_flags & OPf_REF)
 599             || (PL_check[o->op_type] != Perl_ck_ftst))
 600             break;
 601         /* FALL THROUGH */
 602     case OP_GVSV:
 603     case OP_GV:
 604     case OP_AELEMFAST:
 605         {
 606             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 607 #ifdef USE_ITHREADS
 608                         && PL_curpad
 609 #endif
 610                         ? cGVOPo_gv : NULL;
 611             /* It's possible during global destruction that the GV is freed
 612                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 613                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 614                will trigger an assertion failure, because the entry to sv_clear
 615                checks that the scalar is not already freed.  A check of for
 616                !SvIS_FREED(gv) turns out to be invalid, because during global
 617                destruction the reference count can be forced down to zero
 618                (with SVf_BREAK set).  In which case raising to 1 and then
 619                dropping to 0 triggers cleanup before it should happen.  I
 620                *think* that this might actually be a general, systematic,
 621                weakness of the whole idea of SVf_BREAK, in that code *is*
 622                allowed to raise and lower references during global destruction,
 623                so any *valid* code that happens to do this during global
 624                destruction might well trigger premature cleanup.  */
 625             bool still_valid = gv && SvREFCNT(gv);
 626
 627             if (still_valid)
 628                 SvREFCNT_inc_simple_void(gv);
 629 #ifdef USE_ITHREADS
 630             if (cPADOPo->op_padix > 0) {
 631                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 632                  * may still exist on the pad */
 633                 pad_swipe(cPADOPo->op_padix, TRUE);
 634                 cPADOPo->op_padix = 0;
 635             }
 636 #else
 637             SvREFCNT_dec(cSVOPo->op_sv);
 638             cSVOPo->op_sv = NULL;
 639 #endif
 640             if (still_valid) {
 641                 int try_downgrade = SvREFCNT(gv) == 2;
 642                 SvREFCNT_dec(gv);
 643                 if (try_downgrade)
 644                     gv_try_downgrade(gv);
 645             }
 646         }
 647         break;
 648     case OP_METHOD_NAMED:
 649     case OP_CONST:
 650     case OP_HINTSEVAL:
 651         SvREFCNT_dec(cSVOPo->op_sv);
 652         cSVOPo->op_sv = NULL;
 653 #ifdef USE_ITHREADS
 654         /** Bug #15654
 655           Even if op_clear does a pad_free for the target of the op,
 656           pad_free doesn't actually remove the sv that exists in the pad;
 657           instead it lives on. This results in that it could be reused as
 658           a target later on when the pad was reallocated.
 659         **/
 660         if(o->op_targ) {
 661           pad_swipe(o->op_targ,1);
 662           o->op_targ = 0;
 663         }
 664 #endif
 665         break;
 666     case OP_GOTO:
 667     case OP_NEXT:
 668     case OP_LAST:
 669     case OP_REDO:
 670         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 671             break;
 672         /* FALL THROUGH */
 673     case OP_TRANS:
 674     case OP_TRANSR:
 675         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 676 #ifdef USE_ITHREADS
 677             if (cPADOPo->op_padix > 0) {
 678                 pad_swipe(cPADOPo->op_padix, TRUE);
 679                 cPADOPo->op_padix = 0;
 680             }
 681 #else
 682             SvREFCNT_dec(cSVOPo->op_sv);
 683             cSVOPo->op_sv = NULL;
 684 #endif
 685         }
 686         else {
 687             PerlMemShared_free(cPVOPo->op_pv);
 688             cPVOPo->op_pv = NULL;
 689         }
 690         break;
 691     case OP_SUBST:
 692         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 693         goto clear_pmop;
 694     case OP_PUSHRE:
 695 #ifdef USE_ITHREADS
 696         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 697             /* No GvIN_PAD_off here, because other references may still
 698              * exist on the pad */
 699             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 700         }
 701 #else
 702         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 703 #endif
 704         /* FALL THROUGH */
 705     case OP_MATCH:
 706     case OP_QR:
 707 clear_pmop:
 708         forget_pmop(cPMOPo, 1);
 709         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 710         /* we use the same protection as the "SAFE" version of the PM_ macros
 711          * here since sv_clean_all might release some PMOPs
 712          * after PL_regex_padav has been cleared
 713          * and the clearing of PL_regex_padav needs to
 714          * happen before sv_clean_all
 715          */
 716 #ifdef USE_ITHREADS
 717         if(PL_regex_pad) {        /* We could be in destruction */
 718             const IV offset = (cPMOPo)->op_pmoffset;
 719             ReREFCNT_dec(PM_GETRE(cPMOPo));
 720             PL_regex_pad[offset] = &PL_sv_undef;
 721             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 722                            sizeof(offset));
 723         }
 724 #else
 725         ReREFCNT_dec(PM_GETRE(cPMOPo));
 726         PM_SETRE(cPMOPo, NULL);
 727 #endif
 728
 729         break;
 730     }
 731
 732     if (o->op_targ > 0) {
 733         pad_free(o->op_targ);
 734         o->op_targ = 0;
 735     }
 736 }
 737
 738 STATIC void
 739 S_cop_free(pTHX_ COP* cop)
 740 {
 741     PERL_ARGS_ASSERT_COP_FREE;
 742
 743     CopFILE_free(cop);
 744     CopSTASH_free(cop);
 745     if (! specialWARN(cop->cop_warnings))
 746         PerlMemShared_free(cop->cop_warnings);
 747     cophh_free(CopHINTHASH_get(cop));
 748 }
 749
 750 STATIC void
 751 S_forget_pmop(pTHX_ PMOP *const o
 752 #ifdef USE_ITHREADS
 753               , U32 flags
 754 #endif
 755               )
 756 {
 757     HV * const pmstash = PmopSTASH(o);
 758
 759     PERL_ARGS_ASSERT_FORGET_PMOP;
 760
 761     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 762         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 763         if (mg) {
 764             PMOP **const array = (PMOP**) mg->mg_ptr;
 765             U32 count = mg->mg_len / sizeof(PMOP**);
 766             U32 i = count;
 767
 768             while (i--) {
 769                 if (array[i] == o) {
 770                     /* Found it. Move the entry at the end to overwrite it.  */
 771                     array[i] = array[--count];
 772                     mg->mg_len = count * sizeof(PMOP**);
 773                     /* Could realloc smaller at this point always, but probably
 774                        not worth it. Probably worth free()ing if we're the
 775                        last.  */
 776                     if(!count) {
 777                         Safefree(mg->mg_ptr);
 778                         mg->mg_ptr = NULL;
 779                     }
 780                     break;
 781                 }
 782             }
 783         }
 784     }
 785     if (PL_curpm == o)
 786         PL_curpm = NULL;
 787 #ifdef USE_ITHREADS
 788     if (flags)
 789         PmopSTASH_free(o);
 790 #endif
 791 }
 792
 793 STATIC void
 794 S_find_and_forget_pmops(pTHX_ OP *o)
 795 {
 796     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 797
 798     if (o->op_flags & OPf_KIDS) {
 799         OP *kid = cUNOPo->op_first;
 800         while (kid) {
 801             switch (kid->op_type) {
 802             case OP_SUBST:
 803             case OP_PUSHRE:
 804             case OP_MATCH:
 805             case OP_QR:
 806                 forget_pmop((PMOP*)kid, 0);
 807             }
 808             find_and_forget_pmops(kid);
 809             kid = kid->op_sibling;
 810         }
 811     }
 812 }
 813
 814 void
 815 Perl_op_null(pTHX_ OP *o)
 816 {
 817     dVAR;
 818
 819     PERL_ARGS_ASSERT_OP_NULL;
 820
 821     if (o->op_type == OP_NULL)
 822         return;
 823     if (!PL_madskills)
 824         op_clear(o);
 825     o->op_targ = o->op_type;
 826     o->op_type = OP_NULL;
 827     o->op_ppaddr = PL_ppaddr[OP_NULL];
 828 }
 829
 830 void
 831 Perl_op_refcnt_lock(pTHX)
 832 {
 833     dVAR;
 834     PERL_UNUSED_CONTEXT;
 835     OP_REFCNT_LOCK;
 836 }
 837
 838 void
 839 Perl_op_refcnt_unlock(pTHX)
 840 {
 841     dVAR;
 842     PERL_UNUSED_CONTEXT;
 843     OP_REFCNT_UNLOCK;
 844 }
 845
 846 /* Contextualizers */
 847
 848 /*
 849 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
 850
 851 Applies a syntactic context to an op tree representing an expression.
 852 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
 853 or C<G_VOID> to specify the context to apply.  The modified op tree
 854 is returned.
 855
 856 =cut
 857 */
 858
 859 OP *
 860 Perl_op_contextualize(pTHX_ OP *o, I32 context)
 861 {
 862     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
 863     switch (context) {
 864         case G_SCALAR: return scalar(o);
 865         case G_ARRAY:  return list(o);
 866         case G_VOID:   return scalarvoid(o);
 867         default:
 868             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
 869                        (long) context);
 870             return o;
 871     }
 872 }
 873
 874 /*
 875 =head1 Optree Manipulation Functions
 876
 877 =for apidoc Am|OP*|op_linklist|OP *o
 878 This function is the implementation of the L</LINKLIST> macro. It should
 879 not be called directly.
 880
 881 =cut
 882 */
 883
 884 OP *
 885 Perl_op_linklist(pTHX_ OP *o)
 886 {
 887     OP *first;
 888
 889     PERL_ARGS_ASSERT_OP_LINKLIST;
 890
 891     if (o->op_next)
 892         return o->op_next;
 893
 894     /* establish postfix order */
 895     first = cUNOPo->op_first;
 896     if (first) {
 897         register OP *kid;
 898         o->op_next = LINKLIST(first);
 899         kid = first;
 900         for (;;) {
 901             if (kid->op_sibling) {
 902                 kid->op_next = LINKLIST(kid->op_sibling);
 903                 kid = kid->op_sibling;
 904             } else {
 905                 kid->op_next = o;
 906                 break;
 907             }
 908         }
 909     }
 910     else
 911         o->op_next = o;
 912
 913     return o->op_next;
 914 }
 915
 916 static OP *
 917 S_scalarkids(pTHX_ OP *o)
 918 {
 919     if (o && o->op_flags & OPf_KIDS) {
 920         OP *kid;
 921         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 922             scalar(kid);
 923     }
 924     return o;
 925 }
 926
 927 STATIC OP *
 928 S_scalarboolean(pTHX_ OP *o)
 929 {
 930     dVAR;
 931
 932     PERL_ARGS_ASSERT_SCALARBOOLEAN;
 933
 934     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
 935      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
 936         if (ckWARN(WARN_SYNTAX)) {
 937             const line_t oldline = CopLINE(PL_curcop);
 938
 939             if (PL_parser && PL_parser->copline != NOLINE)
 940                 CopLINE_set(PL_curcop, PL_parser->copline);
 941             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 942             CopLINE_set(PL_curcop, oldline);
 943         }
 944     }
 945     return scalar(o);
 946 }
 947
 948 OP *
 949 Perl_scalar(pTHX_ OP *o)
 950 {
 951     dVAR;
 952     OP *kid;
 953
 954     /* assumes no premature commitment */
 955     if (!o || (PL_parser && PL_parser->error_count)
 956          || (o->op_flags & OPf_WANT)
 957          || o->op_type == OP_RETURN)
 958     {
 959         return o;
 960     }
 961
 962     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 963
 964     switch (o->op_type) {
 965     case OP_REPEAT:
 966         scalar(cBINOPo->op_first);
 967         break;
 968     case OP_OR:
 969     case OP_AND:
 970     case OP_COND_EXPR:
 971         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 972             scalar(kid);
 973         break;
 974         /* FALL THROUGH */
 975     case OP_SPLIT:
 976     case OP_MATCH:
 977     case OP_QR:
 978     case OP_SUBST:
 979     case OP_NULL:
 980     default:
 981         if (o->op_flags & OPf_KIDS) {
 982             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 983                 scalar(kid);
 984         }
 985         break;
 986     case OP_LEAVE:
 987     case OP_LEAVETRY:
 988         kid = cLISTOPo->op_first;
 989         scalar(kid);
 990         kid = kid->op_sibling;
 991     do_kids:
 992         while (kid) {
 993             OP *sib = kid->op_sibling;
 994             if (sib && kid->op_type != OP_LEAVEWHEN)
 995                 scalarvoid(kid);
 996             else
 997                 scalar(kid);
 998             kid = sib;
 999         }
1000         PL_curcop = &PL_compiling;
1001         break;
1002     case OP_SCOPE:
1003     case OP_LINESEQ:
1004     case OP_LIST:
1005         kid = cLISTOPo->op_first;
1006         goto do_kids;
1007     case OP_SORT:
1008         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1009         break;
1010     }
1011     return o;
1012 }
1013
1014 OP *
1015 Perl_scalarvoid(pTHX_ OP *o)
1016 {
1017     dVAR;
1018     OP *kid;
1019     const char* useless = NULL;
1020     U32 useless_is_utf8 = 0;
1021     SV* sv;
1022     U8 want;
1023
1024     PERL_ARGS_ASSERT_SCALARVOID;
1025
1026     /* trailing mad null ops don't count as "there" for void processing */
1027     if (PL_madskills &&
1028         o->op_type != OP_NULL &&
1029         o->op_sibling &&
1030         o->op_sibling->op_type == OP_NULL)
1031     {
1032         OP *sib;
1033         for (sib = o->op_sibling;
1034                 sib && sib->op_type == OP_NULL;
1035                 sib = sib->op_sibling) ;
1036
1037         if (!sib)
1038             return o;
1039     }
1040
1041     if (o->op_type == OP_NEXTSTATE
1042         || o->op_type == OP_DBSTATE
1043         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1044                                       || o->op_targ == OP_DBSTATE)))
1045         PL_curcop = (COP*)o;            /* for warning below */
1046
1047     /* assumes no premature commitment */
1048     want = o->op_flags & OPf_WANT;
1049     if ((want && want != OPf_WANT_SCALAR)
1050          || (PL_parser && PL_parser->error_count)
1051          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1052     {
1053         return o;
1054     }
1055
1056     if ((o->op_private & OPpTARGET_MY)
1057         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1058     {
1059         return scalar(o);                       /* As if inside SASSIGN */
1060     }
1061
1062     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1063
1064     switch (o->op_type) {
1065     default:
1066         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1067             break;
1068         /* FALL THROUGH */
1069     case OP_REPEAT:
1070         if (o->op_flags & OPf_STACKED)
1071             break;
1072         goto func_ops;
1073     case OP_SUBSTR:
1074         if (o->op_private == 4)
1075             break;
1076         /* FALL THROUGH */
1077     case OP_GVSV:
1078     case OP_WANTARRAY:
1079     case OP_GV:
1080     case OP_SMARTMATCH:
1081     case OP_PADSV:
1082     case OP_PADAV:
1083     case OP_PADHV:
1084     case OP_PADANY:
1085     case OP_AV2ARYLEN:
1086     case OP_REF:
1087     case OP_REFGEN:
1088     case OP_SREFGEN:
1089     case OP_DEFINED:
1090     case OP_HEX:
1091     case OP_OCT:
1092     case OP_LENGTH:
1093     case OP_VEC:
1094     case OP_INDEX:
1095     case OP_RINDEX:
1096     case OP_SPRINTF:
1097     case OP_AELEM:
1098     case OP_AELEMFAST:
1099     case OP_AELEMFAST_LEX:
1100     case OP_ASLICE:
1101     case OP_HELEM:
1102     case OP_HSLICE:
1103     case OP_UNPACK:
1104     case OP_PACK:
1105     case OP_JOIN:
1106     case OP_LSLICE:
1107     case OP_ANONLIST:
1108     case OP_ANONHASH:
1109     case OP_SORT:
1110     case OP_REVERSE:
1111     case OP_RANGE:
1112     case OP_FLIP:
1113     case OP_FLOP:
1114     case OP_CALLER:
1115     case OP_FILENO:
1116     case OP_EOF:
1117     case OP_TELL:
1118     case OP_GETSOCKNAME:
1119     case OP_GETPEERNAME:
1120     case OP_READLINK:
1121     case OP_TELLDIR:
1122     case OP_GETPPID:
1123     case OP_GETPGRP:
1124     case OP_GETPRIORITY:
1125     case OP_TIME:
1126     case OP_TMS:
1127     case OP_LOCALTIME:
1128     case OP_GMTIME:
1129     case OP_GHBYNAME:
1130     case OP_GHBYADDR:
1131     case OP_GHOSTENT:
1132     case OP_GNBYNAME:
1133     case OP_GNBYADDR:
1134     case OP_GNETENT:
1135     case OP_GPBYNAME:
1136     case OP_GPBYNUMBER:
1137     case OP_GPROTOENT:
1138     case OP_GSBYNAME:
1139     case OP_GSBYPORT:
1140     case OP_GSERVENT:
1141     case OP_GPWNAM:
1142     case OP_GPWUID:
1143     case OP_GGRNAM:
1144     case OP_GGRGID:
1145     case OP_GETLOGIN:
1146     case OP_PROTOTYPE:
1147     case OP_RUNCV:
1148       func_ops:
1149         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1150             /* Otherwise it's "Useless use of grep iterator" */
1151             useless = OP_DESC(o);
1152         break;
1153
1154     case OP_SPLIT:
1155         kid = cLISTOPo->op_first;
1156         if (kid && kid->op_type == OP_PUSHRE
1157 #ifdef USE_ITHREADS
1158                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1159 #else
1160                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1161 #endif
1162             useless = OP_DESC(o);
1163         break;
1164
1165     case OP_NOT:
1166        kid = cUNOPo->op_first;
1167        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1168            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1169                 goto func_ops;
1170        }
1171        useless = "negative pattern binding (!~)";
1172        break;
1173
1174     case OP_SUBST:
1175         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1176             useless = "non-destructive substitution (s///r)";
1177         break;
1178
1179     case OP_TRANSR:
1180         useless = "non-destructive transliteration (tr///r)";
1181         break;
1182
1183     case OP_RV2GV:
1184     case OP_RV2SV:
1185     case OP_RV2AV:
1186     case OP_RV2HV:
1187         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1188                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1189             useless = "a variable";
1190         break;
1191
1192     case OP_CONST:
1193         sv = cSVOPo_sv;
1194         if (cSVOPo->op_private & OPpCONST_STRICT)
1195             no_bareword_allowed(o);
1196         else {
1197             if (ckWARN(WARN_VOID)) {
1198                 /* don't warn on optimised away booleans, eg
1199                  * use constant Foo, 5; Foo || print; */
1200                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1201                     useless = NULL;
1202                 /* the constants 0 and 1 are permitted as they are
1203                    conventionally used as dummies in constructs like
1204                         1 while some_condition_with_side_effects;  */
1205                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1206                     useless = NULL;
1207                 else if (SvPOK(sv)) {
1208                   /* perl4's way of mixing documentation and code
1209                      (before the invention of POD) was based on a
1210                      trick to mix nroff and perl code. The trick was
1211                      built upon these three nroff macros being used in
1212                      void context. The pink camel has the details in
1213                      the script wrapman near page 319. */
1214                     const char * const maybe_macro = SvPVX_const(sv);
1215                     if (strnEQ(maybe_macro, "di", 2) ||
1216                         strnEQ(maybe_macro, "ds", 2) ||
1217                         strnEQ(maybe_macro, "ig", 2))
1218                             useless = NULL;
1219                     else {
1220                         SV * const dsv = newSVpvs("");
1221                         SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1222                                     "a constant (%s)",
1223                                     pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1224                                             PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1225                         SvREFCNT_dec(dsv);
1226                         useless = SvPV_nolen(msv);
1227                         useless_is_utf8 = SvUTF8(msv);
1228                     }
1229                 }
1230                 else if (SvOK(sv)) {
1231                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1232                                 "a constant (%"SVf")", sv));
1233                     useless = SvPV_nolen(msv);
1234                 }
1235                 else
1236                     useless = "a constant (undef)";
1237             }
1238         }
1239         op_null(o);             /* don't execute or even remember it */
1240         break;
1241
1242     case OP_POSTINC:
1243         o->op_type = OP_PREINC;         /* pre-increment is faster */
1244         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1245         break;
1246
1247     case OP_POSTDEC:
1248         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1249         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1250         break;
1251
1252     case OP_I_POSTINC:
1253         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1254         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1255         break;
1256
1257     case OP_I_POSTDEC:
1258         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1259         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1260         break;
1261
1262     case OP_SASSIGN: {
1263         OP *rv2gv;
1264         UNOP *refgen, *rv2cv;
1265         LISTOP *exlist;
1266
1267         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1268             break;
1269
1270         rv2gv = ((BINOP *)o)->op_last;
1271         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1272             break;
1273
1274         refgen = (UNOP *)((BINOP *)o)->op_first;
1275
1276         if (!refgen || refgen->op_type != OP_REFGEN)
1277             break;
1278
1279         exlist = (LISTOP *)refgen->op_first;
1280         if (!exlist || exlist->op_type != OP_NULL
1281             || exlist->op_targ != OP_LIST)
1282             break;
1283
1284         if (exlist->op_first->op_type != OP_PUSHMARK)
1285             break;
1286
1287         rv2cv = (UNOP*)exlist->op_last;
1288
1289         if (rv2cv->op_type != OP_RV2CV)
1290             break;
1291
1292         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1293         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1294         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1295
1296         o->op_private |= OPpASSIGN_CV_TO_GV;
1297         rv2gv->op_private |= OPpDONT_INIT_GV;
1298         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1299
1300         break;
1301     }
1302
1303     case OP_AASSIGN: {
1304         inplace_aassign(o);
1305         break;
1306     }
1307
1308     case OP_OR:
1309     case OP_AND:
1310         kid = cLOGOPo->op_first;
1311         if (kid->op_type == OP_NOT
1312             && (kid->op_flags & OPf_KIDS)
1313             && !PL_madskills) {
1314             if (o->op_type == OP_AND) {
1315                 o->op_type = OP_OR;
1316                 o->op_ppaddr = PL_ppaddr[OP_OR];
1317             } else {
1318                 o->op_type = OP_AND;
1319                 o->op_ppaddr = PL_ppaddr[OP_AND];
1320             }
1321             op_null(kid);
1322         }
1323
1324     case OP_DOR:
1325     case OP_COND_EXPR:
1326     case OP_ENTERGIVEN:
1327     case OP_ENTERWHEN:
1328         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1329             scalarvoid(kid);
1330         break;
1331
1332     case OP_NULL:
1333         if (o->op_flags & OPf_STACKED)
1334             break;
1335         /* FALL THROUGH */
1336     case OP_NEXTSTATE:
1337     case OP_DBSTATE:
1338     case OP_ENTERTRY:
1339     case OP_ENTER:
1340         if (!(o->op_flags & OPf_KIDS))
1341             break;
1342         /* FALL THROUGH */
1343     case OP_SCOPE:
1344     case OP_LEAVE:
1345     case OP_LEAVETRY:
1346     case OP_LEAVELOOP:
1347     case OP_LINESEQ:
1348     case OP_LIST:
1349     case OP_LEAVEGIVEN:
1350     case OP_LEAVEWHEN:
1351         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1352             scalarvoid(kid);
1353         break;
1354     case OP_ENTEREVAL:
1355         scalarkids(o);
1356         break;
1357     case OP_SCALAR:
1358         return scalar(o);
1359     }
1360     if (useless)
1361        Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1362                        newSVpvn_flags(useless, strlen(useless),
1363                             SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1364     return o;
1365 }
1366
1367 static OP *
1368 S_listkids(pTHX_ OP *o)
1369 {
1370     if (o && o->op_flags & OPf_KIDS) {
1371         OP *kid;
1372         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1373             list(kid);
1374     }
1375     return o;
1376 }
1377
1378 OP *
1379 Perl_list(pTHX_ OP *o)
1380 {
1381     dVAR;
1382     OP *kid;
1383
1384     /* assumes no premature commitment */
1385     if (!o || (o->op_flags & OPf_WANT)
1386          || (PL_parser && PL_parser->error_count)
1387          || o->op_type == OP_RETURN)
1388     {
1389         return o;
1390     }
1391
1392     if ((o->op_private & OPpTARGET_MY)
1393         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1394     {
1395         return o;                               /* As if inside SASSIGN */
1396     }
1397
1398     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1399
1400     switch (o->op_type) {
1401     case OP_FLOP:
1402     case OP_REPEAT:
1403         list(cBINOPo->op_first);
1404         break;
1405     case OP_OR:
1406     case OP_AND:
1407     case OP_COND_EXPR:
1408         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1409             list(kid);
1410         break;
1411     default:
1412     case OP_MATCH:
1413     case OP_QR:
1414     case OP_SUBST:
1415     case OP_NULL:
1416         if (!(o->op_flags & OPf_KIDS))
1417             break;
1418         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1419             list(cBINOPo->op_first);
1420             return gen_constant_list(o);
1421         }
1422     case OP_LIST:
1423         listkids(o);
1424         break;
1425     case OP_LEAVE:
1426     case OP_LEAVETRY:
1427         kid = cLISTOPo->op_first;
1428         list(kid);
1429         kid = kid->op_sibling;
1430     do_kids:
1431         while (kid) {
1432             OP *sib = kid->op_sibling;
1433             if (sib && kid->op_type != OP_LEAVEWHEN)
1434                 scalarvoid(kid);
1435             else
1436                 list(kid);
1437             kid = sib;
1438         }
1439         PL_curcop = &PL_compiling;
1440         break;
1441     case OP_SCOPE:
1442     case OP_LINESEQ:
1443         kid = cLISTOPo->op_first;
1444         goto do_kids;
1445     }
1446     return o;
1447 }
1448
1449 static OP *
1450 S_scalarseq(pTHX_ OP *o)
1451 {
1452     dVAR;
1453     if (o) {
1454         const OPCODE type = o->op_type;
1455
1456         if (type == OP_LINESEQ || type == OP_SCOPE ||
1457             type == OP_LEAVE || type == OP_LEAVETRY)
1458         {
1459             OP *kid;
1460             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1461                 if (kid->op_sibling) {
1462                     scalarvoid(kid);
1463                 }
1464             }
1465             PL_curcop = &PL_compiling;
1466         }
1467         o->op_flags &= ~OPf_PARENS;
1468         if (PL_hints & HINT_BLOCK_SCOPE)
1469             o->op_flags |= OPf_PARENS;
1470     }
1471     else
1472         o = newOP(OP_STUB, 0);
1473     return o;
1474 }
1475
1476 STATIC OP *
1477 S_modkids(pTHX_ OP *o, I32 type)
1478 {
1479     if (o && o->op_flags & OPf_KIDS) {
1480         OP *kid;
1481         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1482             op_lvalue(kid, type);
1483     }
1484     return o;
1485 }
1486
1487 /*
1488 =for apidoc finalize_optree
1489
1490 This function finalizes the optree. Should be called directly after
1491 the complete optree is built. It does some additional
1492 checking which can't be done in the normal ck_xxx functions and makes
1493 the tree thread-safe.
1494
1495 =cut
1496 */
1497 void
1498 Perl_finalize_optree(pTHX_ OP* o)
1499 {
1500     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1501
1502     ENTER;
1503     SAVEVPTR(PL_curcop);
1504
1505     finalize_op(o);
1506
1507     LEAVE;
1508 }
1509
1510 STATIC void
1511 S_finalize_op(pTHX_ OP* o)
1512 {
1513     PERL_ARGS_ASSERT_FINALIZE_OP;
1514
1515 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1516     {
1517         /* Make sure mad ops are also thread-safe */
1518         MADPROP *mp = o->op_madprop;
1519         while (mp) {
1520             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1521                 OP *prop_op = (OP *) mp->mad_val;
1522                 /* We only need "Relocate sv to the pad for thread safety.", but this
1523                    easiest way to make sure it traverses everything */
1524                 if (prop_op->op_type == OP_CONST)
1525                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1526                 finalize_op(prop_op);
1527             }
1528             mp = mp->mad_next;
1529         }
1530     }
1531 #endif
1532
1533     switch (o->op_type) {
1534     case OP_NEXTSTATE:
1535     case OP_DBSTATE:
1536         PL_curcop = ((COP*)o);          /* for warnings */
1537         break;
1538     case OP_EXEC:
1539         if ( o->op_sibling
1540             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1541             && ckWARN(WARN_SYNTAX))
1542             {
1543                 if (o->op_sibling->op_sibling) {
1544                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1545                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1546                         const line_t oldline = CopLINE(PL_curcop);
1547                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1548                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1549                             "Statement unlikely to be reached");
1550                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1551                             "\t(Maybe you meant system() when you said exec()?)\n");
1552                         CopLINE_set(PL_curcop, oldline);
1553                     }
1554                 }
1555             }
1556         break;
1557
1558     case OP_GV:
1559         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1560             GV * const gv = cGVOPo_gv;
1561             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1562                 /* XXX could check prototype here instead of just carping */
1563                 SV * const sv = sv_newmortal();
1564                 gv_efullname3(sv, gv, NULL);
1565                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1566                     "%"SVf"() called too early to check prototype",
1567                     SVfARG(sv));
1568             }
1569         }
1570         break;
1571
1572     case OP_CONST:
1573         if (cSVOPo->op_private & OPpCONST_STRICT)
1574             no_bareword_allowed(o);
1575         /* FALLTHROUGH */
1576 #ifdef USE_ITHREADS
1577     case OP_HINTSEVAL:
1578     case OP_METHOD_NAMED:
1579         /* Relocate sv to the pad for thread safety.
1580          * Despite being a "constant", the SV is written to,
1581          * for reference counts, sv_upgrade() etc. */
1582         if (cSVOPo->op_sv) {
1583             const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1584             if (o->op_type != OP_METHOD_NAMED &&
1585                 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1586             {
1587                 /* If op_sv is already a PADTMP/MY then it is being used by
1588                  * some pad, so make a copy. */
1589                 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1590                 SvREADONLY_on(PAD_SVl(ix));
1591                 SvREFCNT_dec(cSVOPo->op_sv);
1592             }
1593             else if (o->op_type != OP_METHOD_NAMED
1594                 && cSVOPo->op_sv == &PL_sv_undef) {
1595                 /* PL_sv_undef is hack - it's unsafe to store it in the
1596                    AV that is the pad, because av_fetch treats values of
1597                    PL_sv_undef as a "free" AV entry and will merrily
1598                    replace them with a new SV, causing pad_alloc to think
1599                    that this pad slot is free. (When, clearly, it is not)
1600                 */
1601                 SvOK_off(PAD_SVl(ix));
1602                 SvPADTMP_on(PAD_SVl(ix));
1603                 SvREADONLY_on(PAD_SVl(ix));
1604             }
1605             else {
1606                 SvREFCNT_dec(PAD_SVl(ix));
1607                 SvPADTMP_on(cSVOPo->op_sv);
1608                 PAD_SETSV(ix, cSVOPo->op_sv);
1609                 /* XXX I don't know how this isn't readonly already. */
1610                 SvREADONLY_on(PAD_SVl(ix));
1611             }
1612             cSVOPo->op_sv = NULL;
1613             o->op_targ = ix;
1614         }
1615 #endif
1616         break;
1617
1618     case OP_HELEM: {
1619         UNOP *rop;
1620         SV *lexname;
1621         GV **fields;
1622         SV **svp, *sv;
1623         const char *key = NULL;
1624         STRLEN keylen;
1625
1626         if (((BINOP*)o)->op_last->op_type != OP_CONST)
1627             break;
1628
1629         /* Make the CONST have a shared SV */
1630         svp = cSVOPx_svp(((BINOP*)o)->op_last);
1631         if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1632             && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1633             key = SvPV_const(sv, keylen);
1634             lexname = newSVpvn_share(key,
1635                 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1636                 0);
1637             SvREFCNT_dec(sv);
1638             *svp = lexname;
1639         }
1640
1641         if ((o->op_private & (OPpLVAL_INTRO)))
1642             break;
1643
1644         rop = (UNOP*)((BINOP*)o)->op_first;
1645         if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1646             break;
1647         lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1648         if (!SvPAD_TYPED(lexname))
1649             break;
1650         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1651         if (!fields || !GvHV(*fields))
1652             break;
1653         key = SvPV_const(*svp, keylen);
1654         if (!hv_fetch(GvHV(*fields), key,
1655                 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1656             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1657                            "in variable %"SVf" of type %"HEKf,
1658                       SVfARG(*svp), SVfARG(lexname),
1659                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1660         }
1661         break;
1662     }
1663
1664     case OP_HSLICE: {
1665         UNOP *rop;
1666         SV *lexname;
1667         GV **fields;
1668         SV **svp;
1669         const char *key;
1670         STRLEN keylen;
1671         SVOP *first_key_op, *key_op;
1672
1673         if ((o->op_private & (OPpLVAL_INTRO))
1674             /* I bet there's always a pushmark... */
1675             || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1676             /* hmmm, no optimization if list contains only one key. */
1677             break;
1678         rop = (UNOP*)((LISTOP*)o)->op_last;
1679         if (rop->op_type != OP_RV2HV)
1680             break;
1681         if (rop->op_first->op_type == OP_PADSV)
1682             /* @$hash{qw(keys here)} */
1683             rop = (UNOP*)rop->op_first;
1684         else {
1685             /* @{$hash}{qw(keys here)} */
1686             if (rop->op_first->op_type == OP_SCOPE
1687                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1688                 {
1689                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1690                 }
1691             else
1692                 break;
1693         }
1694
1695         lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1696         if (!SvPAD_TYPED(lexname))
1697             break;
1698         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1699         if (!fields || !GvHV(*fields))
1700             break;
1701         /* Again guessing that the pushmark can be jumped over.... */
1702         first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1703             ->op_first->op_sibling;
1704         for (key_op = first_key_op; key_op;
1705              key_op = (SVOP*)key_op->op_sibling) {
1706             if (key_op->op_type != OP_CONST)
1707                 continue;
1708             svp = cSVOPx_svp(key_op);
1709             key = SvPV_const(*svp, keylen);
1710             if (!hv_fetch(GvHV(*fields), key,
1711                     SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1712                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1713                            "in variable %"SVf" of type %"HEKf,
1714                       SVfARG(*svp), SVfARG(lexname),
1715                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1716             }
1717         }
1718         break;
1719     }
1720     case OP_SUBST: {
1721         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1722             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1723         break;
1724     }
1725     default:
1726         break;
1727     }
1728
1729     if (o->op_flags & OPf_KIDS) {
1730         OP *kid;
1731         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1732             finalize_op(kid);
1733     }
1734 }
1735
1736 /*
1737 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1738
1739 Propagate lvalue ("modifiable") context to an op and its children.
1740 I<type> represents the context type, roughly based on the type of op that
1741 would do the modifying, although C<local()> is represented by OP_NULL,
1742 because it has no op type of its own (it is signalled by a flag on
1743 the lvalue op).
1744
1745 This function detects things that can't be modified, such as C<$x+1>, and
1746 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1747 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1748
1749 It also flags things that need to behave specially in an lvalue context,
1750 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1751
1752 =cut
1753 */
1754
1755 OP *
1756 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1757 {
1758     dVAR;
1759     OP *kid;
1760     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1761     int localize = -1;
1762
1763     if (!o || (PL_parser && PL_parser->error_count))
1764         return o;
1765
1766     if ((o->op_private & OPpTARGET_MY)
1767         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1768     {
1769         return o;
1770     }
1771
1772     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1773
1774     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1775
1776     switch (o->op_type) {
1777     case OP_UNDEF:
1778         localize = 0;
1779         PL_modcount++;
1780         return o;
1781     case OP_STUB:
1782         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1783             break;
1784         goto nomod;
1785     case OP_ENTERSUB:
1786         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1787             !(o->op_flags & OPf_STACKED)) {
1788             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1789             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1790                poses, so we need it clear.  */
1791             o->op_private &= ~1;
1792             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1793             assert(cUNOPo->op_first->op_type == OP_NULL);
1794             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1795             break;
1796         }
1797         else {                          /* lvalue subroutine call */
1798             o->op_private |= OPpLVAL_INTRO
1799                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1800             PL_modcount = RETURN_UNLIMITED_NUMBER;
1801             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1802                 /* Potential lvalue context: */
1803                 o->op_private |= OPpENTERSUB_INARGS;
1804                 break;
1805             }
1806             else {                      /* Compile-time error message: */
1807                 OP *kid = cUNOPo->op_first;
1808                 CV *cv;
1809
1810                 if (kid->op_type != OP_PUSHMARK) {
1811                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1812                         Perl_croak(aTHX_
1813                                 "panic: unexpected lvalue entersub "
1814                                 "args: type/targ %ld:%"UVuf,
1815                                 (long)kid->op_type, (UV)kid->op_targ);
1816                     kid = kLISTOP->op_first;
1817                 }
1818                 while (kid->op_sibling)
1819                     kid = kid->op_sibling;
1820                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1821                     break;      /* Postpone until runtime */
1822                 }
1823
1824                 kid = kUNOP->op_first;
1825                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1826                     kid = kUNOP->op_first;
1827                 if (kid->op_type == OP_NULL)
1828                     Perl_croak(aTHX_
1829                                "Unexpected constant lvalue entersub "
1830                                "entry via type/targ %ld:%"UVuf,
1831                                (long)kid->op_type, (UV)kid->op_targ);
1832                 if (kid->op_type != OP_GV) {
1833                     break;
1834                 }
1835
1836                 cv = GvCV(kGVOP_gv);
1837                 if (!cv)
1838                     break;
1839                 if (CvLVALUE(cv))
1840                     break;
1841             }
1842         }
1843         /* FALL THROUGH */
1844     default:
1845       nomod:
1846         if (flags & OP_LVALUE_NO_CROAK) return NULL;
1847         /* grep, foreach, subcalls, refgen */
1848         if (type == OP_GREPSTART || type == OP_ENTERSUB
1849          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
1850             break;
1851         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1852                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1853                       ? "do block"
1854                       : (o->op_type == OP_ENTERSUB
1855                         ? "non-lvalue subroutine call"
1856                         : OP_DESC(o))),
1857                      type ? PL_op_desc[type] : "local"));
1858         return o;
1859
1860     case OP_PREINC:
1861     case OP_PREDEC:
1862     case OP_POW:
1863     case OP_MULTIPLY:
1864     case OP_DIVIDE:
1865     case OP_MODULO:
1866     case OP_REPEAT:
1867     case OP_ADD:
1868     case OP_SUBTRACT:
1869     case OP_CONCAT:
1870     case OP_LEFT_SHIFT:
1871     case OP_RIGHT_SHIFT:
1872     case OP_BIT_AND:
1873     case OP_BIT_XOR:
1874     case OP_BIT_OR:
1875     case OP_I_MULTIPLY:
1876     case OP_I_DIVIDE:
1877     case OP_I_MODULO:
1878     case OP_I_ADD:
1879     case OP_I_SUBTRACT:
1880         if (!(o->op_flags & OPf_STACKED))
1881             goto nomod;
1882         PL_modcount++;
1883         break;
1884
1885     case OP_COND_EXPR:
1886         localize = 1;
1887         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1888             op_lvalue(kid, type);
1889         break;
1890
1891     case OP_RV2AV:
1892     case OP_RV2HV:
1893         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1894            PL_modcount = RETURN_UNLIMITED_NUMBER;
1895             return o;           /* Treat \(@foo) like ordinary list. */
1896         }
1897         /* FALL THROUGH */
1898     case OP_RV2GV:
1899         if (scalar_mod_type(o, type))
1900             goto nomod;
1901         ref(cUNOPo->op_first, o->op_type);
1902         /* FALL THROUGH */
1903     case OP_ASLICE:
1904     case OP_HSLICE:
1905         if (type == OP_LEAVESUBLV)
1906             o->op_private |= OPpMAYBE_LVSUB;
1907         localize = 1;
1908         /* FALL THROUGH */
1909     case OP_AASSIGN:
1910     case OP_NEXTSTATE:
1911     case OP_DBSTATE:
1912        PL_modcount = RETURN_UNLIMITED_NUMBER;
1913         break;
1914     case OP_AV2ARYLEN:
1915         PL_hints |= HINT_BLOCK_SCOPE;
1916         if (type == OP_LEAVESUBLV)
1917             o->op_private |= OPpMAYBE_LVSUB;
1918         PL_modcount++;
1919         break;
1920     case OP_RV2SV:
1921         ref(cUNOPo->op_first, o->op_type);
1922         localize = 1;
1923         /* FALL THROUGH */
1924     case OP_GV:
1925         PL_hints |= HINT_BLOCK_SCOPE;
1926     case OP_SASSIGN:
1927     case OP_ANDASSIGN:
1928     case OP_ORASSIGN:
1929     case OP_DORASSIGN:
1930         PL_modcount++;
1931         break;
1932
1933     case OP_AELEMFAST:
1934     case OP_AELEMFAST_LEX:
1935         localize = -1;
1936         PL_modcount++;
1937         break;
1938
1939     case OP_PADAV:
1940     case OP_PADHV:
1941        PL_modcount = RETURN_UNLIMITED_NUMBER;
1942         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1943             return o;           /* Treat \(@foo) like ordinary list. */
1944         if (scalar_mod_type(o, type))
1945             goto nomod;
1946         if (type == OP_LEAVESUBLV)
1947             o->op_private |= OPpMAYBE_LVSUB;
1948         /* FALL THROUGH */
1949     case OP_PADSV:
1950         PL_modcount++;
1951         if (!type) /* local() */
1952             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1953                  PAD_COMPNAME_SV(o->op_targ));
1954         break;
1955
1956     case OP_PUSHMARK:
1957         localize = 0;
1958         break;
1959
1960     case OP_KEYS:
1961     case OP_RKEYS:
1962         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1963             goto nomod;
1964         goto lvalue_func;
1965     case OP_SUBSTR:
1966         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1967             goto nomod;
1968         /* FALL THROUGH */
1969     case OP_POS:
1970     case OP_VEC:
1971       lvalue_func:
1972         if (type == OP_LEAVESUBLV)
1973             o->op_private |= OPpMAYBE_LVSUB;
1974         pad_free(o->op_targ);
1975         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1976         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1977         if (o->op_flags & OPf_KIDS)
1978             op_lvalue(cBINOPo->op_first->op_sibling, type);
1979         break;
1980
1981     case OP_AELEM:
1982     case OP_HELEM:
1983         ref(cBINOPo->op_first, o->op_type);
1984         if (type == OP_ENTERSUB &&
1985              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1986             o->op_private |= OPpLVAL_DEFER;
1987         if (type == OP_LEAVESUBLV)
1988             o->op_private |= OPpMAYBE_LVSUB;
1989         localize = 1;
1990         PL_modcount++;
1991         break;
1992
1993     case OP_SCOPE:
1994     case OP_LEAVE:
1995     case OP_ENTER:
1996     case OP_LINESEQ:
1997         localize = 0;
1998         if (o->op_flags & OPf_KIDS)
1999             op_lvalue(cLISTOPo->op_last, type);
2000         break;
2001
2002     case OP_NULL:
2003         localize = 0;
2004         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2005             goto nomod;
2006         else if (!(o->op_flags & OPf_KIDS))
2007             break;
2008         if (o->op_targ != OP_LIST) {
2009             op_lvalue(cBINOPo->op_first, type);
2010             break;
2011         }
2012         /* FALL THROUGH */
2013     case OP_LIST:
2014         localize = 0;
2015         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2016             /* elements might be in void context because the list is
2017                in scalar context or because they are attribute sub calls */
2018             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2019                 op_lvalue(kid, type);
2020         break;
2021
2022     case OP_RETURN:
2023         if (type != OP_LEAVESUBLV)
2024             goto nomod;
2025         break; /* op_lvalue()ing was handled by ck_return() */
2026     }
2027
2028     /* [20011101.069] File test operators interpret OPf_REF to mean that
2029        their argument is a filehandle; thus \stat(".") should not set
2030        it. AMS 20011102 */
2031     if (type == OP_REFGEN &&
2032         PL_check[o->op_type] == Perl_ck_ftst)
2033         return o;
2034
2035     if (type != OP_LEAVESUBLV)
2036         o->op_flags |= OPf_MOD;
2037
2038     if (type == OP_AASSIGN || type == OP_SASSIGN)
2039         o->op_flags |= OPf_SPECIAL|OPf_REF;
2040     else if (!type) { /* local() */
2041         switch (localize) {
2042         case 1:
2043             o->op_private |= OPpLVAL_INTRO;
2044             o->op_flags &= ~OPf_SPECIAL;
2045             PL_hints |= HINT_BLOCK_SCOPE;
2046             break;
2047         case 0:
2048             break;
2049         case -1:
2050             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2051                            "Useless localization of %s", OP_DESC(o));
2052         }
2053     }
2054     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2055              && type != OP_LEAVESUBLV)
2056         o->op_flags |= OPf_REF;
2057     return o;
2058 }
2059
2060 STATIC bool
2061 S_scalar_mod_type(const OP *o, I32 type)
2062 {
2063     assert(o || type != OP_SASSIGN);
2064
2065     switch (type) {
2066     case OP_SASSIGN:
2067         if (o->op_type == OP_RV2GV)
2068             return FALSE;
2069         /* FALL THROUGH */
2070     case OP_PREINC:
2071     case OP_PREDEC:
2072     case OP_POSTINC:
2073     case OP_POSTDEC:
2074     case OP_I_PREINC:
2075     case OP_I_PREDEC:
2076     case OP_I_POSTINC:
2077     case OP_I_POSTDEC:
2078     case OP_POW:
2079     case OP_MULTIPLY:
2080     case OP_DIVIDE:
2081     case OP_MODULO:
2082     case OP_REPEAT:
2083     case OP_ADD:
2084     case OP_SUBTRACT:
2085     case OP_I_MULTIPLY:
2086     case OP_I_DIVIDE:
2087     case OP_I_MODULO:
2088     case OP_I_ADD:
2089     case OP_I_SUBTRACT:
2090     case OP_LEFT_SHIFT:
2091     case OP_RIGHT_SHIFT:
2092     case OP_BIT_AND:
2093     case OP_BIT_XOR:
2094     case OP_BIT_OR:
2095     case OP_CONCAT:
2096     case OP_SUBST:
2097     case OP_TRANS:
2098     case OP_TRANSR:
2099     case OP_READ:
2100     case OP_SYSREAD:
2101     case OP_RECV:
2102     case OP_ANDASSIGN:
2103     case OP_ORASSIGN:
2104     case OP_DORASSIGN:
2105         return TRUE;
2106     default:
2107         return FALSE;
2108     }
2109 }
2110
2111 STATIC bool
2112 S_is_handle_constructor(const OP *o, I32 numargs)
2113 {
2114     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2115
2116     switch (o->op_type) {
2117     case OP_PIPE_OP:
2118     case OP_SOCKPAIR:
2119         if (numargs == 2)
2120             return TRUE;
2121         /* FALL THROUGH */
2122     case OP_SYSOPEN:
2123     case OP_OPEN:
2124     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2125     case OP_SOCKET:
2126     case OP_OPEN_DIR:
2127     case OP_ACCEPT:
2128         if (numargs == 1)
2129             return TRUE;
2130         /* FALLTHROUGH */
2131     default:
2132         return FALSE;
2133     }
2134 }
2135
2136 static OP *
2137 S_refkids(pTHX_ OP *o, I32 type)
2138 {
2139     if (o && o->op_flags & OPf_KIDS) {
2140         OP *kid;
2141         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2142             ref(kid, type);
2143     }
2144     return o;
2145 }
2146
2147 OP *
2148 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2149 {
2150     dVAR;
2151     OP *kid;
2152
2153     PERL_ARGS_ASSERT_DOREF;
2154
2155     if (!o || (PL_parser && PL_parser->error_count))
2156         return o;
2157
2158     switch (o->op_type) {
2159     case OP_ENTERSUB:
2160         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2161             !(o->op_flags & OPf_STACKED)) {
2162             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2163             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2164             assert(cUNOPo->op_first->op_type == OP_NULL);
2165             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2166             o->op_flags |= OPf_SPECIAL;
2167             o->op_private &= ~1;
2168         }
2169         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2170             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2171                               : type == OP_RV2HV ? OPpDEREF_HV
2172                               : OPpDEREF_SV);
2173             o->op_flags |= OPf_MOD;
2174         }
2175
2176         break;
2177
2178     case OP_COND_EXPR:
2179         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2180             doref(kid, type, set_op_ref);
2181         break;
2182     case OP_RV2SV:
2183         if (type == OP_DEFINED)
2184             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2185         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2186         /* FALL THROUGH */
2187     case OP_PADSV:
2188         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2189             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2190                               : type == OP_RV2HV ? OPpDEREF_HV
2191                               : OPpDEREF_SV);
2192             o->op_flags |= OPf_MOD;
2193         }
2194         break;
2195
2196     case OP_RV2AV:
2197     case OP_RV2HV:
2198         if (set_op_ref)
2199             o->op_flags |= OPf_REF;
2200         /* FALL THROUGH */
2201     case OP_RV2GV:
2202         if (type == OP_DEFINED)
2203             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2204         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2205         break;
2206
2207     case OP_PADAV:
2208     case OP_PADHV:
2209         if (set_op_ref)
2210             o->op_flags |= OPf_REF;
2211         break;
2212
2213     case OP_SCALAR:
2214     case OP_NULL:
2215         if (!(o->op_flags & OPf_KIDS))
2216             break;
2217         doref(cBINOPo->op_first, type, set_op_ref);
2218         break;
2219     case OP_AELEM:
2220     case OP_HELEM:
2221         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2222         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2223             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2224                               : type == OP_RV2HV ? OPpDEREF_HV
2225                               : OPpDEREF_SV);
2226             o->op_flags |= OPf_MOD;
2227         }
2228         break;
2229
2230     case OP_SCOPE:
2231     case OP_LEAVE:
2232         set_op_ref = FALSE;
2233         /* FALL THROUGH */
2234     case OP_ENTER:
2235     case OP_LIST:
2236         if (!(o->op_flags & OPf_KIDS))
2237             break;
2238         doref(cLISTOPo->op_last, type, set_op_ref);
2239         break;
2240     default:
2241         break;
2242     }
2243     return scalar(o);
2244
2245 }
2246
2247 STATIC OP *
2248 S_dup_attrlist(pTHX_ OP *o)
2249 {
2250     dVAR;
2251     OP *rop;
2252
2253     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2254
2255     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2256      * where the first kid is OP_PUSHMARK and the remaining ones
2257      * are OP_CONST.  We need to push the OP_CONST values.
2258      */
2259     if (o->op_type == OP_CONST)
2260         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2261 #ifdef PERL_MAD
2262     else if (o->op_type == OP_NULL)
2263         rop = NULL;
2264 #endif
2265     else {
2266         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2267         rop = NULL;
2268         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2269             if (o->op_type == OP_CONST)
2270                 rop = op_append_elem(OP_LIST, rop,
2271                                   newSVOP(OP_CONST, o->op_flags,
2272                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2273         }
2274     }
2275     return rop;
2276 }
2277
2278 STATIC void
2279 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2280 {
2281     dVAR;
2282     SV *stashsv;
2283
2284     PERL_ARGS_ASSERT_APPLY_ATTRS;
2285
2286     /* fake up C<use attributes $pkg,$rv,@attrs> */
2287     ENTER;              /* need to protect against side-effects of 'use' */
2288     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2289
2290 #define ATTRSMODULE "attributes"
2291 #define ATTRSMODULE_PM "attributes.pm"
2292
2293     if (for_my) {
2294         /* Don't force the C<use> if we don't need it. */
2295         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2296         if (svp && *svp != &PL_sv_undef)
2297             NOOP;       /* already in %INC */
2298         else
2299             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2300                              newSVpvs(ATTRSMODULE), NULL);
2301     }
2302     else {
2303         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2304                          newSVpvs(ATTRSMODULE),
2305                          NULL,
2306                          op_prepend_elem(OP_LIST,
2307                                       newSVOP(OP_CONST, 0, stashsv),
2308                                       op_prepend_elem(OP_LIST,
2309                                                    newSVOP(OP_CONST, 0,
2310                                                            newRV(target)),
2311                                                    dup_attrlist(attrs))));
2312     }
2313     LEAVE;
2314 }
2315
2316 STATIC void
2317 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2318 {
2319     dVAR;
2320     OP *pack, *imop, *arg;
2321     SV *meth, *stashsv;
2322
2323     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2324
2325     if (!attrs)
2326         return;
2327
2328     assert(target->op_type == OP_PADSV ||
2329            target->op_type == OP_PADHV ||
2330            target->op_type == OP_PADAV);
2331
2332     /* Ensure that attributes.pm is loaded. */
2333     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2334
2335     /* Need package name for method call. */
2336     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2337
2338     /* Build up the real arg-list. */
2339     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2340
2341     arg = newOP(OP_PADSV, 0);
2342     arg->op_targ = target->op_targ;
2343     arg = op_prepend_elem(OP_LIST,
2344                        newSVOP(OP_CONST, 0, stashsv),
2345                        op_prepend_elem(OP_LIST,
2346                                     newUNOP(OP_REFGEN, 0,
2347                                             op_lvalue(arg, OP_REFGEN)),
2348                                     dup_attrlist(attrs)));
2349
2350     /* Fake up a method call to import */
2351     meth = newSVpvs_share("import");
2352     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2353                    op_append_elem(OP_LIST,
2354                                op_prepend_elem(OP_LIST, pack, list(arg)),
2355                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2356
2357     /* Combine the ops. */
2358     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2359 }
2360
2361 /*
2362 =notfor apidoc apply_attrs_string
2363
2364 Attempts to apply a list of attributes specified by the C<attrstr> and
2365 C<len> arguments to the subroutine identified by the C<cv> argument which
2366 is expected to be associated with the package identified by the C<stashpv>
2367 argument (see L<attributes>).  It gets this wrong, though, in that it
2368 does not correctly identify the boundaries of the individual attribute
2369 specifications within C<attrstr>.  This is not really intended for the
2370 public API, but has to be listed here for systems such as AIX which
2371 need an explicit export list for symbols.  (It's called from XS code
2372 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2373 to respect attribute syntax properly would be welcome.
2374
2375 =cut
2376 */
2377
2378 void
2379 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2380                         const char *attrstr, STRLEN len)
2381 {
2382     OP *attrs = NULL;
2383
2384     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2385
2386     if (!len) {
2387         len = strlen(attrstr);
2388     }
2389
2390     while (len) {
2391         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2392         if (len) {
2393             const char * const sstr = attrstr;
2394             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2395             attrs = op_append_elem(OP_LIST, attrs,
2396                                 newSVOP(OP_CONST, 0,
2397                                         newSVpvn(sstr, attrstr-sstr)));
2398         }
2399     }
2400
2401     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2402                      newSVpvs(ATTRSMODULE),
2403                      NULL, op_prepend_elem(OP_LIST,
2404                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2405                                   op_prepend_elem(OP_LIST,
2406                                                newSVOP(OP_CONST, 0,
2407                                                        newRV(MUTABLE_SV(cv))),
2408                                                attrs)));
2409 }
2410
2411 STATIC OP *
2412 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2413 {
2414     dVAR;
2415     I32 type;
2416     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2417
2418     PERL_ARGS_ASSERT_MY_KID;
2419
2420     if (!o || (PL_parser && PL_parser->error_count))
2421         return o;
2422
2423     type = o->op_type;
2424     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2425         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2426         return o;
2427     }
2428
2429     if (type == OP_LIST) {
2430         OP *kid;
2431         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2432             my_kid(kid, attrs, imopsp);
2433         return o;
2434     } else if (type == OP_UNDEF
2435 #ifdef PERL_MAD
2436                || type == OP_STUB
2437 #endif
2438                ) {
2439         return o;
2440     } else if (type == OP_RV2SV ||      /* "our" declaration */
2441                type == OP_RV2AV ||
2442                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2443         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2444             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2445                         OP_DESC(o),
2446                         PL_parser->in_my == KEY_our
2447                             ? "our"
2448                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2449         } else if (attrs) {
2450             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2451             PL_parser->in_my = FALSE;
2452             PL_parser->in_my_stash = NULL;
2453             apply_attrs(GvSTASH(gv),
2454                         (type == OP_RV2SV ? GvSV(gv) :
2455                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2456                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2457                         attrs, FALSE);
2458         }
2459         o->op_private |= OPpOUR_INTRO;
2460         return o;
2461     }
2462     else if (type != OP_PADSV &&
2463              type != OP_PADAV &&
2464              type != OP_PADHV &&
2465              type != OP_PUSHMARK)
2466     {
2467         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2468                           OP_DESC(o),
2469                           PL_parser->in_my == KEY_our
2470                             ? "our"
2471                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2472         return o;
2473     }
2474     else if (attrs && type != OP_PUSHMARK) {
2475         HV *stash;
2476
2477         PL_parser->in_my = FALSE;
2478         PL_parser->in_my_stash = NULL;
2479
2480         /* check for C<my Dog $spot> when deciding package */
2481         stash = PAD_COMPNAME_TYPE(o->op_targ);
2482         if (!stash)
2483             stash = PL_curstash;
2484         apply_attrs_my(stash, o, attrs, imopsp);
2485     }
2486     o->op_flags |= OPf_MOD;
2487     o->op_private |= OPpLVAL_INTRO;
2488     if (stately)
2489         o->op_private |= OPpPAD_STATE;
2490     return o;
2491 }
2492
2493 OP *
2494 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2495 {
2496     dVAR;
2497     OP *rops;
2498     int maybe_scalar = 0;
2499
2500     PERL_ARGS_ASSERT_MY_ATTRS;
2501
2502 /* [perl #17376]: this appears to be premature, and results in code such as
2503    C< our(%x); > executing in list mode rather than void mode */
2504 #if 0
2505     if (o->op_flags & OPf_PARENS)
2506         list(o);
2507     else
2508         maybe_scalar = 1;
2509 #else
2510     maybe_scalar = 1;
2511 #endif
2512     if (attrs)
2513         SAVEFREEOP(attrs);
2514     rops = NULL;
2515     o = my_kid(o, attrs, &rops);
2516     if (rops) {
2517         if (maybe_scalar && o->op_type == OP_PADSV) {
2518             o = scalar(op_append_list(OP_LIST, rops, o));
2519             o->op_private |= OPpLVAL_INTRO;
2520         }
2521         else {
2522             /* The listop in rops might have a pushmark at the beginning,
2523                which will mess up list assignment. */
2524             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2525             if (rops->op_type == OP_LIST &&
2526                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2527             {
2528                 OP * const pushmark = lrops->op_first;
2529                 lrops->op_first = pushmark->op_sibling;
2530                 op_free(pushmark);
2531             }
2532             o = op_append_list(OP_LIST, o, rops);
2533         }
2534     }
2535     PL_parser->in_my = FALSE;
2536     PL_parser->in_my_stash = NULL;
2537     return o;
2538 }
2539
2540 OP *
2541 Perl_sawparens(pTHX_ OP *o)
2542 {
2543     PERL_UNUSED_CONTEXT;
2544     if (o)
2545         o->op_flags |= OPf_PARENS;
2546     return o;
2547 }
2548
2549 OP *
2550 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2551 {
2552     OP *o;
2553     bool ismatchop = 0;
2554     const OPCODE ltype = left->op_type;
2555     const OPCODE rtype = right->op_type;
2556
2557     PERL_ARGS_ASSERT_BIND_MATCH;
2558
2559     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2560           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2561     {
2562       const char * const desc
2563           = PL_op_desc[(
2564                           rtype == OP_SUBST || rtype == OP_TRANS
2565                        || rtype == OP_TRANSR
2566                        )
2567                        ? (int)rtype : OP_MATCH];
2568       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2569       GV *gv;
2570       SV * const name =
2571        (ltype == OP_RV2AV || ltype == OP_RV2HV)
2572         ?    cUNOPx(left)->op_first->op_type == OP_GV
2573           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2574               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2575               : NULL
2576         : varname(
2577            (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2578           );
2579       if (name)
2580         Perl_warner(aTHX_ packWARN(WARN_MISC),
2581              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2582              desc, name, name);
2583       else {
2584         const char * const sample = (isary
2585              ? "@array" : "%hash");
2586         Perl_warner(aTHX_ packWARN(WARN_MISC),
2587              "Applying %s to %s will act on scalar(%s)",
2588              desc, sample, sample);
2589       }
2590     }
2591
2592     if (rtype == OP_CONST &&
2593         cSVOPx(right)->op_private & OPpCONST_BARE &&
2594         cSVOPx(right)->op_private & OPpCONST_STRICT)
2595     {
2596         no_bareword_allowed(right);
2597     }
2598
2599     /* !~ doesn't make sense with /r, so error on it for now */
2600     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2601         type == OP_NOT)
2602         yyerror("Using !~ with s///r doesn't make sense");
2603     if (rtype == OP_TRANSR && type == OP_NOT)
2604         yyerror("Using !~ with tr///r doesn't make sense");
2605
2606     ismatchop = (rtype == OP_MATCH ||
2607                  rtype == OP_SUBST ||
2608                  rtype == OP_TRANS || rtype == OP_TRANSR)
2609              && !(right->op_flags & OPf_SPECIAL);
2610     if (ismatchop && right->op_private & OPpTARGET_MY) {
2611         right->op_targ = 0;
2612         right->op_private &= ~OPpTARGET_MY;
2613     }
2614     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2615         OP *newleft;
2616
2617         right->op_flags |= OPf_STACKED;
2618         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2619             ! (rtype == OP_TRANS &&
2620                right->op_private & OPpTRANS_IDENTICAL) &&
2621             ! (rtype == OP_SUBST &&
2622                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2623             newleft = op_lvalue(left, rtype);
2624         else
2625             newleft = left;
2626         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2627             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2628         else
2629             o = op_prepend_elem(rtype, scalar(newleft), right);
2630         if (type == OP_NOT)
2631             return newUNOP(OP_NOT, 0, scalar(o));
2632         return o;
2633     }
2634     else
2635         return bind_match(type, left,
2636                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2637 }
2638
2639 OP *
2640 Perl_invert(pTHX_ OP *o)
2641 {
2642     if (!o)
2643         return NULL;
2644     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2645 }
2646
2647 /*
2648 =for apidoc Amx|OP *|op_scope|OP *o
2649
2650 Wraps up an op tree with some additional ops so that at runtime a dynamic
2651 scope will be created.  The original ops run in the new dynamic scope,
2652 and then, provided that they exit normally, the scope will be unwound.
2653 The additional ops used to create and unwind the dynamic scope will
2654 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2655 instead if the ops are simple enough to not need the full dynamic scope
2656 structure.
2657
2658 =cut
2659 */
2660
2661 OP *
2662 Perl_op_scope(pTHX_ OP *o)
2663 {
2664     dVAR;
2665     if (o) {
2666         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2667             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2668             o->op_type = OP_LEAVE;
2669             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2670         }
2671         else if (o->op_type == OP_LINESEQ) {
2672             OP *kid;
2673             o->op_type = OP_SCOPE;
2674             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2675             kid = ((LISTOP*)o)->op_first;
2676             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2677                 op_null(kid);
2678
2679                 /* The following deals with things like 'do {1 for 1}' */
2680                 kid = kid->op_sibling;
2681                 if (kid &&
2682                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2683                     op_null(kid);
2684             }
2685         }
2686         else
2687             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2688     }
2689     return o;
2690 }
2691
2692 int
2693 Perl_block_start(pTHX_ int full)
2694 {
2695     dVAR;
2696     const int retval = PL_savestack_ix;
2697
2698     pad_block_start(full);
2699     SAVEHINTS();
2700     PL_hints &= ~HINT_BLOCK_SCOPE;
2701     SAVECOMPILEWARNINGS();
2702     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2703
2704     CALL_BLOCK_HOOKS(bhk_start, full);
2705
2706     return retval;
2707 }
2708
2709 OP*
2710 Perl_block_end(pTHX_ I32 floor, OP *seq)
2711 {
2712     dVAR;
2713     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2714     OP* retval = scalarseq(seq);
2715
2716     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2717
2718     LEAVE_SCOPE(floor);
2719     CopHINTS_set(&PL_compiling, PL_hints);
2720     if (needblockscope)
2721         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2722     pad_leavemy();
2723
2724     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2725
2726     return retval;
2727 }
2728
2729 /*
2730 =head1 Compile-time scope hooks
2731
2732 =for apidoc Aox||blockhook_register
2733
2734 Register a set of hooks to be called when the Perl lexical scope changes
2735 at compile time. See L<perlguts/"Compile-time scope hooks">.
2736
2737 =cut
2738 */
2739
2740 void
2741 Perl_blockhook_register(pTHX_ BHK *hk)
2742 {
2743     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2744
2745     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2746 }
2747
2748 STATIC OP *
2749 S_newDEFSVOP(pTHX)
2750 {
2751     dVAR;
2752     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2753     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2754         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2755     }
2756     else {
2757         OP * const o = newOP(OP_PADSV, 0);
2758         o->op_targ = offset;
2759         return o;
2760     }
2761 }
2762
2763 void
2764 Perl_newPROG(pTHX_ OP *o)
2765 {
2766     dVAR;
2767
2768     PERL_ARGS_ASSERT_NEWPROG;
2769
2770     if (PL_in_eval) {
2771         PERL_CONTEXT *cx;
2772         I32 i;
2773         if (PL_eval_root)
2774                 return;
2775         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2776                                ((PL_in_eval & EVAL_KEEPERR)
2777                                 ? OPf_SPECIAL : 0), o);
2778
2779         cx = &cxstack[cxstack_ix];
2780         assert(CxTYPE(cx) == CXt_EVAL);
2781
2782         if ((cx->blk_gimme & G_WANT) == G_VOID)
2783             scalarvoid(PL_eval_root);
2784         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2785             list(PL_eval_root);
2786         else
2787             scalar(PL_eval_root);
2788
2789         /* don't use LINKLIST, since PL_eval_root might indirect through
2790          * a rather expensive function call and LINKLIST evaluates its
2791          * argument more than once */
2792         PL_eval_start = op_linklist(PL_eval_root);
2793         PL_eval_root->op_private |= OPpREFCOUNTED;
2794         OpREFCNT_set(PL_eval_root, 1);
2795         PL_eval_root->op_next = 0;
2796         i = PL_savestack_ix;
2797         SAVEFREEOP(o);
2798         ENTER;
2799         CALL_PEEP(PL_eval_start);
2800         finalize_optree(PL_eval_root);
2801         LEAVE;
2802         PL_savestack_ix = i;
2803     }
2804     else {
2805         if (o->op_type == OP_STUB) {
2806             PL_comppad_name = 0;
2807             PL_compcv = 0;
2808             S_op_destroy(aTHX_ o);
2809             return;
2810         }
2811         PL_main_root = op_scope(sawparens(scalarvoid(o)));
2812         PL_curcop = &PL_compiling;
2813         PL_main_start = LINKLIST(PL_main_root);
2814         PL_main_root->op_private |= OPpREFCOUNTED;
2815         OpREFCNT_set(PL_main_root, 1);
2816         PL_main_root->op_next = 0;
2817         CALL_PEEP(PL_main_start);
2818         finalize_optree(PL_main_root);
2819         PL_compcv = 0;
2820
2821         /* Register with debugger */
2822         if (PERLDB_INTER) {
2823             CV * const cv = get_cvs("DB::postponed", 0);
2824             if (cv) {
2825                 dSP;
2826                 PUSHMARK(SP);
2827                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2828                 PUTBACK;
2829                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2830             }
2831         }
2832     }
2833 }
2834
2835 OP *
2836 Perl_localize(pTHX_ OP *o, I32 lex)
2837 {
2838     dVAR;
2839
2840     PERL_ARGS_ASSERT_LOCALIZE;
2841
2842     if (o->op_flags & OPf_PARENS)
2843 /* [perl #17376]: this appears to be premature, and results in code such as
2844    C< our(%x); > executing in list mode rather than void mode */
2845 #if 0
2846         list(o);
2847 #else
2848         NOOP;
2849 #endif
2850     else {
2851         if ( PL_parser->bufptr > PL_parser->oldbufptr
2852             && PL_parser->bufptr[-1] == ','
2853             && ckWARN(WARN_PARENTHESIS))
2854         {
2855             char *s = PL_parser->bufptr;
2856             bool sigil = FALSE;
2857
2858             /* some heuristics to detect a potential error */
2859             while (*s && (strchr(", \t\n", *s)))
2860                 s++;
2861
2862             while (1) {
2863                 if (*s && strchr("@$%*", *s) && *++s
2864                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2865                     s++;
2866                     sigil = TRUE;
2867                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2868                         s++;
2869                     while (*s && (strchr(", \t\n", *s)))
2870                         s++;
2871                 }
2872                 else
2873                     break;
2874             }
2875             if (sigil && (*s == ';' || *s == '=')) {
2876                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2877                                 "Parentheses missing around \"%s\" list",
2878                                 lex
2879                                     ? (PL_parser->in_my == KEY_our
2880                                         ? "our"
2881                                         : PL_parser->in_my == KEY_state
2882                                             ? "state"
2883                                             : "my")
2884                                     : "local");
2885             }
2886         }
2887     }
2888     if (lex)
2889         o = my(o);
2890     else
2891         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
2892     PL_parser->in_my = FALSE;
2893     PL_parser->in_my_stash = NULL;
2894     return o;
2895 }
2896
2897 OP *
2898 Perl_jmaybe(pTHX_ OP *o)
2899 {
2900     PERL_ARGS_ASSERT_JMAYBE;
2901
2902     if (o->op_type == OP_LIST) {
2903         OP * const o2
2904             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2905         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2906     }
2907     return o;
2908 }
2909
2910 PERL_STATIC_INLINE OP *
2911 S_op_std_init(pTHX_ OP *o)
2912 {
2913     I32 type = o->op_type;
2914
2915     PERL_ARGS_ASSERT_OP_STD_INIT;
2916
2917     if (PL_opargs[type] & OA_RETSCALAR)
2918         scalar(o);
2919     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2920         o->op_targ = pad_alloc(type, SVs_PADTMP);
2921
2922     return o;
2923 }
2924
2925 PERL_STATIC_INLINE OP *
2926 S_op_integerize(pTHX_ OP *o)
2927 {
2928     I32 type = o->op_type;
2929
2930     PERL_ARGS_ASSERT_OP_INTEGERIZE;
2931
2932     /* integerize op, unless it happens to be C<-foo>.
2933      * XXX should pp_i_negate() do magic string negation instead? */
2934     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2935         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2936              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2937     {
2938         dVAR;
2939         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2940     }
2941
2942     if (type == OP_NEGATE)
2943         /* XXX might want a ck_negate() for this */
2944         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2945
2946     return o;
2947 }
2948
2949 static OP *
2950 S_fold_constants(pTHX_ register OP *o)
2951 {
2952     dVAR;
2953     register OP * VOL curop;
2954     OP *newop;
2955     VOL I32 type = o->op_type;
2956     SV * VOL sv = NULL;
2957     int ret = 0;
2958     I32 oldscope;
2959     OP *old_next;
2960     SV * const oldwarnhook = PL_warnhook;
2961     SV * const olddiehook  = PL_diehook;
2962     COP not_compiling;
2963     dJMPENV;
2964
2965     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2966
2967     if (!(PL_opargs[type] & OA_FOLDCONST))
2968         goto nope;
2969
2970     switch (type) {
2971     case OP_UCFIRST:
2972     case OP_LCFIRST:
2973     case OP_UC:
2974     case OP_LC:
2975     case OP_SLT:
2976     case OP_SGT:
2977     case OP_SLE:
2978     case OP_SGE:
2979     case OP_SCMP:
2980     case OP_SPRINTF:
2981         /* XXX what about the numeric ops? */
2982         if (IN_LOCALE_COMPILETIME)
2983             goto nope;
2984         break;
2985     }
2986
2987     if (PL_parser && PL_parser->error_count)
2988         goto nope;              /* Don't try to run w/ errors */
2989
2990     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2991         const OPCODE type = curop->op_type;
2992         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2993             type != OP_LIST &&
2994             type != OP_SCALAR &&
2995             type != OP_NULL &&
2996             type != OP_PUSHMARK)
2997         {
2998             goto nope;
2999         }
3000     }
3001
3002     curop = LINKLIST(o);
3003     old_next = o->op_next;
3004     o->op_next = 0;
3005     PL_op = curop;
3006
3007     oldscope = PL_scopestack_ix;
3008     create_eval_scope(G_FAKINGEVAL);
3009
3010     /* Verify that we don't need to save it:  */
3011     assert(PL_curcop == &PL_compiling);
3012     StructCopy(&PL_compiling, &not_compiling, COP);
3013     PL_curcop = &not_compiling;
3014     /* The above ensures that we run with all the correct hints of the
3015        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3016     assert(IN_PERL_RUNTIME);
3017     PL_warnhook = PERL_WARNHOOK_FATAL;
3018     PL_diehook  = NULL;
3019     JMPENV_PUSH(ret);
3020
3021     switch (ret) {
3022     case 0:
3023         CALLRUNOPS(aTHX);
3024         sv = *(PL_stack_sp--);
3025         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3026 #ifdef PERL_MAD
3027             /* Can't simply swipe the SV from the pad, because that relies on
3028                the op being freed "real soon now". Under MAD, this doesn't
3029                happen (see the #ifdef below).  */
3030             sv = newSVsv(sv);
3031 #else
3032             pad_swipe(o->op_targ,  FALSE);
3033 #endif
3034         }
3035         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3036             SvREFCNT_inc_simple_void(sv);
3037             SvTEMP_off(sv);
3038         }
3039         break;
3040     case 3:
3041         /* Something tried to die.  Abandon constant folding.  */
3042         /* Pretend the error never happened.  */
3043         CLEAR_ERRSV();
3044         o->op_next = old_next;
3045         break;
3046     default:
3047         JMPENV_POP;
3048         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3049         PL_warnhook = oldwarnhook;
3050         PL_diehook  = olddiehook;
3051         /* XXX note that this croak may fail as we've already blown away
3052          * the stack - eg any nested evals */
3053         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3054     }
3055     JMPENV_POP;
3056     PL_warnhook = oldwarnhook;
3057     PL_diehook  = olddiehook;
3058     PL_curcop = &PL_compiling;
3059
3060     if (PL_scopestack_ix > oldscope)
3061         delete_eval_scope();
3062
3063     if (ret)
3064         goto nope;
3065
3066 #ifndef PERL_MAD
3067     op_free(o);
3068 #endif
3069     assert(sv);
3070     if (type == OP_RV2GV)
3071         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3072     else
3073         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3074     op_getmad(o,newop,'f');
3075     return newop;
3076
3077  nope:
3078     return o;
3079 }
3080
3081 static OP *
3082 S_gen_constant_list(pTHX_ register OP *o)
3083 {
3084     dVAR;
3085     register OP *curop;
3086     const I32 oldtmps_floor = PL_tmps_floor;
3087
3088     list(o);
3089     if (PL_parser && PL_parser->error_count)
3090         return o;               /* Don't attempt to run with errors */
3091
3092     PL_op = curop = LINKLIST(o);
3093     o->op_next = 0;
3094     CALL_PEEP(curop);
3095     Perl_pp_pushmark(aTHX);
3096     CALLRUNOPS(aTHX);
3097     PL_op = curop;
3098     assert (!(curop->op_flags & OPf_SPECIAL));
3099     assert(curop->op_type == OP_RANGE);
3100     Perl_pp_anonlist(aTHX);
3101     PL_tmps_floor = oldtmps_floor;
3102
3103     o->op_type = OP_RV2AV;
3104     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3105     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3106     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3107     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3108     curop = ((UNOP*)o)->op_first;
3109     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3110 #ifdef PERL_MAD
3111     op_getmad(curop,o,'O');
3112 #else
3113     op_free(curop);
3114 #endif
3115     LINKLIST(o);
3116     return list(o);
3117 }
3118
3119 OP *
3120 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3121 {
3122     dVAR;
3123     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3124     if (!o || o->op_type != OP_LIST)
3125         o = newLISTOP(OP_LIST, 0, o, NULL);
3126     else
3127         o->op_flags &= ~OPf_WANT;
3128
3129     if (!(PL_opargs[type] & OA_MARK))
3130         op_null(cLISTOPo->op_first);
3131     else {
3132         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3133         if (kid2 && kid2->op_type == OP_COREARGS) {
3134             op_null(cLISTOPo->op_first);
3135             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3136         }
3137     }
3138
3139     o->op_type = (OPCODE)type;
3140     o->op_ppaddr = PL_ppaddr[type];
3141     o->op_flags |= flags;
3142
3143     o = CHECKOP(type, o);
3144     if (o->op_type != (unsigned)type)
3145         return o;
3146
3147     return fold_constants(op_integerize(op_std_init(o)));
3148 }
3149
3150 /*
3151 =head1 Optree Manipulation Functions
3152 */
3153
3154 /* List constructors */
3155
3156 /*
3157 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3158
3159 Append an item to the list of ops contained directly within a list-type
3160 op, returning the lengthened list.  I<first> is the list-type op,
3161 and I<last> is the op to append to the list.  I<optype> specifies the
3162 intended opcode for the list.  If I<first> is not already a list of the
3163 right type, it will be upgraded into one.  If either I<first> or I<last>
3164 is null, the other is returned unchanged.
3165
3166 =cut
3167 */
3168
3169 OP *
3170 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3171 {
3172     if (!first)
3173         return last;
3174
3175     if (!last)
3176         return first;
3177
3178     if (first->op_type != (unsigned)type
3179         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3180     {
3181         return newLISTOP(type, 0, first, last);
3182     }
3183
3184     if (first->op_flags & OPf_KIDS)
3185         ((LISTOP*)first)->op_last->op_sibling = last;
3186     else {
3187         first->op_flags |= OPf_KIDS;
3188         ((LISTOP*)first)->op_first = last;
3189     }
3190     ((LISTOP*)first)->op_last = last;
3191     return first;
3192 }
3193
3194 /*
3195 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3196
3197 Concatenate the lists of ops contained directly within two list-type ops,
3198 returning the combined list.  I<first> and I<last> are the list-type ops
3199 to concatenate.  I<optype> specifies the intended opcode for the list.
3200 If either I<first> or I<last> is not already a list of the right type,
3201 it will be upgraded into one.  If either I<first> or I<last> is null,
3202 the other is returned unchanged.
3203
3204 =cut
3205 */
3206
3207 OP *
3208 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3209 {
3210     if (!first)
3211         return last;
3212
3213     if (!last)
3214         return first;
3215
3216     if (first->op_type != (unsigned)type)
3217         return op_prepend_elem(type, first, last);
3218
3219     if (last->op_type != (unsigned)type)
3220         return op_append_elem(type, first, last);
3221
3222     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3223     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3224     first->op_flags |= (last->op_flags & OPf_KIDS);
3225
3226 #ifdef PERL_MAD
3227     if (((LISTOP*)last)->op_first && first->op_madprop) {
3228         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3229         if (mp) {
3230             while (mp->mad_next)
3231                 mp = mp->mad_next;
3232             mp->mad_next = first->op_madprop;
3233         }
3234         else {
3235             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3236         }
3237     }
3238     first->op_madprop = last->op_madprop;
3239     last->op_madprop = 0;
3240 #endif
3241
3242     S_op_destroy(aTHX_ last);
3243
3244     return first;
3245 }
3246
3247 /*
3248 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3249
3250 Prepend an item to the list of ops contained directly within a list-type
3251 op, returning the lengthened list.  I<first> is the op to prepend to the
3252 list, and I<last> is the list-type op.  I<optype> specifies the intended
3253 opcode for the list.  If I<last> is not already a list of the right type,
3254 it will be upgraded into one.  If either I<first> or I<last> is null,
3255 the other is returned unchanged.
3256
3257 =cut
3258 */
3259
3260 OP *
3261 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3262 {
3263     if (!first)
3264         return last;
3265
3266     if (!last)
3267         return first;
3268
3269     if (last->op_type == (unsigned)type) {
3270         if (type == OP_LIST) {  /* already a PUSHMARK there */
3271             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3272             ((LISTOP*)last)->op_first->op_sibling = first;
3273             if (!(first->op_flags & OPf_PARENS))
3274                 last->op_flags &= ~OPf_PARENS;
3275         }
3276         else {
3277             if (!(last->op_flags & OPf_KIDS)) {
3278                 ((LISTOP*)last)->op_last = first;
3279                 last->op_flags |= OPf_KIDS;
3280             }
3281             first->op_sibling = ((LISTOP*)last)->op_first;
3282             ((LISTOP*)last)->op_first = first;
3283         }
3284         last->op_flags |= OPf_KIDS;
3285         return last;
3286     }
3287
3288     return newLISTOP(type, 0, first, last);
3289 }
3290
3291 /* Constructors */
3292
3293 #ifdef PERL_MAD
3294
3295 TOKEN *
3296 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3297 {
3298     TOKEN *tk;
3299     Newxz(tk, 1, TOKEN);
3300     tk->tk_type = (OPCODE)optype;
3301     tk->tk_type = 12345;
3302     tk->tk_lval = lval;
3303     tk->tk_mad = madprop;
3304     return tk;
3305 }
3306
3307 void
3308 Perl_token_free(pTHX_ TOKEN* tk)
3309 {
3310     PERL_ARGS_ASSERT_TOKEN_FREE;
3311
3312     if (tk->tk_type != 12345)
3313         return;
3314     mad_free(tk->tk_mad);
3315     Safefree(tk);
3316 }
3317
3318 void
3319 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3320 {
3321     MADPROP* mp;
3322     MADPROP* tm;
3323
3324     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3325
3326     if (tk->tk_type != 12345) {
3327         Perl_warner(aTHX_ packWARN(WARN_MISC),
3328              "Invalid TOKEN object ignored");
3329         return;
3330     }
3331     tm = tk->tk_mad;
3332     if (!tm)
3333         return;
3334
3335     /* faked up qw list? */
3336     if (slot == '(' &&
3337         tm->mad_type == MAD_SV &&
3338         SvPVX((SV *)tm->mad_val)[0] == 'q')
3339             slot = 'x';
3340
3341     if (o) {
3342         mp = o->op_madprop;
3343         if (mp) {
3344             for (;;) {
3345                 /* pretend constant fold didn't happen? */
3346                 if (mp->mad_key == 'f' &&
3347                     (o->op_type == OP_CONST ||
3348                      o->op_type == OP_GV) )
3349                 {
3350                     token_getmad(tk,(OP*)mp->mad_val,slot);
3351                     return;
3352                 }
3353                 if (!mp->mad_next)
3354                     break;
3355                 mp = mp->mad_next;
3356             }
3357             mp->mad_next = tm;
3358             mp = mp->mad_next;
3359         }
3360         else {
3361             o->op_madprop = tm;
3362             mp = o->op_madprop;
3363         }
3364         if (mp->mad_key == 'X')
3365             mp->mad_key = slot; /* just change the first one */
3366
3367         tk->tk_mad = 0;
3368     }
3369     else
3370         mad_free(tm);
3371     Safefree(tk);
3372 }
3373
3374 void
3375 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3376 {
3377     MADPROP* mp;
3378     if (!from)
3379         return;
3380     if (o) {
3381         mp = o->op_madprop;
3382         if (mp) {
3383             for (;;) {
3384                 /* pretend constant fold didn't happen? */
3385                 if (mp->mad_key == 'f' &&
3386                     (o->op_type == OP_CONST ||
3387                      o->op_type == OP_GV) )
3388                 {
3389                     op_getmad(from,(OP*)mp->mad_val,slot);
3390                     return;
3391                 }
3392                 if (!mp->mad_next)
3393                     break;
3394                 mp = mp->mad_next;
3395             }
3396             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3397         }
3398         else {
3399             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3400         }
3401     }
3402 }
3403
3404 void
3405 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3406 {
3407     MADPROP* mp;
3408     if (!from)
3409         return;
3410     if (o) {
3411         mp = o->op_madprop;
3412         if (mp) {
3413             for (;;) {
3414                 /* pretend constant fold didn't happen? */
3415                 if (mp->mad_key == 'f' &&
3416                     (o->op_type == OP_CONST ||
3417                      o->op_type == OP_GV) )
3418                 {
3419                     op_getmad(from,(OP*)mp->mad_val,slot);
3420                     return;
3421                 }
3422                 if (!mp->mad_next)
3423                     break;
3424                 mp = mp->mad_next;
3425             }
3426             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3427         }
3428         else {
3429             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3430         }
3431     }
3432     else {
3433         PerlIO_printf(PerlIO_stderr(),
3434                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3435         op_free(from);
3436     }
3437 }
3438
3439 void
3440 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3441 {
3442     MADPROP* tm;
3443     if (!mp || !o)
3444         return;
3445     if (slot)
3446         mp->mad_key = slot;
3447     tm = o->op_madprop;
3448     o->op_madprop = mp;
3449     for (;;) {
3450         if (!mp->mad_next)
3451             break;
3452         mp = mp->mad_next;
3453     }
3454     mp->mad_next = tm;
3455 }
3456
3457 void
3458 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3459 {
3460     if (!o)
3461         return;
3462     addmad(tm, &(o->op_madprop), slot);
3463 }
3464
3465 void
3466 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3467 {
3468     MADPROP* mp;
3469     if (!tm || !root)
3470         return;
3471     if (slot)
3472         tm->mad_key = slot;
3473     mp = *root;
3474     if (!mp) {
3475         *root = tm;
3476         return;
3477     }
3478     for (;;) {
3479         if (!mp->mad_next)
3480             break;
3481         mp = mp->mad_next;
3482     }
3483     mp->mad_next = tm;
3484 }
3485
3486 MADPROP *
3487 Perl_newMADsv(pTHX_ char key, SV* sv)
3488 {
3489     PERL_ARGS_ASSERT_NEWMADSV;
3490
3491     return newMADPROP(key, MAD_SV, sv, 0);
3492 }
3493
3494 MADPROP *
3495 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3496 {
3497     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3498     mp->mad_next = 0;
3499     mp->mad_key = key;
3500     mp->mad_vlen = vlen;
3501     mp->mad_type = type;
3502     mp->mad_val = val;
3503 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3504     return mp;
3505 }
3506
3507 void
3508 Perl_mad_free(pTHX_ MADPROP* mp)
3509 {
3510 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3511     if (!mp)
3512         return;
3513     if (mp->mad_next)
3514         mad_free(mp->mad_next);
3515 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3516         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3517     switch (mp->mad_type) {
3518     case MAD_NULL:
3519         break;
3520     case MAD_PV:
3521         Safefree((char*)mp->mad_val);
3522         break;
3523     case MAD_OP:
3524         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3525             op_free((OP*)mp->mad_val);
3526         break;
3527     case MAD_SV:
3528         sv_free(MUTABLE_SV(mp->mad_val));
3529         break;
3530     default:
3531         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3532         break;
3533     }
3534     PerlMemShared_free(mp);
3535 }
3536
3537 #endif
3538
3539 /*
3540 =head1 Optree construction
3541
3542 =for apidoc Am|OP *|newNULLLIST
3543
3544 Constructs, checks, and returns a new C<stub> op, which represents an
3545 empty list expression.
3546
3547 =cut
3548 */
3549
3550 OP *
3551 Perl_newNULLLIST(pTHX)
3552 {
3553     return newOP(OP_STUB, 0);
3554 }
3555
3556 static OP *
3557 S_force_list(pTHX_ OP *o)
3558 {
3559     if (!o || o->op_type != OP_LIST)
3560         o = newLISTOP(OP_LIST, 0, o, NULL);
3561     op_null(o);
3562     return o;
3563 }
3564
3565 /*
3566 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3567
3568 Constructs, checks, and returns an op of any list type.  I<type> is
3569 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3570 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3571 supply up to two ops to be direct children of the list op; they are
3572 consumed by this function and become part of the constructed op tree.
3573
3574 =cut
3575 */
3576
3577 OP *
3578 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3579 {
3580     dVAR;
3581     LISTOP *listop;
3582
3583     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3584
3585     NewOp(1101, listop, 1, LISTOP);
3586
3587     listop->op_type = (OPCODE)type;
3588     listop->op_ppaddr = PL_ppaddr[type];
3589     if (first || last)
3590         flags |= OPf_KIDS;
3591     listop->op_flags = (U8)flags;
3592
3593     if (!last && first)
3594         last = first;
3595     else if (!first && last)
3596         first = last;
3597     else if (first)
3598         first->op_sibling = last;
3599     listop->op_first = first;
3600     listop->op_last = last;
3601     if (type == OP_LIST) {
3602         OP* const pushop = newOP(OP_PUSHMARK, 0);
3603         pushop->op_sibling = first;
3604         listop->op_first = pushop;
3605         listop->op_flags |= OPf_KIDS;
3606         if (!last)
3607             listop->op_last = pushop;
3608     }
3609
3610     return CHECKOP(type, listop);
3611 }
3612
3613 /*
3614 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3615
3616 Constructs, checks, and returns an op of any base type (any type that
3617 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3618 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3619 of C<op_private>.
3620
3621 =cut
3622 */
3623
3624 OP *
3625 Perl_newOP(pTHX_ I32 type, I32 flags)
3626 {
3627     dVAR;
3628     OP *o;
3629
3630     if (type == -OP_ENTEREVAL) {
3631         type = OP_ENTEREVAL;
3632         flags |= OPpEVAL_BYTES<<8;
3633     }
3634
3635     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3636         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3637         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3638         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3639
3640     NewOp(1101, o, 1, OP);
3641     o->op_type = (OPCODE)type;
3642     o->op_ppaddr = PL_ppaddr[type];
3643     o->op_flags = (U8)flags;
3644     o->op_latefree = 0;
3645     o->op_latefreed = 0;
3646     o->op_attached = 0;
3647
3648     o->op_next = o;
3649     o->op_private = (U8)(0 | (flags >> 8));
3650     if (PL_opargs[type] & OA_RETSCALAR)
3651         scalar(o);
3652     if (PL_opargs[type] & OA_TARGET)
3653         o->op_targ = pad_alloc(type, SVs_PADTMP);
3654     return CHECKOP(type, o);
3655 }
3656
3657 /*
3658 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3659
3660 Constructs, checks, and returns an op of any unary type.  I<type> is
3661 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3662 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3663 bits, the eight bits of C<op_private>, except that the bit with value 1
3664 is automatically set.  I<first> supplies an optional op to be the direct
3665 child of the unary op; it is consumed by this function and become part
3666 of the constructed op tree.
3667
3668 =cut
3669 */
3670
3671 OP *
3672 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3673 {
3674     dVAR;
3675     UNOP *unop;
3676
3677     if (type == -OP_ENTEREVAL) {
3678         type = OP_ENTEREVAL;
3679         flags |= OPpEVAL_BYTES<<8;
3680     }
3681
3682     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3683         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3684         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3685         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3686         || type == OP_SASSIGN
3687         || type == OP_ENTERTRY
3688         || type == OP_NULL );
3689
3690     if (!first)
3691         first = newOP(OP_STUB, 0);
3692     if (PL_opargs[type] & OA_MARK)
3693         first = force_list(first);
3694
3695     NewOp(1101, unop, 1, UNOP);
3696     unop->op_type = (OPCODE)type;
3697     unop->op_ppaddr = PL_ppaddr[type];
3698     unop->op_first = first;
3699     unop->op_flags = (U8)(flags | OPf_KIDS);
3700     unop->op_private = (U8)(1 | (flags >> 8));
3701     unop = (UNOP*) CHECKOP(type, unop);
3702     if (unop->op_next)
3703         return (OP*)unop;
3704
3705     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3706 }
3707
3708 /*
3709 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3710
3711 Constructs, checks, and returns an op of any binary type.  I<type>
3712 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3713 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3714 the eight bits of C<op_private>, except that the bit with value 1 or
3715 2 is automatically set as required.  I<first> and I<last> supply up to
3716 two ops to be the direct children of the binary op; they are consumed
3717 by this function and become part of the constructed op tree.
3718
3719 =cut
3720 */
3721
3722 OP *
3723 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3724 {
3725     dVAR;
3726     BINOP *binop;
3727
3728     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3729         || type == OP_SASSIGN || type == OP_NULL );
3730
3731     NewOp(1101, binop, 1, BINOP);
3732
3733     if (!first)
3734         first = newOP(OP_NULL, 0);
3735
3736     binop->op_type = (OPCODE)type;
3737     binop->op_ppaddr = PL_ppaddr[type];
3738     binop->op_first = first;
3739     binop->op_flags = (U8)(flags | OPf_KIDS);
3740     if (!last) {
3741         last = first;
3742         binop->op_private = (U8)(1 | (flags >> 8));
3743     }
3744     else {
3745         binop->op_private = (U8)(2 | (flags >> 8));
3746         first->op_sibling = last;
3747     }
3748
3749     binop = (BINOP*)CHECKOP(type, binop);
3750     if (binop->op_next || binop->op_type != (OPCODE)type)
3751         return (OP*)binop;
3752
3753     binop->op_last = binop->op_first->op_sibling;
3754
3755     return fold_constants(op_integerize(op_std_init((OP *)binop)));
3756 }
3757
3758 static int uvcompare(const void *a, const void *b)
3759     __attribute__nonnull__(1)
3760     __attribute__nonnull__(2)
3761     __attribute__pure__;
3762 static int uvcompare(const void *a, const void *b)
3763 {
3764     if (*((const UV *)a) < (*(const UV *)b))
3765         return -1;
3766     if (*((const UV *)a) > (*(const UV *)b))
3767         return 1;
3768     if (*((const UV *)a+1) < (*(const UV *)b+1))
3769         return -1;
3770     if (*((const UV *)a+1) > (*(const UV *)b+1))
3771         return 1;
3772     return 0;
3773 }
3774
3775 static OP *
3776 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3777 {
3778     dVAR;
3779     SV * const tstr = ((SVOP*)expr)->op_sv;
3780     SV * const rstr =
3781 #ifdef PERL_MAD
3782                         (repl->op_type == OP_NULL)
3783                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3784 #endif
3785                               ((SVOP*)repl)->op_sv;
3786     STRLEN tlen;
3787     STRLEN rlen;
3788     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3789     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3790     register I32 i;
3791     register I32 j;
3792     I32 grows = 0;
3793     register short *tbl;
3794
3795     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3796     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3797     I32 del              = o->op_private & OPpTRANS_DELETE;
3798     SV* swash;
3799
3800     PERL_ARGS_ASSERT_PMTRANS;
3801
3802     PL_hints |= HINT_BLOCK_SCOPE;
3803
3804     if (SvUTF8(tstr))
3805         o->op_private |= OPpTRANS_FROM_UTF;
3806
3807     if (SvUTF8(rstr))
3808         o->op_private |= OPpTRANS_TO_UTF;
3809
3810     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3811         SV* const listsv = newSVpvs("# comment\n");
3812         SV* transv = NULL;
3813         const U8* tend = t + tlen;
3814         const U8* rend = r + rlen;
3815         STRLEN ulen;
3816         UV tfirst = 1;
3817         UV tlast = 0;
3818         IV tdiff;
3819         UV rfirst = 1;
3820         UV rlast = 0;
3821         IV rdiff;
3822         IV diff;
3823         I32 none = 0;
3824         U32 max = 0;
3825         I32 bits;
3826         I32 havefinal = 0;
3827         U32 final = 0;
3828         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3829         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3830         U8* tsave = NULL;
3831         U8* rsave = NULL;
3832         const U32 flags = UTF8_ALLOW_DEFAULT;
3833
3834         if (!from_utf) {
3835             STRLEN len = tlen;
3836             t = tsave = bytes_to_utf8(t, &len);
3837             tend = t + len;
3838         }
3839         if (!to_utf && rlen) {
3840             STRLEN len = rlen;
3841             r = rsave = bytes_to_utf8(r, &len);
3842             rend = r + len;
3843         }
3844
3845 /* There are several snags with this code on EBCDIC:
3846    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3847    2. scan_const() in toke.c has encoded chars in native encoding which makes
3848       ranges at least in EBCDIC 0..255 range the bottom odd.
3849 */
3850
3851         if (complement) {
3852             U8 tmpbuf[UTF8_MAXBYTES+1];
3853             UV *cp;
3854             UV nextmin = 0;
3855             Newx(cp, 2*tlen, UV);
3856             i = 0;
3857             transv = newSVpvs("");
3858             while (t < tend) {
3859                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3860                 t += ulen;
3861                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3862                     t++;
3863                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3864                     t += ulen;
3865                 }
3866                 else {
3867                  cp[2*i+1] = cp[2*i];
3868                 }
3869                 i++;
3870             }
3871             qsort(cp, i, 2*sizeof(UV), uvcompare);
3872             for (j = 0; j < i; j++) {
3873                 UV  val = cp[2*j];
3874                 diff = val - nextmin;
3875                 if (diff > 0) {
3876                     t = uvuni_to_utf8(tmpbuf,nextmin);
3877                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3878                     if (diff > 1) {
3879                         U8  range_mark = UTF_TO_NATIVE(0xff);
3880                         t = uvuni_to_utf8(tmpbuf, val - 1);
3881                         sv_catpvn(transv, (char *)&range_mark, 1);
3882                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3883                     }
3884                 }
3885                 val = cp[2*j+1];
3886                 if (val >= nextmin)
3887                     nextmin = val + 1;
3888             }
3889             t = uvuni_to_utf8(tmpbuf,nextmin);
3890             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3891             {
3892                 U8 range_mark = UTF_TO_NATIVE(0xff);
3893                 sv_catpvn(transv, (char *)&range_mark, 1);
3894             }
3895             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3896             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3897             t = (const U8*)SvPVX_const(transv);
3898             tlen = SvCUR(transv);
3899             tend = t + tlen;
3900             Safefree(cp);
3901         }
3902         else if (!rlen && !del) {
3903             r = t; rlen = tlen; rend = tend;
3904         }
3905         if (!squash) {
3906                 if ((!rlen && !del) || t == r ||
3907                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3908                 {
3909                     o->op_private |= OPpTRANS_IDENTICAL;
3910                 }
3911         }
3912
3913         while (t < tend || tfirst <= tlast) {
3914             /* see if we need more "t" chars */
3915             if (tfirst > tlast) {
3916                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3917                 t += ulen;
3918                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3919                     t++;
3920                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3921                     t += ulen;
3922                 }
3923                 else
3924                     tlast = tfirst;
3925             }
3926
3927             /* now see if we need more "r" chars */
3928             if (rfirst > rlast) {
3929                 if (r < rend) {
3930                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3931                     r += ulen;
3932                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3933                         r++;
3934                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3935                         r += ulen;
3936                     }
3937                     else
3938                         rlast = rfirst;
3939                 }
3940                 else {
3941                     if (!havefinal++)
3942                         final = rlast;
3943                     rfirst = rlast = 0xffffffff;
3944                 }
3945             }
3946
3947             /* now see which range will peter our first, if either. */
3948             tdiff = tlast - tfirst;
3949             rdiff = rlast - rfirst;
3950
3951             if (tdiff <= rdiff)
3952                 diff = tdiff;
3953             else
3954                 diff = rdiff;
3955
3956             if (rfirst == 0xffffffff) {
3957                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3958                 if (diff > 0)
3959                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3960                                    (long)tfirst, (long)tlast);
3961                 else
3962                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3963             }
3964             else {
3965                 if (diff > 0)
3966                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3967                                    (long)tfirst, (long)(tfirst + diff),
3968                                    (long)rfirst);
3969                 else
3970                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3971                                    (long)tfirst, (long)rfirst);
3972
3973                 if (rfirst + diff > max)
3974                     max = rfirst + diff;
3975                 if (!grows)
3976                     grows = (tfirst < rfirst &&
3977                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3978                 rfirst += diff + 1;
3979             }
3980             tfirst += diff + 1;
3981         }
3982
3983         none = ++max;
3984         if (del)
3985             del = ++max;
3986
3987         if (max > 0xffff)
3988             bits = 32;
3989         else if (max > 0xff)
3990             bits = 16;
3991         else
3992             bits = 8;
3993
3994         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3995 #ifdef USE_ITHREADS
3996         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3997         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3998         PAD_SETSV(cPADOPo->op_padix, swash);
3999         SvPADTMP_on(swash);
4000         SvREADONLY_on(swash);
4001 #else
4002         cSVOPo->op_sv = swash;
4003 #endif
4004         SvREFCNT_dec(listsv);
4005         SvREFCNT_dec(transv);
4006
4007         if (!del && havefinal && rlen)
4008             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4009                            newSVuv((UV)final), 0);
4010
4011         if (grows)
4012             o->op_private |= OPpTRANS_GROWS;
4013
4014         Safefree(tsave);
4015         Safefree(rsave);
4016
4017 #ifdef PERL_MAD
4018         op_getmad(expr,o,'e');
4019         op_getmad(repl,o,'r');
4020 #else
4021         op_free(expr);
4022         op_free(repl);
4023 #endif
4024         return o;
4025     }
4026
4027     tbl = (short*)PerlMemShared_calloc(
4028         (o->op_private & OPpTRANS_COMPLEMENT) &&
4029             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4030         sizeof(short));
4031     cPVOPo->op_pv = (char*)tbl;
4032     if (complement) {
4033         for (i = 0; i < (I32)tlen; i++)
4034             tbl[t[i]] = -1;
4035         for (i = 0, j = 0; i < 256; i++) {
4036             if (!tbl[i]) {
4037                 if (j >= (I32)rlen) {
4038                     if (del)
4039                         tbl[i] = -2;
4040                     else if (rlen)
4041                         tbl[i] = r[j-1];
4042                     else
4043                         tbl[i] = (short)i;
4044                 }
4045                 else {
4046                     if (i < 128 && r[j] >= 128)
4047                         grows = 1;
4048                     tbl[i] = r[j++];
4049                 }
4050             }
4051         }
4052         if (!del) {
4053             if (!rlen) {
4054                 j = rlen;
4055                 if (!squash)
4056                     o->op_private |= OPpTRANS_IDENTICAL;
4057             }
4058             else if (j >= (I32)rlen)
4059                 j = rlen - 1;
4060             else {
4061                 tbl =
4062                     (short *)
4063                     PerlMemShared_realloc(tbl,
4064                                           (0x101+rlen-j) * sizeof(short));
4065                 cPVOPo->op_pv = (char*)tbl;
4066             }
4067             tbl[0x100] = (short)(rlen - j);
4068             for (i=0; i < (I32)rlen - j; i++)
4069                 tbl[0x101+i] = r[j+i];
4070         }
4071     }
4072     else {
4073         if (!rlen && !del) {
4074             r = t; rlen = tlen;
4075             if (!squash)
4076                 o->op_private |= OPpTRANS_IDENTICAL;
4077         }
4078         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4079             o->op_private |= OPpTRANS_IDENTICAL;
4080         }
4081         for (i = 0; i < 256; i++)
4082             tbl[i] = -1;
4083         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4084             if (j >= (I32)rlen) {
4085                 if (del) {
4086                     if (tbl[t[i]] == -1)
4087                         tbl[t[i]] = -2;
4088                     continue;
4089                 }
4090                 --j;
4091             }
4092             if (tbl[t[i]] == -1) {
4093                 if (t[i] < 128 && r[j] >= 128)
4094                     grows = 1;
4095                 tbl[t[i]] = r[j];
4096             }
4097         }
4098     }
4099
4100     if(del && rlen == tlen) {
4101         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4102     } else if(rlen > tlen) {
4103         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4104     }
4105
4106     if (grows)
4107         o->op_private |= OPpTRANS_GROWS;
4108 #ifdef PERL_MAD
4109     op_getmad(expr,o,'e');
4110     op_getmad(repl,o,'r');
4111 #else
4112     op_free(expr);
4113     op_free(repl);
4114 #endif
4115
4116     return o;
4117 }
4118
4119 /*
4120 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4121
4122 Constructs, checks, and returns an op of any pattern matching type.
4123 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4124 and, shifted up eight bits, the eight bits of C<op_private>.
4125
4126 =cut
4127 */
4128
4129 OP *
4130 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4131 {
4132     dVAR;
4133     PMOP *pmop;
4134
4135     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4136
4137     NewOp(1101, pmop, 1, PMOP);
4138     pmop->op_type = (OPCODE)type;
4139     pmop->op_ppaddr = PL_ppaddr[type];
4140     pmop->op_flags = (U8)flags;
4141     pmop->op_private = (U8)(0 | (flags >> 8));
4142
4143     if (PL_hints & HINT_RE_TAINT)
4144         pmop->op_pmflags |= PMf_RETAINT;
4145     if (IN_LOCALE_COMPILETIME) {
4146         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4147     }
4148     else if ((! (PL_hints & HINT_BYTES))
4149                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4150              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4151     {
4152         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4153     }
4154     if (PL_hints & HINT_RE_FLAGS) {
4155         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4156          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4157         );
4158         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4159         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4160          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4161         );
4162         if (reflags && SvOK(reflags)) {
4163             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4164         }
4165     }
4166
4167
4168 #ifdef USE_ITHREADS
4169     assert(SvPOK(PL_regex_pad[0]));
4170     if (SvCUR(PL_regex_pad[0])) {
4171         /* Pop off the "packed" IV from the end.  */
4172         SV *const repointer_list = PL_regex_pad[0];
4173         const char *p = SvEND(repointer_list) - sizeof(IV);
4174         const IV offset = *((IV*)p);
4175
4176         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4177
4178         SvEND_set(repointer_list, p);
4179
4180         pmop->op_pmoffset = offset;
4181         /* This slot should be free, so assert this:  */
4182         assert(PL_regex_pad[offset] == &PL_sv_undef);
4183     } else {
4184         SV * const repointer = &PL_sv_undef;
4185         av_push(PL_regex_padav, repointer);
4186         pmop->op_pmoffset = av_len(PL_regex_padav);
4187         PL_regex_pad = AvARRAY(PL_regex_padav);
4188     }
4189 #endif
4190
4191     return CHECKOP(type, pmop);
4192 }
4193
4194 /* Given some sort of match op o, and an expression expr containing a
4195  * pattern, either compile expr into a regex and attach it to o (if it's
4196  * constant), or convert expr into a runtime regcomp op sequence (if it's
4197  * not)
4198  *
4199  * isreg indicates that the pattern is part of a regex construct, eg
4200  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4201  * split "pattern", which aren't. In the former case, expr will be a list
4202  * if the pattern contains more than one term (eg /a$b/) or if it contains
4203  * a replacement, ie s/// or tr///.
4204  */
4205
4206 OP *
4207 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4208 {
4209     dVAR;
4210     PMOP *pm;
4211     LOGOP *rcop;
4212     I32 repl_has_vars = 0;
4213     OP* repl = NULL;
4214     bool reglist;
4215
4216     PERL_ARGS_ASSERT_PMRUNTIME;
4217
4218     if (
4219         o->op_type == OP_SUBST
4220      || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4221     ) {
4222         /* last element in list is the replacement; pop it */
4223         OP* kid;
4224         repl = cLISTOPx(expr)->op_last;
4225         kid = cLISTOPx(expr)->op_first;
4226         while (kid->op_sibling != repl)
4227             kid = kid->op_sibling;
4228         kid->op_sibling = NULL;
4229         cLISTOPx(expr)->op_last = kid;
4230     }
4231
4232     if (isreg && expr->op_type == OP_LIST &&
4233         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4234     {
4235         /* convert single element list to element */
4236         OP* const oe = expr;
4237         expr = cLISTOPx(oe)->op_first->op_sibling;
4238         cLISTOPx(oe)->op_first->op_sibling = NULL;
4239         cLISTOPx(oe)->op_last = NULL;
4240         op_free(oe);
4241     }
4242
4243     if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4244         return pmtrans(o, expr, repl);
4245     }
4246
4247     reglist = isreg && expr->op_type == OP_LIST;
4248     if (reglist)
4249         op_null(expr);
4250
4251     PL_hints |= HINT_BLOCK_SCOPE;
4252     pm = (PMOP*)o;
4253
4254     if (expr->op_type == OP_CONST) {
4255         SV *pat = ((SVOP*)expr)->op_sv;
4256         U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4257
4258         if (o->op_flags & OPf_SPECIAL)
4259             pm_flags |= RXf_SPLIT;
4260
4261         if (DO_UTF8(pat)) {
4262             assert (SvUTF8(pat));
4263         } else if (SvUTF8(pat)) {
4264             /* Not doing UTF-8, despite what the SV says. Is this only if we're
4265                trapped in use 'bytes'?  */
4266             /* Make a copy of the octet sequence, but without the flag on, as
4267                the compiler now honours the SvUTF8 flag on pat.  */
4268             STRLEN len;
4269             const char *const p = SvPV(pat, len);
4270             pat = newSVpvn_flags(p, len, SVs_TEMP);
4271         }
4272
4273         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4274
4275 #ifdef PERL_MAD
4276         op_getmad(expr,(OP*)pm,'e');
4277 #else
4278         op_free(expr);
4279 #endif
4280     }
4281     else {
4282         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4283             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4284                             ? OP_REGCRESET
4285                             : OP_REGCMAYBE),0,expr);
4286
4287         NewOp(1101, rcop, 1, LOGOP);
4288         rcop->op_type = OP_REGCOMP;
4289         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4290         rcop->op_first = scalar(expr);
4291         rcop->op_flags |= OPf_KIDS
4292                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4293                             | (reglist ? OPf_STACKED : 0);
4294         rcop->op_private = 1;
4295         rcop->op_other = o;
4296         if (reglist)
4297             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4298
4299         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4300         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4301
4302         /* establish postfix order */
4303         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4304             LINKLIST(expr);
4305             rcop->op_next = expr;
4306             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4307         }
4308         else {
4309             rcop->op_next = LINKLIST(expr);
4310             expr->op_next = (OP*)rcop;
4311         }
4312
4313         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4314     }
4315
4316     if (repl) {
4317         OP *curop;
4318         if (pm->op_pmflags & PMf_EVAL) {
4319             curop = NULL;
4320             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4321                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4322         }
4323         else if (repl->op_type == OP_CONST)
4324             curop = repl;
4325         else {
4326             OP *lastop = NULL;
4327             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4328                 if (curop->op_type == OP_SCOPE
4329                         || curop->op_type == OP_LEAVE
4330                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4331                     if (curop->op_type == OP_GV) {
4332                         GV * const gv = cGVOPx_gv(curop);
4333                         repl_has_vars = 1;
4334                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4335                             break;
4336                     }
4337                     else if (curop->op_type == OP_RV2CV)
4338                         break;
4339                     else if (curop->op_type == OP_RV2SV ||
4340                              curop->op_type == OP_RV2AV ||
4341                              curop->op_type == OP_RV2HV ||
4342                              curop->op_type == OP_RV2GV) {
4343                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4344                             break;
4345                     }
4346                     else if (curop->op_type == OP_PADSV ||
4347                              curop->op_type == OP_PADAV ||
4348                              curop->op_type == OP_PADHV ||
4349                              curop->op_type == OP_PADANY)
4350                     {
4351                         repl_has_vars = 1;
4352                     }
4353                     else if (curop->op_type == OP_PUSHRE)
4354                         NOOP; /* Okay here, dangerous in newASSIGNOP */
4355                     else
4356                         break;
4357                 }
4358                 lastop = curop;
4359             }
4360         }
4361         if (curop == repl
4362             && !(repl_has_vars
4363                  && (!PM_GETRE(pm)
4364                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4365         {
4366             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4367             op_prepend_elem(o->op_type, scalar(repl), o);
4368         }
4369         else {
4370             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4371                 pm->op_pmflags |= PMf_MAYBE_CONST;
4372             }
4373             NewOp(1101, rcop, 1, LOGOP);
4374             rcop->op_type = OP_SUBSTCONT;
4375             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4376             rcop->op_first = scalar(repl);
4377             rcop->op_flags |= OPf_KIDS;
4378             rcop->op_private = 1;
4379             rcop->op_other = o;
4380
4381             /* establish postfix order */
4382             rcop->op_next = LINKLIST(repl);
4383             repl->op_next = (OP*)rcop;
4384
4385             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4386             assert(!(pm->op_pmflags & PMf_ONCE));
4387             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4388             rcop->op_next = 0;
4389         }
4390     }
4391
4392     return (OP*)pm;
4393 }
4394
4395 /*
4396 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4397
4398 Constructs, checks, and returns an op of any type that involves an
4399 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4400 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4401 takes ownership of one reference to it.
4402
4403 =cut
4404 */
4405
4406 OP *
4407 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4408 {
4409     dVAR;
4410     SVOP *svop;
4411
4412     PERL_ARGS_ASSERT_NEWSVOP;
4413
4414     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4415         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4416         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4417
4418     NewOp(1101, svop, 1, SVOP);
4419     svop->op_type = (OPCODE)type;
4420     svop->op_ppaddr = PL_ppaddr[type];
4421     svop->op_sv = sv;
4422     svop->op_next = (OP*)svop;
4423     svop->op_flags = (U8)flags;
4424     if (PL_opargs[type] & OA_RETSCALAR)
4425         scalar((OP*)svop);
4426     if (PL_opargs[type] & OA_TARGET)
4427         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4428     return CHECKOP(type, svop);
4429 }
4430
4431 #ifdef USE_ITHREADS
4432
4433 /*
4434 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4435
4436 Constructs, checks, and returns an op of any type that involves a
4437 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4438 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4439 is populated with I<sv>; this function takes ownership of one reference
4440 to it.
4441
4442 This function only exists if Perl has been compiled to use ithreads.
4443
4444 =cut
4445 */
4446
4447 OP *
4448 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4449 {
4450     dVAR;
4451     PADOP *padop;
4452
4453     PERL_ARGS_ASSERT_NEWPADOP;
4454
4455     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4456         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4457         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4458
4459     NewOp(1101, padop, 1, PADOP);
4460     padop->op_type = (OPCODE)type;
4461     padop->op_ppaddr = PL_ppaddr[type];
4462     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4463     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4464     PAD_SETSV(padop->op_padix, sv);
4465     assert(sv);
4466     SvPADTMP_on(sv);
4467     padop->op_next = (OP*)padop;
4468     padop->op_flags = (U8)flags;
4469     if (PL_opargs[type] & OA_RETSCALAR)
4470         scalar((OP*)padop);
4471     if (PL_opargs[type] & OA_TARGET)
4472         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4473     return CHECKOP(type, padop);
4474 }
4475
4476 #endif /* !USE_ITHREADS */
4477
4478 /*
4479 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4480
4481 Constructs, checks, and returns an op of any type that involves an
4482 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4483 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4484 reference; calling this function does not transfer ownership of any
4485 reference to it.
4486
4487 =cut
4488 */
4489
4490 OP *
4491 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4492 {
4493     dVAR;
4494
4495     PERL_ARGS_ASSERT_NEWGVOP;
4496
4497 #ifdef USE_ITHREADS
4498     GvIN_PAD_on(gv);
4499     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4500 #else
4501     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4502 #endif
4503 }
4504
4505 /*
4506 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4507
4508 Constructs, checks, and returns an op of any type that involves an
4509 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4510 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4511 must have been allocated using L</PerlMemShared_malloc>; the memory will
4512 be freed when the op is destroyed.
4513
4514 =cut
4515 */
4516
4517 OP *
4518 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4519 {
4520     dVAR;
4521     const bool utf8 = cBOOL(flags & SVf_UTF8);
4522     PVOP *pvop;
4523
4524     flags &= ~SVf_UTF8;
4525
4526     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4527         || type == OP_RUNCV
4528         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4529
4530     NewOp(1101, pvop, 1, PVOP);
4531     pvop->op_type = (OPCODE)type;
4532     pvop->op_ppaddr = PL_ppaddr[type];
4533     pvop->op_pv = pv;
4534     pvop->op_next = (OP*)pvop;
4535     pvop->op_flags = (U8)flags;
4536     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4537     if (PL_opargs[type] & OA_RETSCALAR)
4538         scalar((OP*)pvop);
4539     if (PL_opargs[type] & OA_TARGET)
4540         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4541     return CHECKOP(type, pvop);
4542 }
4543
4544 #ifdef PERL_MAD
4545 OP*
4546 #else
4547 void
4548 #endif
4549 Perl_package(pTHX_ OP *o)
4550 {
4551     dVAR;
4552     SV *const sv = cSVOPo->op_sv;
4553 #ifdef PERL_MAD
4554     OP *pegop;
4555 #endif
4556
4557     PERL_ARGS_ASSERT_PACKAGE;
4558
4559     SAVEGENERICSV(PL_curstash);
4560     save_item(PL_curstname);
4561
4562     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4563
4564     sv_setsv(PL_curstname, sv);
4565
4566     PL_hints |= HINT_BLOCK_SCOPE;
4567     PL_parser->copline = NOLINE;
4568     PL_parser->expect = XSTATE;
4569
4570 #ifndef PERL_MAD
4571     op_free(o);
4572 #else
4573     if (!PL_madskills) {
4574         op_free(o);
4575         return NULL;
4576     }
4577
4578     pegop = newOP(OP_NULL,0);
4579     op_getmad(o,pegop,'P');
4580     return pegop;
4581 #endif
4582 }
4583
4584 void
4585 Perl_package_version( pTHX_ OP *v )
4586 {
4587     dVAR;
4588     U32 savehints = PL_hints;
4589     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4590     PL_hints &= ~HINT_STRICT_VARS;
4591     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4592     PL_hints = savehints;
4593     op_free(v);
4594 }
4595
4596 #ifdef PERL_MAD
4597 OP*
4598 #else
4599 void
4600 #endif
4601 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4602 {
4603     dVAR;
4604     OP *pack;
4605     OP *imop;
4606     OP *veop;
4607 #ifdef PERL_MAD
4608     OP *pegop = newOP(OP_NULL,0);
4609 #endif
4610     SV *use_version = NULL;
4611
4612     PERL_ARGS_ASSERT_UTILIZE;
4613
4614     if (idop->op_type != OP_CONST)
4615         Perl_croak(aTHX_ "Module name must be constant");
4616
4617     if (PL_madskills)
4618         op_getmad(idop,pegop,'U');
4619
4620     veop = NULL;
4621
4622     if (version) {
4623         SV * const vesv = ((SVOP*)version)->op_sv;
4624
4625         if (PL_madskills)
4626             op_getmad(version,pegop,'V');
4627         if (!arg && !SvNIOKp(vesv)) {
4628             arg = version;
4629         }
4630         else {
4631             OP *pack;
4632             SV *meth;
4633
4634             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4635                 Perl_croak(aTHX_ "Version number must be a constant number");
4636
4637             /* Make copy of idop so we don't free it twice */
4638             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4639
4640             /* Fake up a method call to VERSION */
4641             meth = newSVpvs_share("VERSION");
4642             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4643                             op_append_elem(OP_LIST,
4644                                         op_prepend_elem(OP_LIST, pack, list(version)),
4645                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4646         }
4647     }
4648
4649     /* Fake up an import/unimport */
4650     if (arg && arg->op_type == OP_STUB) {
4651         if (PL_madskills)
4652             op_getmad(arg,pegop,'S');
4653         imop = arg;             /* no import on explicit () */
4654     }
4655     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4656         imop = NULL;            /* use 5.0; */
4657         if (aver)
4658             use_version = ((SVOP*)idop)->op_sv;
4659         else
4660             idop->op_private |= OPpCONST_NOVER;
4661     }
4662     else {
4663         SV *meth;
4664
4665         if (PL_madskills)
4666             op_getmad(arg,pegop,'A');
4667
4668         /* Make copy of idop so we don't free it twice */
4669         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4670
4671         /* Fake up a method call to import/unimport */
4672         meth = aver
4673             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4674         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4675                        op_append_elem(OP_LIST,
4676                                    op_prepend_elem(OP_LIST, pack, list(arg)),
4677                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4678     }
4679
4680     /* Fake up the BEGIN {}, which does its thing immediately. */
4681     newATTRSUB(floor,
4682         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4683         NULL,
4684         NULL,
4685         op_append_elem(OP_LINESEQ,
4686             op_append_elem(OP_LINESEQ,
4687                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4688                 newSTATEOP(0, NULL, veop)),
4689             newSTATEOP(0, NULL, imop) ));
4690
4691     if (use_version) {
4692         /* Enable the
4693          * feature bundle that corresponds to the required version. */
4694         use_version = sv_2mortal(new_version(use_version));
4695         S_enable_feature_bundle(aTHX_ use_version);
4696
4697         /* If a version >= 5.11.0 is requested, strictures are on by default! */
4698         if (vcmp(use_version,
4699                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4700             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4701                 PL_hints |= HINT_STRICT_REFS;
4702             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4703                 PL_hints |= HINT_STRICT_SUBS;
4704             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4705                 PL_hints |= HINT_STRICT_VARS;
4706         }
4707         /* otherwise they are off */
4708         else {
4709             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4710                 PL_hints &= ~HINT_STRICT_REFS;
4711             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4712                 PL_hints &= ~HINT_STRICT_SUBS;
4713             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4714                 PL_hints &= ~HINT_STRICT_VARS;
4715         }
4716     }
4717
4718     /* The "did you use incorrect case?" warning used to be here.
4719      * The problem is that on case-insensitive filesystems one
4720      * might get false positives for "use" (and "require"):
4721      * "use Strict" or "require CARP" will work.  This causes
4722      * portability problems for the script: in case-strict
4723      * filesystems the script will stop working.
4724      *
4725      * The "incorrect case" warning checked whether "use Foo"
4726      * imported "Foo" to your namespace, but that is wrong, too:
4727      * there is no requirement nor promise in the language that
4728      * a Foo.pm should or would contain anything in package "Foo".
4729      *
4730      * There is very little Configure-wise that can be done, either:
4731      * the case-sensitivity of the build filesystem of Perl does not
4732      * help in guessing the case-sensitivity of the runtime environment.
4733      */
4734
4735     PL_hints |= HINT_BLOCK_SCOPE;
4736     PL_parser->copline = NOLINE;
4737     PL_parser->expect = XSTATE;
4738     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4739     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4740         PL_cop_seqmax++;
4741
4742 #ifdef PERL_MAD
4743     if (!PL_madskills) {
4744         /* FIXME - don't allocate pegop if !PL_madskills */
4745         op_free(pegop);
4746         return NULL;
4747     }
4748     return pegop;
4749 #endif
4750 }
4751
4752 /*
4753 =head1 Embedding Functions
4754
4755 =for apidoc load_module
4756
4757 Loads the module whose name is pointed to by the string part of name.
4758 Note that the actual module name, not its filename, should be given.
4759 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4760 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4761 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4762 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4763 arguments can be used to specify arguments to the module's import()
4764 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4765 terminated with a final NULL pointer.  Note that this list can only
4766 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4767 Otherwise at least a single NULL pointer to designate the default
4768 import list is required.
4769
4770 The reference count for each specified C<SV*> parameter is decremented.
4771
4772 =cut */
4773
4774 void
4775 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4776 {
4777     va_list args;
4778
4779     PERL_ARGS_ASSERT_LOAD_MODULE;
4780
4781     va_start(args, ver);
4782     vload_module(flags, name, ver, &args);
4783     va_end(args);
4784 }
4785
4786 #ifdef PERL_IMPLICIT_CONTEXT
4787 void
4788 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4789 {
4790     dTHX;
4791     va_list args;
4792     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4793     va_start(args, ver);
4794     vload_module(flags, name, ver, &args);
4795     va_end(args);
4796 }
4797 #endif
4798
4799 void
4800 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4801 {
4802     dVAR;
4803     OP *veop, *imop;
4804     OP * const modname = newSVOP(OP_CONST, 0, name);
4805
4806     PERL_ARGS_ASSERT_VLOAD_MODULE;
4807
4808     modname->op_private |= OPpCONST_BARE;
4809     if (ver) {
4810         veop = newSVOP(OP_CONST, 0, ver);
4811     }
4812     else
4813         veop = NULL;
4814     if (flags & PERL_LOADMOD_NOIMPORT) {
4815         imop = sawparens(newNULLLIST());
4816     }
4817     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4818         imop = va_arg(*args, OP*);
4819     }
4820     else {
4821         SV *sv;
4822         imop = NULL;
4823         sv = va_arg(*args, SV*);
4824         while (sv) {
4825             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4826             sv = va_arg(*args, SV*);
4827         }
4828     }
4829
4830     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4831      * that it has a PL_parser to play with while doing that, and also
4832      * that it doesn't mess with any existing parser, by creating a tmp
4833      * new parser with lex_start(). This won't actually be used for much,
4834      * since pp_require() will create another parser for the real work. */
4835
4836     ENTER;
4837     SAVEVPTR(PL_curcop);
4838     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4839     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4840             veop, modname, imop);
4841     LEAVE;
4842 }
4843
4844 OP *
4845 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4846 {
4847     dVAR;
4848     OP *doop;
4849     GV *gv = NULL;
4850
4851     PERL_ARGS_ASSERT_DOFILE;
4852
4853     if (!force_builtin) {
4854         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4855         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4856             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4857             gv = gvp ? *gvp : NULL;
4858         }
4859     }
4860
4861     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4862         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4863                                op_append_elem(OP_LIST, term,
4864                                            scalar(newUNOP(OP_RV2CV, 0,
4865                                                           newGVOP(OP_GV, 0, gv))))));
4866     }
4867     else {
4868         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4869     }
4870     return doop;
4871 }
4872
4873 /*
4874 =head1 Optree construction
4875
4876 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4877
4878 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4879 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4880 be set automatically, and, shifted up eight bits, the eight bits of
4881 C<op_private>, except that the bit with value 1 or 2 is automatically
4882 set as required.  I<listval> and I<subscript> supply the parameters of
4883 the slice; they are consumed by this function and become part of the
4884 constructed op tree.
4885
4886 =cut
4887 */
4888
4889 OP *
4890 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4891 {
4892     return newBINOP(OP_LSLICE, flags,
4893             list(force_list(subscript)),
4894             list(force_list(listval)) );
4895 }
4896
4897 STATIC I32
4898 S_is_list_assignment(pTHX_ register const OP *o)
4899 {
4900     unsigned type;
4901     U8 flags;
4902
4903     if (!o)
4904         return TRUE;
4905
4906     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4907         o = cUNOPo->op_first;
4908
4909     flags = o->op_flags;
4910     type = o->op_type;
4911     if (type == OP_COND_EXPR) {
4912         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4913         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4914
4915         if (t && f)
4916             return TRUE;
4917         if (t || f)
4918             yyerror("Assignment to both a list and a scalar");
4919         return FALSE;
4920     }
4921
4922     if (type == OP_LIST &&
4923         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4924         o->op_private & OPpLVAL_INTRO)
4925         return FALSE;
4926
4927     if (type == OP_LIST || flags & OPf_PARENS ||
4928         type == OP_RV2AV || type == OP_RV2HV ||
4929         type == OP_ASLICE || type == OP_HSLICE)
4930         return TRUE;
4931
4932     if (type == OP_PADAV || type == OP_PADHV)
4933         return TRUE;
4934
4935     if (type == OP_RV2SV)
4936         return FALSE;
4937
4938     return FALSE;
4939 }
4940
4941 /*
4942   Helper function for newASSIGNOP to detection commonality between the
4943   lhs and the rhs.  Marks all variables with PL_generation.  If it
4944   returns TRUE the assignment must be able to handle common variables.
4945 */
4946 PERL_STATIC_INLINE bool
4947 S_aassign_common_vars(pTHX_ OP* o)
4948 {
4949     OP *curop;
4950     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4951         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4952             if (curop->op_type == OP_GV) {
4953                 GV *gv = cGVOPx_gv(curop);
4954                 if (gv == PL_defgv
4955                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4956                     return TRUE;
4957                 GvASSIGN_GENERATION_set(gv, PL_generation);
4958             }
4959             else if (curop->op_type == OP_PADSV ||
4960                 curop->op_type == OP_PADAV ||
4961                 curop->op_type == OP_PADHV ||
4962                 curop->op_type == OP_PADANY)
4963                 {
4964                     if (PAD_COMPNAME_GEN(curop->op_targ)
4965                         == (STRLEN)PL_generation)
4966                         return TRUE;
4967                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4968
4969                 }
4970             else if (curop->op_type == OP_RV2CV)
4971                 return TRUE;
4972             else if (curop->op_type == OP_RV2SV ||
4973                 curop->op_type == OP_RV2AV ||
4974                 curop->op_type == OP_RV2HV ||
4975                 curop->op_type == OP_RV2GV) {
4976                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
4977                     return TRUE;
4978             }
4979             else if (curop->op_type == OP_PUSHRE) {
4980 #ifdef USE_ITHREADS
4981                 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4982                     GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4983                     if (gv == PL_defgv
4984                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4985                         return TRUE;
4986                     GvASSIGN_GENERATION_set(gv, PL_generation);
4987                 }
4988 #else
4989                 GV *const gv
4990                     = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4991                 if (gv) {
4992                     if (gv == PL_defgv
4993                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4994                         return TRUE;
4995                     GvASSIGN_GENERATION_set(gv, PL_generation);
4996                 }
4997 #endif
4998             }
4999             else
5000                 return TRUE;
5001         }
5002
5003         if (curop->op_flags & OPf_KIDS) {
5004             if (aassign_common_vars(curop))
5005                 return TRUE;
5006         }
5007     }
5008     return FALSE;
5009 }
5010
5011 /*
5012 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5013
5014 Constructs, checks, and returns an assignment op.  I<left> and I<right>
5015 supply the parameters of the assignment; they are consumed by this
5016 function and become part of the constructed op tree.
5017
5018 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5019 a suitable conditional optree is constructed.  If I<optype> is the opcode
5020 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5021 performs the binary operation and assigns the result to the left argument.
5022 Either way, if I<optype> is non-zero then I<flags> has no effect.
5023
5024 If I<optype> is zero, then a plain scalar or list assignment is
5025 constructed.  Which type of assignment it is is automatically determined.
5026 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5027 will be set automatically, and, shifted up eight bits, the eight bits
5028 of C<op_private>, except that the bit with value 1 or 2 is automatically
5029 set as required.
5030
5031 =cut
5032 */
5033
5034 OP *
5035 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5036 {
5037     dVAR;
5038     OP *o;
5039
5040     if (optype) {
5041         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5042             return newLOGOP(optype, 0,
5043                 op_lvalue(scalar(left), optype),
5044                 newUNOP(OP_SASSIGN, 0, scalar(right)));
5045         }
5046         else {
5047             return newBINOP(optype, OPf_STACKED,
5048                 op_lvalue(scalar(left), optype), scalar(right));
5049         }
5050     }
5051
5052     if (is_list_assignment(left)) {
5053         static const char no_list_state[] = "Initialization of state variables"
5054             " in list context currently forbidden";
5055         OP *curop;
5056         bool maybe_common_vars = TRUE;
5057
5058         PL_modcount = 0;
5059         left = op_lvalue(left, OP_AASSIGN);
5060         curop = list(force_list(left));
5061         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5062         o->op_private = (U8)(0 | (flags >> 8));
5063
5064         if ((left->op_type == OP_LIST
5065              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5066         {
5067             OP* lop = ((LISTOP*)left)->op_first;
5068             maybe_common_vars = FALSE;
5069             while (lop) {
5070                 if (lop->op_type == OP_PADSV ||
5071                     lop->op_type == OP_PADAV ||
5072                     lop->op_type == OP_PADHV ||
5073                     lop->op_type == OP_PADANY) {
5074                     if (!(lop->op_private & OPpLVAL_INTRO))
5075                         maybe_common_vars = TRUE;
5076
5077                     if (lop->op_private & OPpPAD_STATE) {
5078                         if (left->op_private & OPpLVAL_INTRO) {
5079                             /* Each variable in state($a, $b, $c) = ... */
5080                         }
5081                         else {
5082                             /* Each state variable in
5083                                (state $a, my $b, our $c, $d, undef) = ... */
5084                         }
5085                         yyerror(no_list_state);
5086                     } else {
5087                         /* Each my variable in
5088                            (state $a, my $b, our $c, $d, undef) = ... */
5089                     }
5090                 } else if (lop->op_type == OP_UNDEF ||
5091                            lop->op_type == OP_PUSHMARK) {
5092                     /* undef may be interesting in
5093                        (state $a, undef, state $c) */
5094                 } else {
5095                     /* Other ops in the list. */
5096                     maybe_common_vars = TRUE;
5097                 }
5098                 lop = lop->op_sibling;
5099             }
5100         }
5101         else if ((left->op_private & OPpLVAL_INTRO)
5102                 && (   left->op_type == OP_PADSV
5103                     || left->op_type == OP_PADAV
5104                     || left->op_type == OP_PADHV
5105                     || left->op_type == OP_PADANY))
5106         {
5107             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5108             if (left->op_private & OPpPAD_STATE) {
5109                 /* All single variable list context state assignments, hence
5110                    state ($a) = ...
5111                    (state $a) = ...
5112                    state @a = ...
5113                    state (@a) = ...
5114                    (state @a) = ...
5115                    state %a = ...
5116                    state (%a) = ...
5117                    (state %a) = ...
5118                 */
5119                 yyerror(no_list_state);
5120             }
5121         }
5122
5123         /* PL_generation sorcery:
5124          * an assignment like ($a,$b) = ($c,$d) is easier than
5125          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5126          * To detect whether there are common vars, the global var
5127          * PL_generation is incremented for each assign op we compile.
5128          * Then, while compiling the assign op, we run through all the
5129          * variables on both sides of the assignment, setting a spare slot
5130          * in each of them to PL_generation. If any of them already have
5131          * that value, we know we've got commonality.  We could use a
5132          * single bit marker, but then we'd have to make 2 passes, first
5133          * to clear the flag, then to test and set it.  To find somewhere
5134          * to store these values, evil chicanery is done with SvUVX().
5135          */
5136
5137         if (maybe_common_vars) {
5138             PL_generation++;
5139             if (aassign_common_vars(o))
5140                 o->op_private |= OPpASSIGN_COMMON;
5141             LINKLIST(o);
5142         }
5143
5144         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5145             OP* tmpop = ((LISTOP*)right)->op_first;
5146             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5147                 PMOP * const pm = (PMOP*)tmpop;
5148                 if (left->op_type == OP_RV2AV &&
5149                     !(left->op_private & OPpLVAL_INTRO) &&
5150                     !(o->op_private & OPpASSIGN_COMMON) )
5151                 {
5152                     tmpop = ((UNOP*)left)->op_first;
5153                     if (tmpop->op_type == OP_GV
5154 #ifdef USE_ITHREADS
5155                         && !pm->op_pmreplrootu.op_pmtargetoff
5156 #else
5157                         && !pm->op_pmreplrootu.op_pmtargetgv
5158 #endif
5159                         ) {
5160 #ifdef USE_ITHREADS
5161                         pm->op_pmreplrootu.op_pmtargetoff
5162                             = cPADOPx(tmpop)->op_padix;
5163                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
5164 #else
5165                         pm->op_pmreplrootu.op_pmtargetgv
5166                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5167                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
5168 #endif
5169                         pm->op_pmflags |= PMf_ONCE;
5170                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
5171                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5172                         tmpop->op_sibling = NULL;       /* don't free split */
5173                         right->op_next = tmpop->op_next;  /* fix starting loc */
5174                         op_free(o);                     /* blow off assign */
5175                         right->op_flags &= ~OPf_WANT;
5176                                 /* "I don't know and I don't care." */
5177                         return right;
5178                     }
5179                 }
5180                 else {
5181                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5182                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
5183                     {
5184                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5185                         if (SvIOK(sv) && SvIVX(sv) == 0)
5186                             sv_setiv(sv, PL_modcount+1);
5187                     }
5188                 }
5189             }
5190         }
5191         return o;
5192     }
5193     if (!right)
5194         right = newOP(OP_UNDEF, 0);
5195     if (right->op_type == OP_READLINE) {
5196         right->op_flags |= OPf_STACKED;
5197         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5198                 scalar(right));
5199     }
5200     else {
5201         o = newBINOP(OP_SASSIGN, flags,
5202             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5203     }
5204     return o;
5205 }
5206
5207 /*
5208 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5209
5210 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
5211 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5212 code.  The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5213 If I<label> is non-null, it supplies the name of a label to attach to
5214 the state op; this function takes ownership of the memory pointed at by
5215 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
5216 for the state op.
5217
5218 If I<o> is null, the state op is returned.  Otherwise the state op is
5219 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
5220 is consumed by this function and becomes part of the returned op tree.
5221
5222 =cut
5223 */
5224
5225 OP *
5226 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5227 {
5228     dVAR;
5229     const U32 seq = intro_my();
5230     const U32 utf8 = flags & SVf_UTF8;
5231     register COP *cop;
5232
5233     flags &= ~SVf_UTF8;
5234
5235     NewOp(1101, cop, 1, COP);
5236     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5237         cop->op_type = OP_DBSTATE;
5238         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5239     }
5240     else {
5241         cop->op_type = OP_NEXTSTATE;
5242         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5243     }
5244     cop->op_flags = (U8)flags;
5245     CopHINTS_set(cop, PL_hints);
5246 #ifdef NATIVE_HINTS
5247     cop->op_private |= NATIVE_HINTS;
5248 #endif
5249     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5250     cop->op_next = (OP*)cop;
5251
5252     cop->cop_seq = seq;
5253     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5254     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5255     if (label) {
5256         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5257
5258         PL_hints |= HINT_BLOCK_SCOPE;
5259         /* It seems that we need to defer freeing this pointer, as other parts
5260            of the grammar end up wanting to copy it after this op has been
5261            created. */
5262         SAVEFREEPV(label);
5263     }
5264
5265     if (PL_parser && PL_parser->copline == NOLINE)
5266         CopLINE_set(cop, CopLINE(PL_curcop));
5267     else {
5268         CopLINE_set(cop, PL_parser->copline);
5269         if (PL_parser)
5270             PL_parser->copline = NOLINE;
5271     }
5272 #ifdef USE_ITHREADS
5273     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
5274 #else
5275     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5276 #endif
5277     CopSTASH_set(cop, PL_curstash);
5278
5279     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5280         /* this line can have a breakpoint - store the cop in IV */
5281         AV *av = CopFILEAVx(PL_curcop);
5282         if (av) {
5283             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5284             if (svp && *svp != &PL_sv_undef ) {
5285                 (void)SvIOK_on(*svp);
5286                 SvIV_set(*svp, PTR2IV(cop));
5287             }
5288         }
5289     }
5290
5291     if (flags & OPf_SPECIAL)
5292         op_null((OP*)cop);
5293     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5294 }
5295
5296 /*
5297 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5298
5299 Constructs, checks, and returns a logical (flow control) op.  I<type>
5300 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
5301 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5302 the eight bits of C<op_private>, except that the bit with value 1 is
5303 automatically set.  I<first> supplies the expression controlling the
5304 flow, and I<other> supplies the side (alternate) chain of ops; they are
5305 consumed by this function and become part of the constructed op tree.
5306
5307 =cut
5308 */
5309
5310 OP *
5311 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5312 {
5313     dVAR;
5314
5315     PERL_ARGS_ASSERT_NEWLOGOP;
5316
5317     return new_logop(type, flags, &first, &other);
5318 }
5319
5320 STATIC OP *
5321 S_search_const(pTHX_ OP *o)
5322 {
5323     PERL_ARGS_ASSERT_SEARCH_CONST;
5324
5325     switch (o->op_type) {
5326         case OP_CONST:
5327             return o;
5328         case OP_NULL:
5329             if (o->op_flags & OPf_KIDS)
5330                 return search_const(cUNOPo->op_first);
5331             break;
5332         case OP_LEAVE:
5333         case OP_SCOPE:
5334         case OP_LINESEQ:
5335         {
5336             OP *kid;
5337             if (!(o->op_flags & OPf_KIDS))
5338                 return NULL;
5339             kid = cLISTOPo->op_first;
5340             do {
5341                 switch (kid->op_type) {
5342                     case OP_ENTER:
5343                     case OP_NULL:
5344                     case OP_NEXTSTATE:
5345                         kid = kid->op_sibling;
5346                         break;
5347                     default:
5348                         if (kid != cLISTOPo->op_last)
5349                             return NULL;
5350                         goto last;
5351                 }
5352             } while (kid);
5353             if (!kid)
5354                 kid = cLISTOPo->op_last;
5355 last:
5356             return search_const(kid);
5357         }
5358     }
5359
5360     return NULL;
5361 }
5362
5363 STATIC OP *
5364 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5365 {
5366     dVAR;
5367     LOGOP *logop;
5368     OP *o;
5369     OP *first;
5370     OP *other;
5371     OP *cstop = NULL;
5372     int prepend_not = 0;
5373
5374     PERL_ARGS_ASSERT_NEW_LOGOP;
5375
5376     first = *firstp;
5377     other = *otherp;
5378
5379     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
5380         return newBINOP(type, flags, scalar(first), scalar(other));
5381
5382     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5383
5384     scalarboolean(first);
5385     /* optimize AND and OR ops that have NOTs as children */
5386     if (first->op_type == OP_NOT
5387         && (first->op_flags & OPf_KIDS)
5388         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5389             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
5390         && !PL_madskills) {
5391         if (type == OP_AND || type == OP_OR) {
5392             if (type == OP_AND)
5393                 type = OP_OR;
5394             else
5395                 type = OP_AND;
5396             op_null(first);
5397             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5398                 op_null(other);
5399                 prepend_not = 1; /* prepend a NOT op later */
5400             }
5401         }
5402     }
5403     /* search for a constant op that could let us fold the test */
5404     if ((cstop = search_const(first))) {
5405         if (cstop->op_private & OPpCONST_STRICT)
5406             no_bareword_allowed(cstop);
5407         else if ((cstop->op_private & OPpCONST_BARE))
5408                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5409         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
5410             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5411             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5412             *firstp = NULL;
5413             if (other->op_type == OP_CONST)
5414                 other->op_private |= OPpCONST_SHORTCIRCUIT;
5415             if (PL_madskills) {
5416                 OP *newop = newUNOP(OP_NULL, 0, other);
5417                 op_getmad(first, newop, '1');
5418                 newop->op_targ = type;  /* set "was" field */
5419                 return newop;
5420             }
5421             op_free(first);
5422             if (other->op_type == OP_LEAVE)
5423                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5424             else if (other->op_type == OP_MATCH
5425                   || other->op_type == OP_SUBST
5426                   || other->op_type == OP_TRANSR
5427                   || other->op_type == OP_TRANS)
5428                 /* Mark the op as being unbindable with =~ */
5429                 other->op_flags |= OPf_SPECIAL;
5430             return other;
5431         }
5432         else {
5433             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5434             const OP *o2 = other;
5435             if ( ! (o2->op_type == OP_LIST
5436                     && (( o2 = cUNOPx(o2)->op_first))
5437                     && o2->op_type == OP_PUSHMARK
5438                     && (( o2 = o2->op_sibling)) )
5439             )
5440                 o2 = other;
5441             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5442                         || o2->op_type == OP_PADHV)
5443                 && o2->op_private & OPpLVAL_INTRO
5444                 && !(o2->op_private & OPpPAD_STATE))
5445             {
5446                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5447                                  "Deprecated use of my() in false conditional");
5448             }
5449
5450             *otherp = NULL;
5451             if (first->op_type == OP_CONST)
5452                 first->op_private |= OPpCONST_SHORTCIRCUIT;
5453             if (PL_madskills) {
5454                 first = newUNOP(OP_NULL, 0, first);
5455                 op_getmad(other, first, '2');
5456                 first->op_targ = type;  /* set "was" field */
5457             }
5458             else
5459                 op_free(other);
5460             return first;
5461         }
5462     }
5463     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5464         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5465     {
5466         const OP * const k1 = ((UNOP*)first)->op_first;
5467         const OP * const k2 = k1->op_sibling;
5468         OPCODE warnop = 0;
5469         switch (first->op_type)
5470         {
5471         case OP_NULL:
5472             if (k2 && k2->op_type == OP_READLINE
5473                   && (k2->op_flags & OPf_STACKED)
5474                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5475             {
5476                 warnop = k2->op_type;
5477             }
5478             break;
5479
5480         case OP_SASSIGN:
5481             if (k1->op_type == OP_READDIR
5482                   || k1->op_type == OP_GLOB
5483                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5484                  || k1->op_type == OP_EACH
5485                  || k1->op_type == OP_AEACH)
5486             {
5487                 warnop = ((k1->op_type == OP_NULL)
5488                           ? (OPCODE)k1->op_targ : k1->op_type);
5489             }
5490             break;
5491         }
5492         if (warnop) {
5493             const line_t oldline = CopLINE(PL_curcop);
5494             CopLINE_set(PL_curcop, PL_parser->copline);
5495             Perl_warner(aTHX_ packWARN(WARN_MISC),
5496                  "Value of %s%s can be \"0\"; test with defined()",
5497                  PL_op_desc[warnop],
5498                  ((warnop == OP_READLINE || warnop == OP_GLOB)
5499                   ? " construct" : "() operator"));
5500             CopLINE_set(PL_curcop, oldline);
5501         }
5502     }
5503
5504     if (!other)
5505         return first;
5506
5507     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5508         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
5509
5510     NewOp(1101, logop, 1, LOGOP);
5511
5512     logop->op_type = (OPCODE)type;
5513     logop->op_ppaddr = PL_ppaddr[type];
5514     logop->op_first = first;
5515     logop->op_flags = (U8)(flags | OPf_KIDS);
5516     logop->op_other = LINKLIST(other);
5517     logop->op_private = (U8)(1 | (flags >> 8));
5518
5519     /* establish postfix order */
5520     logop->op_next = LINKLIST(first);
5521     first->op_next = (OP*)logop;
5522     first->op_sibling = other;
5523
5524     CHECKOP(type,logop);
5525
5526     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5527     other->op_next = o;
5528
5529     return o;
5530 }
5531
5532 /*
5533 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5534
5535 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5536 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5537 will be set automatically, and, shifted up eight bits, the eight bits of
5538 C<op_private>, except that the bit with value 1 is automatically set.
5539 I<first> supplies the expression selecting between the two branches,
5540 and I<trueop> and I<falseop> supply the branches; they are consumed by
5541 this function and become part of the constructed op tree.
5542
5543 =cut
5544 */
5545
5546 OP *
5547 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5548 {
5549     dVAR;
5550     LOGOP *logop;
5551     OP *start;
5552     OP *o;
5553     OP *cstop;
5554
5555     PERL_ARGS_ASSERT_NEWCONDOP;
5556
5557     if (!falseop)
5558         return newLOGOP(OP_AND, 0, first, trueop);
5559     if (!trueop)
5560         return newLOGOP(OP_OR, 0, first, falseop);
5561
5562     scalarboolean(first);
5563     if ((cstop = search_const(first))) {
5564         /* Left or right arm of the conditional?  */
5565         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5566         OP *live = left ? trueop : falseop;
5567         OP *const dead = left ? falseop : trueop;
5568         if (cstop->op_private & OPpCONST_BARE &&
5569             cstop->op_private & OPpCONST_STRICT) {
5570             no_bareword_allowed(cstop);
5571         }
5572         if (PL_madskills) {
5573             /* This is all dead code when PERL_MAD is not defined.  */
5574             live = newUNOP(OP_NULL, 0, live);
5575             op_getmad(first, live, 'C');
5576             op_getmad(dead, live, left ? 'e' : 't');
5577         } else {
5578             op_free(first);
5579             op_free(dead);
5580         }
5581         if (live->op_type == OP_LEAVE)
5582             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5583         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5584               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5585             /* Mark the op as being unbindable with =~ */
5586             live->op_flags |= OPf_SPECIAL;
5587         return live;
5588     }
5589     NewOp(1101, logop, 1, LOGOP);
5590     logop->op_type = OP_COND_EXPR;
5591     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5592     logop->op_first = first;
5593     logop->op_flags = (U8)(flags | OPf_KIDS);
5594     logop->op_private = (U8)(1 | (flags >> 8));
5595     logop->op_other = LINKLIST(trueop);
5596     logop->op_next = LINKLIST(falseop);
5597
5598     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5599             logop);
5600
5601     /* establish postfix order */
5602     start = LINKLIST(first);
5603     first->op_next = (OP*)logop;
5604
5605     first->op_sibling = trueop;
5606     trueop->op_sibling = falseop;
5607     o = newUNOP(OP_NULL, 0, (OP*)logop);
5608
5609     trueop->op_next = falseop->op_next = o;
5610
5611     o->op_next = start;
5612     return o;
5613 }
5614
5615 /*
5616 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5617
5618 Constructs and returns a C<range> op, with subordinate C<flip> and
5619 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
5620 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5621 for both the C<flip> and C<range> ops, except that the bit with value
5622 1 is automatically set.  I<left> and I<right> supply the expressions
5623 controlling the endpoints of the range; they are consumed by this function
5624 and become part of the constructed op tree.
5625
5626 =cut
5627 */
5628
5629 OP *
5630 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5631 {
5632     dVAR;
5633     LOGOP *range;
5634     OP *flip;
5635     OP *flop;
5636     OP *leftstart;
5637     OP *o;
5638
5639     PERL_ARGS_ASSERT_NEWRANGE;
5640
5641     NewOp(1101, range, 1, LOGOP);
5642
5643     range->op_type = OP_RANGE;
5644     range->op_ppaddr = PL_ppaddr[OP_RANGE];
5645     range->op_first = left;
5646     range->op_flags = OPf_KIDS;
5647     leftstart = LINKLIST(left);
5648     range->op_other = LINKLIST(right);
5649     range->op_private = (U8)(1 | (flags >> 8));
5650
5651     left->op_sibling = right;
5652
5653     range->op_next = (OP*)range;
5654     flip = newUNOP(OP_FLIP, flags, (OP*)range);
5655     flop = newUNOP(OP_FLOP, 0, flip);
5656     o = newUNOP(OP_NULL, 0, flop);
5657     LINKLIST(flop);
5658     range->op_next = leftstart;
5659
5660     left->op_next = flip;
5661     right->op_next = flop;
5662
5663     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5664     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5665     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5666     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5667
5668     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5669     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5670
5671     /* check barewords before they might be optimized aways */
5672     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5673         no_bareword_allowed(left);
5674     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5675         no_bareword_allowed(right);
5676
5677     flip->op_next = o;
5678     if (!flip->op_private || !flop->op_private)
5679         LINKLIST(o);            /* blow off optimizer unless constant */
5680
5681     return o;
5682 }
5683
5684 /*
5685 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5686
5687 Constructs, checks, and returns an op tree expressing a loop.  This is
5688 only a loop in the control flow through the op tree; it does not have
5689 the heavyweight loop structure that allows exiting the loop by C<last>
5690 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
5691 top-level op, except that some bits will be set automatically as required.
5692 I<expr> supplies the expression controlling loop iteration, and I<block>
5693 supplies the body of the loop; they are consumed by this function and
5694 become part of the constructed op tree.  I<debuggable> is currently
5695 unused and should always be 1.
5696
5697 =cut
5698 */
5699
5700 OP *
5701 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5702 {
5703     dVAR;
5704     OP* listop;
5705     OP* o;
5706     const bool once = block && block->op_flags & OPf_SPECIAL &&
5707       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5708
5709     PERL_UNUSED_ARG(debuggable);
5710
5711     if (expr) {
5712         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5713             return block;       /* do {} while 0 does once */
5714         if (expr->op_type == OP_READLINE
5715             || expr->op_type == OP_READDIR
5716             || expr->op_type == OP_GLOB
5717             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5718             expr = newUNOP(OP_DEFINED, 0,
5719                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5720         } else if (expr->op_flags & OPf_KIDS) {
5721             const OP * const k1 = ((UNOP*)expr)->op_first;
5722             const OP * const k2 = k1 ? k1->op_sibling : NULL;
5723             switch (expr->op_type) {
5724               case OP_NULL:
5725                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5726                       && (k2->op_flags & OPf_STACKED)
5727                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5728                     expr = newUNOP(OP_DEFINED, 0, expr);
5729                 break;
5730
5731               case OP_SASSIGN:
5732                 if (k1 && (k1->op_type == OP_READDIR
5733                       || k1->op_type == OP_GLOB
5734                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5735                      || k1->op_type == OP_EACH
5736                      || k1->op_type == OP_AEACH))
5737                     expr = newUNOP(OP_DEFINED, 0, expr);
5738                 break;
5739             }
5740         }
5741     }
5742
5743     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5744      * op, in listop. This is wrong. [perl #27024] */
5745     if (!block)
5746         block = newOP(OP_NULL, 0);
5747     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5748     o = new_logop(OP_AND, 0, &expr, &listop);
5749
5750     if (listop)
5751         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5752
5753     if (once && o != listop)
5754         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5755
5756     if (o == listop)
5757         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
5758
5759     o->op_flags |= flags;
5760     o = op_scope(o);
5761     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5762     return o;
5763 }
5764
5765 /*
5766 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5767
5768 Constructs, checks, and returns an op tree expressing a C<while> loop.
5769 This is a heavyweight loop, with structure that allows exiting the loop
5770 by C<last> and suchlike.
5771
5772 I<loop> is an optional preconstructed C<enterloop> op to use in the
5773 loop; if it is null then a suitable op will be constructed automatically.
5774 I<expr> supplies the loop's controlling expression.  I<block> supplies the
5775 main body of the loop, and I<cont> optionally supplies a C<continue> block
5776 that operates as a second half of the body.  All of these optree inputs
5777 are consumed by this function and become part of the constructed op tree.
5778
5779 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5780 op and, shifted up eight bits, the eight bits of C<op_private> for
5781 the C<leaveloop> op, except that (in both cases) some bits will be set
5782 automatically.  I<debuggable> is currently unused and should always be 1.
5783 I<has_my> can be supplied as true to force the
5784 loop body to be enclosed in its own scope.
5785
5786 =cut
5787 */
5788
5789 OP *
5790 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5791         OP *expr, OP *block, OP *cont, I32 has_my)
5792 {
5793     dVAR;
5794     OP *redo;
5795     OP *next = NULL;
5796     OP *listop;
5797     OP *o;
5798     U8 loopflags = 0;
5799
5800     PERL_UNUSED_ARG(debuggable);
5801
5802     if (expr) {
5803         if (expr->op_type == OP_READLINE
5804          || expr->op_type == OP_READDIR
5805          || expr->op_type == OP_GLOB
5806                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5807             expr = newUNOP(OP_DEFINED, 0,
5808                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5809         } else if (expr->op_flags & OPf_KIDS) {
5810             const OP * const k1 = ((UNOP*)expr)->op_first;
5811             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5812             switch (expr->op_type) {
5813               case OP_NULL:
5814                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5815                       && (k2->op_flags & OPf_STACKED)
5816                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5817                     expr = newUNOP(OP_DEFINED, 0, expr);
5818                 break;
5819
5820               case OP_SASSIGN:
5821                 if (k1 && (k1->op_type == OP_READDIR
5822                       || k1->op_type == OP_GLOB
5823                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5824                      || k1->op_type == OP_EACH
5825                      || k1->op_type == OP_AEACH))
5826                     expr = newUNOP(OP_DEFINED, 0, expr);
5827                 break;
5828             }
5829         }
5830     }
5831
5832     if (!block)
5833         block = newOP(OP_NULL, 0);
5834     else if (cont || has_my) {
5835         block = op_scope(block);
5836     }
5837
5838     if (cont) {
5839         next = LINKLIST(cont);
5840     }
5841     if (expr) {
5842         OP * const unstack = newOP(OP_UNSTACK, 0);
5843         if (!next)
5844             next = unstack;
5845         cont = op_append_elem(OP_LINESEQ, cont, unstack);
5846     }
5847
5848     assert(block);
5849     listop = op_append_list(OP_LINESEQ, block, cont);
5850     assert(listop);
5851     redo = LINKLIST(listop);
5852
5853     if (expr) {
5854         scalar(listop);
5855         o = new_logop(OP_AND, 0, &expr, &listop);
5856         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5857             op_free(expr);              /* oops, it's a while (0) */
5858             op_free((OP*)loop);
5859             return NULL;                /* listop already freed by new_logop */
5860         }
5861         if (listop)
5862             ((LISTOP*)listop)->op_last->op_next =
5863                 (o == listop ? redo : LINKLIST(o));
5864     }
5865     else
5866         o = listop;
5867
5868     if (!loop) {
5869         NewOp(1101,loop,1,LOOP);
5870         loop->op_type = OP_ENTERLOOP;
5871         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5872         loop->op_private = 0;
5873         loop->op_next = (OP*)loop;
5874     }
5875
5876     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5877
5878     loop->op_redoop = redo;
5879     loop->op_lastop = o;
5880     o->op_private |= loopflags;
5881
5882     if (next)
5883         loop->op_nextop = next;
5884     else
5885         loop->op_nextop = o;
5886
5887     o->op_flags |= flags;
5888     o->op_private |= (flags >> 8);
5889     return o;
5890 }
5891
5892 /*
5893 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5894
5895 Constructs, checks, and returns an op tree expressing a C<foreach>
5896 loop (iteration through a list of values).  This is a heavyweight loop,
5897 with structure that allows exiting the loop by C<last> and suchlike.
5898
5899 I<sv> optionally supplies the variable that will be aliased to each
5900 item in turn; if null, it defaults to C<$_> (either lexical or global).
5901 I<expr> supplies the list of values to iterate over.  I<block> supplies
5902 the main body of the loop, and I<cont> optionally supplies a C<continue>
5903 block that operates as a second half of the body.  All of these optree
5904 inputs are consumed by this function and become part of the constructed
5905 op tree.
5906
5907 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5908 op and, shifted up eight bits, the eight bits of C<op_private> for
5909 the C<leaveloop> op, except that (in both cases) some bits will be set
5910 automatically.
5911
5912 =cut
5913 */
5914
5915 OP *
5916 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5917 {
5918     dVAR;
5919     LOOP *loop;
5920     OP *wop;
5921     PADOFFSET padoff = 0;
5922     I32 iterflags = 0;
5923     I32 iterpflags = 0;
5924     OP *madsv = NULL;
5925
5926     PERL_ARGS_ASSERT_NEWFOROP;
5927
5928     if (sv) {
5929         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
5930             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5931             sv->op_type = OP_RV2GV;
5932             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5933
5934             /* The op_type check is needed to prevent a possible segfault
5935              * if the loop variable is undeclared and 'strict vars' is in
5936              * effect. This is illegal but is nonetheless parsed, so we
5937              * may reach this point with an OP_CONST where we're expecting
5938              * an OP_GV.
5939              */
5940             if (cUNOPx(sv)->op_first->op_type == OP_GV
5941              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5942                 iterpflags |= OPpITER_DEF;
5943         }
5944         else if (sv->op_type == OP_PADSV) { /* private variable */
5945             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5946             padoff = sv->op_targ;
5947             if (PL_madskills)
5948                 madsv = sv;
5949             else {
5950                 sv->op_targ = 0;
5951                 op_free(sv);
5952             }
5953             sv = NULL;
5954         }
5955         else
5956             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5957         if (padoff) {
5958             SV *const namesv = PAD_COMPNAME_SV(padoff);
5959             STRLEN len;
5960             const char *const name = SvPV_const(namesv, len);
5961
5962             if (len == 2 && name[0] == '$' && name[1] == '_')
5963                 iterpflags |= OPpITER_DEF;
5964         }
5965     }
5966     else {
5967         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5968         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5969             sv = newGVOP(OP_GV, 0, PL_defgv);
5970         }
5971         else {
5972             padoff = offset;
5973         }
5974         iterpflags |= OPpITER_DEF;
5975     }
5976     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5977         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5978         iterflags |= OPf_STACKED;
5979     }
5980     else if (expr->op_type == OP_NULL &&
5981              (expr->op_flags & OPf_KIDS) &&
5982              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5983     {
5984         /* Basically turn for($x..$y) into the same as for($x,$y), but we
5985          * set the STACKED flag to indicate that these values are to be
5986          * treated as min/max values by 'pp_iterinit'.
5987          */
5988         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5989         LOGOP* const range = (LOGOP*) flip->op_first;
5990         OP* const left  = range->op_first;
5991         OP* const right = left->op_sibling;
5992         LISTOP* listop;
5993
5994         range->op_flags &= ~OPf_KIDS;
5995         range->op_first = NULL;
5996
5997         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5998         listop->op_first->op_next = range->op_next;
5999         left->op_next = range->op_other;
6000         right->op_next = (OP*)listop;
6001         listop->op_next = listop->op_first;
6002
6003 #ifdef PERL_MAD
6004         op_getmad(expr,(OP*)listop,'O');
6005 #else
6006         op_free(expr);
6007 #endif
6008         expr = (OP*)(listop);
6009         op_null(expr);
6010         iterflags |= OPf_STACKED;
6011     }
6012     else {
6013         expr = op_lvalue(force_list(expr), OP_GREPSTART);
6014     }
6015
6016     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6017                                op_append_elem(OP_LIST, expr, scalar(sv))));
6018     assert(!loop->op_next);
6019     /* for my  $x () sets OPpLVAL_INTRO;
6020      * for our $x () sets OPpOUR_INTRO */
6021     loop->op_private = (U8)iterpflags;
6022 #ifdef PL_OP_SLAB_ALLOC
6023     {
6024         LOOP *tmp;
6025         NewOp(1234,tmp,1,LOOP);
6026         Copy(loop,tmp,1,LISTOP);
6027         S_op_destroy(aTHX_ (OP*)loop);
6028         loop = tmp;
6029     }
6030 #else
6031     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6032 #endif
6033     loop->op_targ = padoff;
6034     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6035     if (madsv)
6036         op_getmad(madsv, (OP*)loop, 'v');
6037     return wop;
6038 }
6039
6040 /*
6041 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6042
6043 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6044 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
6045 determining the target of the op; it is consumed by this function and
6046 become part of the constructed op tree.
6047
6048 =cut
6049 */
6050
6051 OP*
6052 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6053 {
6054     dVAR;
6055     OP *o;
6056
6057     PERL_ARGS_ASSERT_NEWLOOPEX;
6058
6059     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6060
6061     if (type != OP_GOTO || label->op_type == OP_CONST) {
6062         /* "last()" means "last" */
6063         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6064             o = newOP(type, OPf_SPECIAL);
6065         else {
6066             o = newPVOP(type,
6067                         label->op_type == OP_CONST
6068                             ? SvUTF8(((SVOP*)label)->op_sv)
6069                             : 0,
6070                         savesharedpv(label->op_type == OP_CONST
6071                                 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6072                                 : ""));
6073         }
6074 #ifdef PERL_MAD
6075         op_getmad(label,o,'L');
6076 #else
6077         op_free(label);
6078 #endif
6079     }
6080     else {
6081         /* Check whether it's going to be a goto &function */
6082         if (label->op_type == OP_ENTERSUB
6083                 && !(label->op_flags & OPf_STACKED))
6084             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6085         o = newUNOP(type, OPf_STACKED, label);
6086     }
6087     PL_hints |= HINT_BLOCK_SCOPE;
6088     return o;
6089 }
6090
6091 /* if the condition is a literal array or hash
6092    (or @{ ... } etc), make a reference to it.
6093  */
6094 STATIC OP *
6095 S_ref_array_or_hash(pTHX_ OP *cond)
6096 {
6097     if (cond
6098     && (cond->op_type == OP_RV2AV
6099     ||  cond->op_type == OP_PADAV
6100     ||  cond->op_type == OP_RV2HV
6101     ||  cond->op_type == OP_PADHV))
6102
6103         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6104
6105     else if(cond
6106     && (cond->op_type == OP_ASLICE
6107     ||  cond->op_type == OP_HSLICE)) {
6108
6109         /* anonlist now needs a list from this op, was previously used in
6110          * scalar context */
6111         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6112         cond->op_flags |= OPf_WANT_LIST;
6113
6114         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6115     }
6116
6117     else
6118         return cond;
6119 }
6120
6121 /* These construct the optree fragments representing given()
6122    and when() blocks.
6123
6124    entergiven and enterwhen are LOGOPs; the op_other pointer
6125    points up to the associated leave op. We need this so we
6126    can put it in the context and make break/continue work.
6127    (Also, of course, pp_enterwhen will jump straight to
6128    op_other if the match fails.)
6129  */
6130
6131 STATIC OP *
6132 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6133                    I32 enter_opcode, I32 leave_opcode,
6134                    PADOFFSET entertarg)
6135 {
6136     dVAR;
6137     LOGOP *enterop;
6138     OP *o;
6139
6140     PERL_ARGS_ASSERT_NEWGIVWHENOP;
6141
6142     NewOp(1101, enterop, 1, LOGOP);
6143     enterop->op_type = (Optype)enter_opcode;
6144     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6145     enterop->op_flags =  (U8) OPf_KIDS;
6146     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6147     enterop->op_private = 0;
6148
6149     o = newUNOP(leave_opcode, 0, (OP *) enterop);
6150
6151     if (cond) {
6152         enterop->op_first = scalar(cond);
6153         cond->op_sibling = block;
6154
6155         o->op_next = LINKLIST(cond);
6156         cond->op_next = (OP *) enterop;
6157     }
6158     else {
6159         /* This is a default {} block */
6160         enterop->op_first = block;
6161         enterop->op_flags |= OPf_SPECIAL;
6162         o      ->op_flags |= OPf_SPECIAL;
6163
6164         o->op_next = (OP *) enterop;
6165     }
6166
6167     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6168                                        entergiven and enterwhen both
6169                                        use ck_null() */
6170
6171     enterop->op_next = LINKLIST(block);
6172     block->op_next = enterop->op_other = o;
6173
6174     return o;
6175 }
6176
6177 /* Does this look like a boolean operation? For these purposes
6178    a boolean operation is:
6179      - a subroutine call [*]
6180      - a logical connective
6181      - a comparison operator
6182      - a filetest operator, with the exception of -s -M -A -C
6183      - defined(), exists() or eof()
6184      - /$re/ or $foo =~ /$re/
6185
6186    [*] possibly surprising
6187  */
6188 STATIC bool
6189 S_looks_like_bool(pTHX_ const OP *o)
6190 {
6191     dVAR;
6192
6193     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6194
6195     switch(o->op_type) {
6196         case OP_OR:
6197         case OP_DOR:
6198             return looks_like_bool(cLOGOPo->op_first);
6199
6200         case OP_AND:
6201             return (
6202                 looks_like_bool(cLOGOPo->op_first)
6203              && looks_like_bool(cLOGOPo->op_first->op_sibling));
6204
6205         case OP_NULL:
6206         case OP_SCALAR:
6207             return (
6208                 o->op_flags & OPf_KIDS
6209             && looks_like_bool(cUNOPo->op_first));
6210
6211         case OP_ENTERSUB:
6212
6213         case OP_NOT:    case OP_XOR:
6214
6215         case OP_EQ:     case OP_NE:     case OP_LT:
6216         case OP_GT:     case OP_LE:     case OP_GE:
6217
6218         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
6219         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
6220
6221         case OP_SEQ:    case OP_SNE:    case OP_SLT:
6222         case OP_SGT:    case OP_SLE:    case OP_SGE:
6223
6224         case OP_SMARTMATCH:
6225
6226         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
6227         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
6228         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
6229         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
6230         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
6231         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
6232         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
6233         case OP_FTTEXT:   case OP_FTBINARY:
6234
6235         case OP_DEFINED: case OP_EXISTS:
6236         case OP_MATCH:   case OP_EOF:
6237
6238         case OP_FLOP:
6239
6240             return TRUE;
6241
6242         case OP_CONST:
6243             /* Detect comparisons that have been optimized away */
6244             if (cSVOPo->op_sv == &PL_sv_yes
6245             ||  cSVOPo->op_sv == &PL_sv_no)
6246
6247                 return TRUE;
6248             else
6249                 return FALSE;
6250
6251         /* FALL THROUGH */
6252         default:
6253             return FALSE;
6254     }
6255 }
6256
6257 /*
6258 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6259
6260 Constructs, checks, and returns an op tree expressing a C<given> block.
6261 I<cond> supplies the expression that will be locally assigned to a lexical
6262 variable, and I<block> supplies the body of the C<given> construct; they
6263 are consumed by this function and become part of the constructed op tree.
6264 I<defsv_off> is the pad offset of the scalar lexical variable that will
6265 be affected.
6266
6267 =cut
6268 */
6269
6270 OP *
6271 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6272 {
6273     dVAR;
6274     PERL_ARGS_ASSERT_NEWGIVENOP;
6275     return newGIVWHENOP(
6276         ref_array_or_hash(cond),
6277         block,
6278         OP_ENTERGIVEN, OP_LEAVEGIVEN,
6279         defsv_off);
6280 }
6281
6282 /*
6283 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6284
6285 Constructs, checks, and returns an op tree expressing a C<when> block.
6286 I<cond> supplies the test expression, and I<block> supplies the block
6287 that will be executed if the test evaluates to true; they are consumed
6288 by this function and become part of the constructed op tree.  I<cond>
6289 will be interpreted DWIMically, often as a comparison against C<$_>,
6290 and may be null to generate a C<default> block.
6291
6292 =cut
6293 */
6294
6295 OP *
6296 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6297 {
6298     const bool cond_llb = (!cond || looks_like_bool(cond));
6299     OP *cond_op;
6300
6301     PERL_ARGS_ASSERT_NEWWHENOP;
6302
6303     if (cond_llb)
6304         cond_op = cond;
6305     else {
6306         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6307                 newDEFSVOP(),
6308                 scalar(ref_array_or_hash(cond)));
6309     }
6310
6311     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6312 }
6313
6314 void
6315 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6316                     const STRLEN len, const U32 flags)
6317 {
6318     const char * const cvp = CvPROTO(cv);
6319     const STRLEN clen = CvPROTOLEN(cv);
6320
6321     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6322
6323     if (((!p != !cvp) /* One has prototype, one has not.  */
6324         || (p && (
6325                   (flags & SVf_UTF8) == SvUTF8(cv)
6326                    ? len != clen || memNE(cvp, p, len)
6327                    : flags & SVf_UTF8
6328                       ? bytes_cmp_utf8((const U8 *)cvp, clen,
6329                                        (const U8 *)p, len)
6330                       : bytes_cmp_utf8((const U8 *)p, len,
6331                                        (const U8 *)cvp, clen)
6332                  )
6333            )
6334         )
6335          && ckWARN_d(WARN_PROTOTYPE)) {
6336         SV* const msg = sv_newmortal();
6337         SV* name = NULL;
6338
6339         if (gv)
6340             gv_efullname3(name = sv_newmortal(), gv, NULL);
6341         sv_setpvs(msg, "Prototype mismatch:");
6342         if (name)
6343             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6344         if (SvPOK(cv))
6345             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6346                 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6347             );
6348         else
6349             sv_catpvs(msg, ": none");
6350         sv_catpvs(msg, " vs ");
6351         if (p)
6352             Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6353         else
6354             sv_catpvs(msg, "none");
6355         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6356     }
6357 }
6358
6359 static void const_sv_xsub(pTHX_ CV* cv);
6360
6361 /*
6362
6363 =head1 Optree Manipulation Functions
6364
6365 =for apidoc cv_const_sv
6366
6367 If C<cv> is a constant sub eligible for inlining. returns the constant
6368 value returned by the sub.  Otherwise, returns NULL.
6369
6370 Constant subs can be created with C<newCONSTSUB> or as described in
6371 L<perlsub/"Constant Functions">.
6372
6373 =cut
6374 */
6375 SV *
6376 Perl_cv_const_sv(pTHX_ const CV *const cv)
6377 {
6378     PERL_UNUSED_CONTEXT;
6379     if (!cv)
6380         return NULL;
6381     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6382         return NULL;
6383     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6384 }
6385
6386 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
6387  * Can be called in 3 ways:
6388  *
6389  * !cv
6390  *      look for a single OP_CONST with attached value: return the value
6391  *
6392  * cv && CvCLONE(cv) && !CvCONST(cv)
6393  *
6394  *      examine the clone prototype, and if contains only a single
6395  *      OP_CONST referencing a pad const, or a single PADSV referencing
6396  *      an outer lexical, return a non-zero value to indicate the CV is
6397  *      a candidate for "constizing" at clone time
6398  *
6399  * cv && CvCONST(cv)
6400  *
6401  *      We have just cloned an anon prototype that was marked as a const
6402  *      candidate. Try to grab the current value, and in the case of
6403  *      PADSV, ignore it if it has multiple references. Return the value.
6404  */
6405
6406 SV *
6407 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6408 {
6409     dVAR;
6410     SV *sv = NULL;
6411
6412     if (PL_madskills)
6413         return NULL;
6414
6415     if (!o)
6416         return NULL;
6417
6418     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6419         o = cLISTOPo->op_first->op_sibling;
6420
6421     for (; o; o = o->op_next) {
6422         const OPCODE type = o->op_type;
6423
6424         if (sv && o->op_next == o)
6425             return sv;
6426         if (o->op_next != o) {
6427             if (type == OP_NEXTSTATE
6428              || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6429              || type == OP_PUSHMARK)
6430                 continue;
6431             if (type == OP_DBSTATE)
6432                 continue;
6433         }
6434         if (type == OP_LEAVESUB || type == OP_RETURN)
6435             break;
6436         if (sv)
6437             return NULL;
6438         if (type == OP_CONST && cSVOPo->op_sv)
6439             sv = cSVOPo->op_sv;
6440         else if (cv && type == OP_CONST) {
6441             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6442             if (!sv)
6443                 return NULL;
6444         }
6445         else if (cv && type == OP_PADSV) {
6446             if (CvCONST(cv)) { /* newly cloned anon */
6447                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6448                 /* the candidate should have 1 ref from this pad and 1 ref
6449                  * from the parent */
6450                 if (!sv || SvREFCNT(sv) != 2)
6451                     return NULL;
6452                 sv = newSVsv(sv);
6453                 SvREADONLY_on(sv);
6454                 return sv;
6455             }
6456             else {
6457                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6458                     sv = &PL_sv_undef; /* an arbitrary non-null value */
6459             }
6460         }
6461         else {
6462             return NULL;
6463         }
6464     }
6465     return sv;
6466 }
6467
6468 #ifdef PERL_MAD
6469 OP *
6470 #else
6471 void
6472 #endif
6473 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6474 {
6475 #if 0
6476     /* This would be the return value, but the return cannot be reached.  */
6477     OP* pegop = newOP(OP_NULL, 0);
6478 #endif
6479
6480     PERL_UNUSED_ARG(floor);
6481
6482     if (o)
6483         SAVEFREEOP(o);
6484     if (proto)
6485         SAVEFREEOP(proto);
6486     if (attrs)
6487         SAVEFREEOP(attrs);
6488     if (block)
6489         SAVEFREEOP(block);
6490     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6491 #ifdef PERL_MAD
6492     NORETURN_FUNCTION_END;
6493 #endif
6494 }
6495
6496 CV *
6497 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6498 {
6499     return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6500 }
6501
6502 CV *
6503 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6504                             OP *block, U32 flags)
6505 {
6506     dVAR;
6507     GV *gv;
6508     const char *ps;
6509     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6510     U32 ps_utf8 = 0;
6511     register CV *cv = NULL;
6512     SV *const_sv;
6513     /* If the subroutine has no body, no attributes, and no builtin attributes
6514        then it's just a sub declaration, and we may be able to get away with
6515        storing with a placeholder scalar in the symbol table, rather than a
6516        full GV and CV.  If anything is present then it will take a full CV to
6517        store it.  */
6518     const I32 gv_fetch_flags
6519         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6520            || PL_madskills)
6521         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6522     STRLEN namlen = 0;
6523     const bool o_is_gv = flags & 1;
6524     const char * const name =
6525          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6526     bool has_name;
6527     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6528
6529     if (proto) {
6530         assert(proto->op_type == OP_CONST);
6531         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6532         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6533     }
6534     else
6535         ps = NULL;
6536
6537     if (o_is_gv) {
6538         gv = (GV*)o;
6539         o = NULL;
6540         has_name = TRUE;
6541     } else if (name) {
6542         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6543         has_name = TRUE;
6544     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6545         SV * const sv = sv_newmortal();
6546         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6547                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6548                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6549         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6550         has_name = TRUE;
6551     } else if (PL_curstash) {
6552         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6553         has_name = FALSE;
6554     } else {
6555         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6556         has_name = FALSE;
6557     }
6558
6559     if (!PL_madskills) {
6560         if (o)
6561             SAVEFREEOP(o);
6562         if (proto)
6563             SAVEFREEOP(proto);
6564         if (attrs)
6565             SAVEFREEOP(attrs);
6566     }
6567
6568     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
6569                                            maximum a prototype before. */
6570         if (SvTYPE(gv) > SVt_NULL) {
6571             if (!SvPOK((const SV *)gv)
6572                 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6573             {
6574                 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6575             }
6576             cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6577         }
6578         if (ps) {
6579             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6580             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6581         }
6582         else
6583             sv_setiv(MUTABLE_SV(gv), -1);
6584
6585         SvREFCNT_dec(PL_compcv);
6586         cv = PL_compcv = NULL;
6587         goto done;
6588     }
6589
6590     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6591
6592     if (!block || !ps || *ps || attrs
6593         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6594 #ifdef PERL_MAD
6595         || block->op_type == OP_NULL
6596 #endif
6597         )
6598         const_sv = NULL;
6599     else
6600         const_sv = op_const_sv(block, NULL);
6601
6602     if (cv) {
6603         const bool exists = CvROOT(cv) || CvXSUB(cv);
6604
6605         /* if the subroutine doesn't exist and wasn't pre-declared
6606          * with a prototype, assume it will be AUTOLOADed,
6607          * skipping the prototype check
6608          */
6609         if (exists || SvPOK(cv))
6610             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6611         /* already defined (or promised)? */
6612         if (exists || GvASSUMECV(gv)) {
6613             if ((!block
6614 #ifdef PERL_MAD
6615                  || block->op_type == OP_NULL
6616 #endif
6617                  )) {
6618                 if (CvFLAGS(PL_compcv)) {
6619                     /* might have had built-in attrs applied */
6620                     const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6621                     if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6622                      && ckWARN(WARN_MISC))
6623                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6624                     CvFLAGS(cv) |=
6625                         (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6626                           & ~(CVf_LVALUE * pureperl));
6627                 }
6628                 if (attrs) goto attrs;
6629                 /* just a "sub foo;" when &foo is already defined */
6630                 SAVEFREESV(PL_compcv);
6631                 goto done;
6632             }
6633             if (block
6634 #ifdef PERL_MAD
6635                 && block->op_type != OP_NULL
6636 #endif
6637                 ) {
6638                 const line_t oldline = CopLINE(PL_curcop);
6639                 if (PL_parser && PL_parser->copline != NOLINE)
6640                         CopLINE_set(PL_curcop, PL_parser->copline);
6641                 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6642                 CopLINE_set(PL_curcop, oldline);
6643 #ifdef PERL_MAD
6644                 if (!PL_minus_c)        /* keep old one around for madskills */
6645 #endif
6646                     {
6647                         /* (PL_madskills unset in used file.) */
6648                         SvREFCNT_dec(cv);
6649                     }
6650                 cv = NULL;
6651             }
6652         }
6653     }
6654     if (const_sv) {
6655         HV *stash;
6656         SvREFCNT_inc_simple_void_NN(const_sv);
6657         if (cv) {
6658             assert(!CvROOT(cv) && !CvCONST(cv));
6659             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
6660             CvXSUBANY(cv).any_ptr = const_sv;
6661             CvXSUB(cv) = const_sv_xsub;
6662             CvCONST_on(cv);
6663             CvISXSUB_on(cv);
6664         }
6665         else {
6666             GvCV_set(gv, NULL);
6667             cv = newCONSTSUB_flags(
6668                 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6669                 const_sv
6670             );
6671         }
6672         stash =
6673             (CvGV(cv) && GvSTASH(CvGV(cv)))
6674                 ? GvSTASH(CvGV(cv))
6675                 : CvSTASH(cv)
6676                     ? CvSTASH(cv)
6677                     : PL_curstash;
6678         if (HvENAME_HEK(stash))
6679             mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6680         if (PL_madskills)
6681             goto install_block;
6682         op_free(block);
6683         SvREFCNT_dec(PL_compcv);
6684         PL_compcv = NULL;
6685         goto done;
6686     }
6687     if (cv) {                           /* must reuse cv if autoloaded */
6688         /* transfer PL_compcv to cv */
6689         if (block
6690 #ifdef PERL_MAD
6691                   && block->op_type != OP_NULL
6692 #endif
6693         ) {
6694             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6695             AV *const temp_av = CvPADLIST(cv);
6696             CV *const temp_cv = CvOUTSIDE(cv);
6697
6698             assert(!CvWEAKOUTSIDE(cv));
6699             assert(!CvCVGV_RC(cv));
6700             assert(CvGV(cv) == gv);
6701
6702             SvPOK_off(cv);
6703             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6704             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6705             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6706             CvPADLIST(cv) = CvPADLIST(PL_compcv);
6707             CvOUTSIDE(PL_compcv) = temp_cv;
6708             CvPADLIST(PL_compcv) = temp_av;
6709
6710             if (CvFILE(cv) && CvDYNFILE(cv)) {
6711                 Safefree(CvFILE(cv));
6712     }
6713             CvFILE_set_from_cop(cv, PL_curcop);
6714             CvSTASH_set(cv, PL_curstash);
6715
6716             /* inner references to PL_compcv must be fixed up ... */
6717             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6718             if (PERLDB_INTER)/* Advice debugger on the new sub. */
6719               ++PL_sub_generation;
6720         }
6721         else {
6722             /* Might have had built-in attributes applied -- propagate them. */
6723             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6724         }
6725         /* ... before we throw it away */
6726         SvREFCNT_dec(PL_compcv);
6727         PL_compcv = cv;
6728     }
6729     else {
6730         cv = PL_compcv;
6731         if (name) {
6732             GvCV_set(gv, cv);
6733             if (PL_madskills) {
6734                 if (strEQ(name, "import")) {
6735                     PL_formfeed = MUTABLE_SV(cv);
6736                     /* diag_listed_as: SKIPME */
6737                     Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6738                 }
6739             }
6740             GvCVGEN(gv) = 0;
6741             if (HvENAME_HEK(GvSTASH(gv)))
6742                 /* sub Foo::bar { (shift)+1 } */
6743                 mro_method_changed_in(GvSTASH(gv));
6744         }
6745     }
6746     if (!CvGV(cv)) {