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         PL_modcount++;
1779         return o;
1780     case OP_STUB:
1781         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1782             break;
1783         goto nomod;
1784     case OP_ENTERSUB:
1785         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1786             !(o->op_flags & OPf_STACKED)) {
1787             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1788             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1789                poses, so we need it clear.  */
1790             o->op_private &= ~1;
1791             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1792             assert(cUNOPo->op_first->op_type == OP_NULL);
1793             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1794             break;
1795         }
1796         else {                          /* lvalue subroutine call */
1797             o->op_private |= OPpLVAL_INTRO
1798                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1799             PL_modcount = RETURN_UNLIMITED_NUMBER;
1800             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1801                 /* Potential lvalue context: */
1802                 o->op_private |= OPpENTERSUB_INARGS;
1803                 break;
1804             }
1805             else {                      /* Compile-time error message: */
1806                 OP *kid = cUNOPo->op_first;
1807                 CV *cv;
1808
1809                 if (kid->op_type != OP_PUSHMARK) {
1810                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1811                         Perl_croak(aTHX_
1812                                 "panic: unexpected lvalue entersub "
1813                                 "args: type/targ %ld:%"UVuf,
1814                                 (long)kid->op_type, (UV)kid->op_targ);
1815                     kid = kLISTOP->op_first;
1816                 }
1817                 while (kid->op_sibling)
1818                     kid = kid->op_sibling;
1819                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1820                     break;      /* Postpone until runtime */
1821                 }
1822
1823                 kid = kUNOP->op_first;
1824                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1825                     kid = kUNOP->op_first;
1826                 if (kid->op_type == OP_NULL)
1827                     Perl_croak(aTHX_
1828                                "Unexpected constant lvalue entersub "
1829                                "entry via type/targ %ld:%"UVuf,
1830                                (long)kid->op_type, (UV)kid->op_targ);
1831                 if (kid->op_type != OP_GV) {
1832                     break;
1833                 }
1834
1835                 cv = GvCV(kGVOP_gv);
1836                 if (!cv)
1837                     break;
1838                 if (CvLVALUE(cv))
1839                     break;
1840             }
1841         }
1842         /* FALL THROUGH */
1843     default:
1844       nomod:
1845         if (flags & OP_LVALUE_NO_CROAK) return NULL;
1846         /* grep, foreach, subcalls, refgen */
1847         if (type == OP_GREPSTART || type == OP_ENTERSUB
1848          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
1849             break;
1850         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1851                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1852                       ? "do block"
1853                       : (o->op_type == OP_ENTERSUB
1854                         ? "non-lvalue subroutine call"
1855                         : OP_DESC(o))),
1856                      type ? PL_op_desc[type] : "local"));
1857         return o;
1858
1859     case OP_PREINC:
1860     case OP_PREDEC:
1861     case OP_POW:
1862     case OP_MULTIPLY:
1863     case OP_DIVIDE:
1864     case OP_MODULO:
1865     case OP_REPEAT:
1866     case OP_ADD:
1867     case OP_SUBTRACT:
1868     case OP_CONCAT:
1869     case OP_LEFT_SHIFT:
1870     case OP_RIGHT_SHIFT:
1871     case OP_BIT_AND:
1872     case OP_BIT_XOR:
1873     case OP_BIT_OR:
1874     case OP_I_MULTIPLY:
1875     case OP_I_DIVIDE:
1876     case OP_I_MODULO:
1877     case OP_I_ADD:
1878     case OP_I_SUBTRACT:
1879         if (!(o->op_flags & OPf_STACKED))
1880             goto nomod;
1881         PL_modcount++;
1882         break;
1883
1884     case OP_COND_EXPR:
1885         localize = 1;
1886         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1887             op_lvalue(kid, type);
1888         break;
1889
1890     case OP_RV2AV:
1891     case OP_RV2HV:
1892         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1893            PL_modcount = RETURN_UNLIMITED_NUMBER;
1894             return o;           /* Treat \(@foo) like ordinary list. */
1895         }
1896         /* FALL THROUGH */
1897     case OP_RV2GV:
1898         if (scalar_mod_type(o, type))
1899             goto nomod;
1900         ref(cUNOPo->op_first, o->op_type);
1901         /* FALL THROUGH */
1902     case OP_ASLICE:
1903     case OP_HSLICE:
1904         if (type == OP_LEAVESUBLV)
1905             o->op_private |= OPpMAYBE_LVSUB;
1906         localize = 1;
1907         /* FALL THROUGH */
1908     case OP_AASSIGN:
1909     case OP_NEXTSTATE:
1910     case OP_DBSTATE:
1911        PL_modcount = RETURN_UNLIMITED_NUMBER;
1912         break;
1913     case OP_AV2ARYLEN:
1914         PL_hints |= HINT_BLOCK_SCOPE;
1915         if (type == OP_LEAVESUBLV)
1916             o->op_private |= OPpMAYBE_LVSUB;
1917         PL_modcount++;
1918         break;
1919     case OP_RV2SV:
1920         ref(cUNOPo->op_first, o->op_type);
1921         localize = 1;
1922         /* FALL THROUGH */
1923     case OP_GV:
1924         PL_hints |= HINT_BLOCK_SCOPE;
1925     case OP_SASSIGN:
1926     case OP_ANDASSIGN:
1927     case OP_ORASSIGN:
1928     case OP_DORASSIGN:
1929         PL_modcount++;
1930         break;
1931
1932     case OP_AELEMFAST:
1933     case OP_AELEMFAST_LEX:
1934         localize = -1;
1935         PL_modcount++;
1936         break;
1937
1938     case OP_PADAV:
1939     case OP_PADHV:
1940        PL_modcount = RETURN_UNLIMITED_NUMBER;
1941         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1942             return o;           /* Treat \(@foo) like ordinary list. */
1943         if (scalar_mod_type(o, type))
1944             goto nomod;
1945         if (type == OP_LEAVESUBLV)
1946             o->op_private |= OPpMAYBE_LVSUB;
1947         /* FALL THROUGH */
1948     case OP_PADSV:
1949         PL_modcount++;
1950         if (!type) /* local() */
1951             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1952                  PAD_COMPNAME_SV(o->op_targ));
1953         break;
1954
1955     case OP_PUSHMARK:
1956         localize = 0;
1957         break;
1958
1959     case OP_KEYS:
1960     case OP_RKEYS:
1961         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1962             goto nomod;
1963         goto lvalue_func;
1964     case OP_SUBSTR:
1965         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1966             goto nomod;
1967         /* FALL THROUGH */
1968     case OP_POS:
1969     case OP_VEC:
1970       lvalue_func:
1971         if (type == OP_LEAVESUBLV)
1972             o->op_private |= OPpMAYBE_LVSUB;
1973         pad_free(o->op_targ);
1974         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1975         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1976         if (o->op_flags & OPf_KIDS)
1977             op_lvalue(cBINOPo->op_first->op_sibling, type);
1978         break;
1979
1980     case OP_AELEM:
1981     case OP_HELEM:
1982         ref(cBINOPo->op_first, o->op_type);
1983         if (type == OP_ENTERSUB &&
1984              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1985             o->op_private |= OPpLVAL_DEFER;
1986         if (type == OP_LEAVESUBLV)
1987             o->op_private |= OPpMAYBE_LVSUB;
1988         localize = 1;
1989         PL_modcount++;
1990         break;
1991
1992     case OP_SCOPE:
1993     case OP_LEAVE:
1994     case OP_ENTER:
1995     case OP_LINESEQ:
1996         localize = 0;
1997         if (o->op_flags & OPf_KIDS)
1998             op_lvalue(cLISTOPo->op_last, type);
1999         break;
2000
2001     case OP_NULL:
2002         localize = 0;
2003         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2004             goto nomod;
2005         else if (!(o->op_flags & OPf_KIDS))
2006             break;
2007         if (o->op_targ != OP_LIST) {
2008             op_lvalue(cBINOPo->op_first, type);
2009             break;
2010         }
2011         /* FALL THROUGH */
2012     case OP_LIST:
2013         localize = 0;
2014         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2015             /* elements might be in void context because the list is
2016                in scalar context or because they are attribute sub calls */
2017             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2018                 op_lvalue(kid, type);
2019         break;
2020
2021     case OP_RETURN:
2022         if (type != OP_LEAVESUBLV)
2023             goto nomod;
2024         break; /* op_lvalue()ing was handled by ck_return() */
2025
2026     case OP_COREARGS:
2027         return o;
2028     }
2029
2030     /* [20011101.069] File test operators interpret OPf_REF to mean that
2031        their argument is a filehandle; thus \stat(".") should not set
2032        it. AMS 20011102 */
2033     if (type == OP_REFGEN &&
2034         PL_check[o->op_type] == Perl_ck_ftst)
2035         return o;
2036
2037     if (type != OP_LEAVESUBLV)
2038         o->op_flags |= OPf_MOD;
2039
2040     if (type == OP_AASSIGN || type == OP_SASSIGN)
2041         o->op_flags |= OPf_SPECIAL|OPf_REF;
2042     else if (!type) { /* local() */
2043         switch (localize) {
2044         case 1:
2045             o->op_private |= OPpLVAL_INTRO;
2046             o->op_flags &= ~OPf_SPECIAL;
2047             PL_hints |= HINT_BLOCK_SCOPE;
2048             break;
2049         case 0:
2050             break;
2051         case -1:
2052             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2053                            "Useless localization of %s", OP_DESC(o));
2054         }
2055     }
2056     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2057              && type != OP_LEAVESUBLV)
2058         o->op_flags |= OPf_REF;
2059     return o;
2060 }
2061
2062 STATIC bool
2063 S_scalar_mod_type(const OP *o, I32 type)
2064 {
2065     switch (type) {
2066     case OP_POS:
2067     case OP_SASSIGN:
2068         if (o && o->op_type == OP_RV2GV)
2069             return FALSE;
2070         /* FALL THROUGH */
2071     case OP_PREINC:
2072     case OP_PREDEC:
2073     case OP_POSTINC:
2074     case OP_POSTDEC:
2075     case OP_I_PREINC:
2076     case OP_I_PREDEC:
2077     case OP_I_POSTINC:
2078     case OP_I_POSTDEC:
2079     case OP_POW:
2080     case OP_MULTIPLY:
2081     case OP_DIVIDE:
2082     case OP_MODULO:
2083     case OP_REPEAT:
2084     case OP_ADD:
2085     case OP_SUBTRACT:
2086     case OP_I_MULTIPLY:
2087     case OP_I_DIVIDE:
2088     case OP_I_MODULO:
2089     case OP_I_ADD:
2090     case OP_I_SUBTRACT:
2091     case OP_LEFT_SHIFT:
2092     case OP_RIGHT_SHIFT:
2093     case OP_BIT_AND:
2094     case OP_BIT_XOR:
2095     case OP_BIT_OR:
2096     case OP_CONCAT:
2097     case OP_SUBST:
2098     case OP_TRANS:
2099     case OP_TRANSR:
2100     case OP_READ:
2101     case OP_SYSREAD:
2102     case OP_RECV:
2103     case OP_ANDASSIGN:
2104     case OP_ORASSIGN:
2105     case OP_DORASSIGN:
2106         return TRUE;
2107     default:
2108         return FALSE;
2109     }
2110 }
2111
2112 STATIC bool
2113 S_is_handle_constructor(const OP *o, I32 numargs)
2114 {
2115     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2116
2117     switch (o->op_type) {
2118     case OP_PIPE_OP:
2119     case OP_SOCKPAIR:
2120         if (numargs == 2)
2121             return TRUE;
2122         /* FALL THROUGH */
2123     case OP_SYSOPEN:
2124     case OP_OPEN:
2125     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2126     case OP_SOCKET:
2127     case OP_OPEN_DIR:
2128     case OP_ACCEPT:
2129         if (numargs == 1)
2130             return TRUE;
2131         /* FALLTHROUGH */
2132     default:
2133         return FALSE;
2134     }
2135 }
2136
2137 static OP *
2138 S_refkids(pTHX_ OP *o, I32 type)
2139 {
2140     if (o && o->op_flags & OPf_KIDS) {
2141         OP *kid;
2142         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2143             ref(kid, type);
2144     }
2145     return o;
2146 }
2147
2148 OP *
2149 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2150 {
2151     dVAR;
2152     OP *kid;
2153
2154     PERL_ARGS_ASSERT_DOREF;
2155
2156     if (!o || (PL_parser && PL_parser->error_count))
2157         return o;
2158
2159     switch (o->op_type) {
2160     case OP_ENTERSUB:
2161         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2162             !(o->op_flags & OPf_STACKED)) {
2163             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2164             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2165             assert(cUNOPo->op_first->op_type == OP_NULL);
2166             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2167             o->op_flags |= OPf_SPECIAL;
2168             o->op_private &= ~1;
2169         }
2170         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2171             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2172                               : type == OP_RV2HV ? OPpDEREF_HV
2173                               : OPpDEREF_SV);
2174             o->op_flags |= OPf_MOD;
2175         }
2176
2177         break;
2178
2179     case OP_COND_EXPR:
2180         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2181             doref(kid, type, set_op_ref);
2182         break;
2183     case OP_RV2SV:
2184         if (type == OP_DEFINED)
2185             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2186         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2187         /* FALL THROUGH */
2188     case OP_PADSV:
2189         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2190             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2191                               : type == OP_RV2HV ? OPpDEREF_HV
2192                               : OPpDEREF_SV);
2193             o->op_flags |= OPf_MOD;
2194         }
2195         break;
2196
2197     case OP_RV2AV:
2198     case OP_RV2HV:
2199         if (set_op_ref)
2200             o->op_flags |= OPf_REF;
2201         /* FALL THROUGH */
2202     case OP_RV2GV:
2203         if (type == OP_DEFINED)
2204             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2205         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2206         break;
2207
2208     case OP_PADAV:
2209     case OP_PADHV:
2210         if (set_op_ref)
2211             o->op_flags |= OPf_REF;
2212         break;
2213
2214     case OP_SCALAR:
2215     case OP_NULL:
2216         if (!(o->op_flags & OPf_KIDS))
2217             break;
2218         doref(cBINOPo->op_first, type, set_op_ref);
2219         break;
2220     case OP_AELEM:
2221     case OP_HELEM:
2222         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2223         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2224             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2225                               : type == OP_RV2HV ? OPpDEREF_HV
2226                               : OPpDEREF_SV);
2227             o->op_flags |= OPf_MOD;
2228         }
2229         break;
2230
2231     case OP_SCOPE:
2232     case OP_LEAVE:
2233         set_op_ref = FALSE;
2234         /* FALL THROUGH */
2235     case OP_ENTER:
2236     case OP_LIST:
2237         if (!(o->op_flags & OPf_KIDS))
2238             break;
2239         doref(cLISTOPo->op_last, type, set_op_ref);
2240         break;
2241     default:
2242         break;
2243     }
2244     return scalar(o);
2245
2246 }
2247
2248 STATIC OP *
2249 S_dup_attrlist(pTHX_ OP *o)
2250 {
2251     dVAR;
2252     OP *rop;
2253
2254     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2255
2256     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2257      * where the first kid is OP_PUSHMARK and the remaining ones
2258      * are OP_CONST.  We need to push the OP_CONST values.
2259      */
2260     if (o->op_type == OP_CONST)
2261         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2262 #ifdef PERL_MAD
2263     else if (o->op_type == OP_NULL)
2264         rop = NULL;
2265 #endif
2266     else {
2267         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2268         rop = NULL;
2269         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2270             if (o->op_type == OP_CONST)
2271                 rop = op_append_elem(OP_LIST, rop,
2272                                   newSVOP(OP_CONST, o->op_flags,
2273                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2274         }
2275     }
2276     return rop;
2277 }
2278
2279 STATIC void
2280 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2281 {
2282     dVAR;
2283     SV *stashsv;
2284
2285     PERL_ARGS_ASSERT_APPLY_ATTRS;
2286
2287     /* fake up C<use attributes $pkg,$rv,@attrs> */
2288     ENTER;              /* need to protect against side-effects of 'use' */
2289     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2290
2291 #define ATTRSMODULE "attributes"
2292 #define ATTRSMODULE_PM "attributes.pm"
2293
2294     if (for_my) {
2295         /* Don't force the C<use> if we don't need it. */
2296         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2297         if (svp && *svp != &PL_sv_undef)
2298             NOOP;       /* already in %INC */
2299         else
2300             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2301                              newSVpvs(ATTRSMODULE), NULL);
2302     }
2303     else {
2304         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2305                          newSVpvs(ATTRSMODULE),
2306                          NULL,
2307                          op_prepend_elem(OP_LIST,
2308                                       newSVOP(OP_CONST, 0, stashsv),
2309                                       op_prepend_elem(OP_LIST,
2310                                                    newSVOP(OP_CONST, 0,
2311                                                            newRV(target)),
2312                                                    dup_attrlist(attrs))));
2313     }
2314     LEAVE;
2315 }
2316
2317 STATIC void
2318 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2319 {
2320     dVAR;
2321     OP *pack, *imop, *arg;
2322     SV *meth, *stashsv;
2323
2324     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2325
2326     if (!attrs)
2327         return;
2328
2329     assert(target->op_type == OP_PADSV ||
2330            target->op_type == OP_PADHV ||
2331            target->op_type == OP_PADAV);
2332
2333     /* Ensure that attributes.pm is loaded. */
2334     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2335
2336     /* Need package name for method call. */
2337     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2338
2339     /* Build up the real arg-list. */
2340     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2341
2342     arg = newOP(OP_PADSV, 0);
2343     arg->op_targ = target->op_targ;
2344     arg = op_prepend_elem(OP_LIST,
2345                        newSVOP(OP_CONST, 0, stashsv),
2346                        op_prepend_elem(OP_LIST,
2347                                     newUNOP(OP_REFGEN, 0,
2348                                             op_lvalue(arg, OP_REFGEN)),
2349                                     dup_attrlist(attrs)));
2350
2351     /* Fake up a method call to import */
2352     meth = newSVpvs_share("import");
2353     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2354                    op_append_elem(OP_LIST,
2355                                op_prepend_elem(OP_LIST, pack, list(arg)),
2356                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2357
2358     /* Combine the ops. */
2359     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2360 }
2361
2362 /*
2363 =notfor apidoc apply_attrs_string
2364
2365 Attempts to apply a list of attributes specified by the C<attrstr> and
2366 C<len> arguments to the subroutine identified by the C<cv> argument which
2367 is expected to be associated with the package identified by the C<stashpv>
2368 argument (see L<attributes>).  It gets this wrong, though, in that it
2369 does not correctly identify the boundaries of the individual attribute
2370 specifications within C<attrstr>.  This is not really intended for the
2371 public API, but has to be listed here for systems such as AIX which
2372 need an explicit export list for symbols.  (It's called from XS code
2373 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2374 to respect attribute syntax properly would be welcome.
2375
2376 =cut
2377 */
2378
2379 void
2380 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2381                         const char *attrstr, STRLEN len)
2382 {
2383     OP *attrs = NULL;
2384
2385     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2386
2387     if (!len) {
2388         len = strlen(attrstr);
2389     }
2390
2391     while (len) {
2392         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2393         if (len) {
2394             const char * const sstr = attrstr;
2395             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2396             attrs = op_append_elem(OP_LIST, attrs,
2397                                 newSVOP(OP_CONST, 0,
2398                                         newSVpvn(sstr, attrstr-sstr)));
2399         }
2400     }
2401
2402     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2403                      newSVpvs(ATTRSMODULE),
2404                      NULL, op_prepend_elem(OP_LIST,
2405                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2406                                   op_prepend_elem(OP_LIST,
2407                                                newSVOP(OP_CONST, 0,
2408                                                        newRV(MUTABLE_SV(cv))),
2409                                                attrs)));
2410 }
2411
2412 STATIC OP *
2413 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2414 {
2415     dVAR;
2416     I32 type;
2417     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2418
2419     PERL_ARGS_ASSERT_MY_KID;
2420
2421     if (!o || (PL_parser && PL_parser->error_count))
2422         return o;
2423
2424     type = o->op_type;
2425     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2426         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2427         return o;
2428     }
2429
2430     if (type == OP_LIST) {
2431         OP *kid;
2432         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2433             my_kid(kid, attrs, imopsp);
2434         return o;
2435     } else if (type == OP_UNDEF
2436 #ifdef PERL_MAD
2437                || type == OP_STUB
2438 #endif
2439                ) {
2440         return o;
2441     } else if (type == OP_RV2SV ||      /* "our" declaration */
2442                type == OP_RV2AV ||
2443                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2444         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2445             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2446                         OP_DESC(o),
2447                         PL_parser->in_my == KEY_our
2448                             ? "our"
2449                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2450         } else if (attrs) {
2451             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2452             PL_parser->in_my = FALSE;
2453             PL_parser->in_my_stash = NULL;
2454             apply_attrs(GvSTASH(gv),
2455                         (type == OP_RV2SV ? GvSV(gv) :
2456                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2457                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2458                         attrs, FALSE);
2459         }
2460         o->op_private |= OPpOUR_INTRO;
2461         return o;
2462     }
2463     else if (type != OP_PADSV &&
2464              type != OP_PADAV &&
2465              type != OP_PADHV &&
2466              type != OP_PUSHMARK)
2467     {
2468         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2469                           OP_DESC(o),
2470                           PL_parser->in_my == KEY_our
2471                             ? "our"
2472                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2473         return o;
2474     }
2475     else if (attrs && type != OP_PUSHMARK) {
2476         HV *stash;
2477
2478         PL_parser->in_my = FALSE;
2479         PL_parser->in_my_stash = NULL;
2480
2481         /* check for C<my Dog $spot> when deciding package */
2482         stash = PAD_COMPNAME_TYPE(o->op_targ);
2483         if (!stash)
2484             stash = PL_curstash;
2485         apply_attrs_my(stash, o, attrs, imopsp);
2486     }
2487     o->op_flags |= OPf_MOD;
2488     o->op_private |= OPpLVAL_INTRO;
2489     if (stately)
2490         o->op_private |= OPpPAD_STATE;
2491     return o;
2492 }
2493
2494 OP *
2495 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2496 {
2497     dVAR;
2498     OP *rops;
2499     int maybe_scalar = 0;
2500
2501     PERL_ARGS_ASSERT_MY_ATTRS;
2502
2503 /* [perl #17376]: this appears to be premature, and results in code such as
2504    C< our(%x); > executing in list mode rather than void mode */
2505 #if 0
2506     if (o->op_flags & OPf_PARENS)
2507         list(o);
2508     else
2509         maybe_scalar = 1;
2510 #else
2511     maybe_scalar = 1;
2512 #endif
2513     if (attrs)
2514         SAVEFREEOP(attrs);
2515     rops = NULL;
2516     o = my_kid(o, attrs, &rops);
2517     if (rops) {
2518         if (maybe_scalar && o->op_type == OP_PADSV) {
2519             o = scalar(op_append_list(OP_LIST, rops, o));
2520             o->op_private |= OPpLVAL_INTRO;
2521         }
2522         else {
2523             /* The listop in rops might have a pushmark at the beginning,
2524                which will mess up list assignment. */
2525             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2526             if (rops->op_type == OP_LIST &&
2527                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2528             {
2529                 OP * const pushmark = lrops->op_first;
2530                 lrops->op_first = pushmark->op_sibling;
2531                 op_free(pushmark);
2532             }
2533             o = op_append_list(OP_LIST, o, rops);
2534         }
2535     }
2536     PL_parser->in_my = FALSE;
2537     PL_parser->in_my_stash = NULL;
2538     return o;
2539 }
2540
2541 OP *
2542 Perl_sawparens(pTHX_ OP *o)
2543 {
2544     PERL_UNUSED_CONTEXT;
2545     if (o)
2546         o->op_flags |= OPf_PARENS;
2547     return o;
2548 }
2549
2550 OP *
2551 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2552 {
2553     OP *o;
2554     bool ismatchop = 0;
2555     const OPCODE ltype = left->op_type;
2556     const OPCODE rtype = right->op_type;
2557
2558     PERL_ARGS_ASSERT_BIND_MATCH;
2559
2560     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2561           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2562     {
2563       const char * const desc
2564           = PL_op_desc[(
2565                           rtype == OP_SUBST || rtype == OP_TRANS
2566                        || rtype == OP_TRANSR
2567                        )
2568                        ? (int)rtype : OP_MATCH];
2569       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2570       GV *gv;
2571       SV * const name =
2572        (ltype == OP_RV2AV || ltype == OP_RV2HV)
2573         ?    cUNOPx(left)->op_first->op_type == OP_GV
2574           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2575               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2576               : NULL
2577         : varname(
2578            (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2579           );
2580       if (name)
2581         Perl_warner(aTHX_ packWARN(WARN_MISC),
2582              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2583              desc, name, name);
2584       else {
2585         const char * const sample = (isary
2586              ? "@array" : "%hash");
2587         Perl_warner(aTHX_ packWARN(WARN_MISC),
2588              "Applying %s to %s will act on scalar(%s)",
2589              desc, sample, sample);
2590       }
2591     }
2592
2593     if (rtype == OP_CONST &&
2594         cSVOPx(right)->op_private & OPpCONST_BARE &&
2595         cSVOPx(right)->op_private & OPpCONST_STRICT)
2596     {
2597         no_bareword_allowed(right);
2598     }
2599
2600     /* !~ doesn't make sense with /r, so error on it for now */
2601     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2602         type == OP_NOT)
2603         yyerror("Using !~ with s///r doesn't make sense");
2604     if (rtype == OP_TRANSR && type == OP_NOT)
2605         yyerror("Using !~ with tr///r doesn't make sense");
2606
2607     ismatchop = (rtype == OP_MATCH ||
2608                  rtype == OP_SUBST ||
2609                  rtype == OP_TRANS || rtype == OP_TRANSR)
2610              && !(right->op_flags & OPf_SPECIAL);
2611     if (ismatchop && right->op_private & OPpTARGET_MY) {
2612         right->op_targ = 0;
2613         right->op_private &= ~OPpTARGET_MY;
2614     }
2615     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2616         OP *newleft;
2617
2618         right->op_flags |= OPf_STACKED;
2619         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2620             ! (rtype == OP_TRANS &&
2621                right->op_private & OPpTRANS_IDENTICAL) &&
2622             ! (rtype == OP_SUBST &&
2623                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2624             newleft = op_lvalue(left, rtype);
2625         else
2626             newleft = left;
2627         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2628             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2629         else
2630             o = op_prepend_elem(rtype, scalar(newleft), right);
2631         if (type == OP_NOT)
2632             return newUNOP(OP_NOT, 0, scalar(o));
2633         return o;
2634     }
2635     else
2636         return bind_match(type, left,
2637                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2638 }
2639
2640 OP *
2641 Perl_invert(pTHX_ OP *o)
2642 {
2643     if (!o)
2644         return NULL;
2645     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2646 }
2647
2648 /*
2649 =for apidoc Amx|OP *|op_scope|OP *o
2650
2651 Wraps up an op tree with some additional ops so that at runtime a dynamic
2652 scope will be created.  The original ops run in the new dynamic scope,
2653 and then, provided that they exit normally, the scope will be unwound.
2654 The additional ops used to create and unwind the dynamic scope will
2655 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2656 instead if the ops are simple enough to not need the full dynamic scope
2657 structure.
2658
2659 =cut
2660 */
2661
2662 OP *
2663 Perl_op_scope(pTHX_ OP *o)
2664 {
2665     dVAR;
2666     if (o) {
2667         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2668             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2669             o->op_type = OP_LEAVE;
2670             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2671         }
2672         else if (o->op_type == OP_LINESEQ) {
2673             OP *kid;
2674             o->op_type = OP_SCOPE;
2675             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2676             kid = ((LISTOP*)o)->op_first;
2677             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2678                 op_null(kid);
2679
2680                 /* The following deals with things like 'do {1 for 1}' */
2681                 kid = kid->op_sibling;
2682                 if (kid &&
2683                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2684                     op_null(kid);
2685             }
2686         }
2687         else
2688             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2689     }
2690     return o;
2691 }
2692
2693 int
2694 Perl_block_start(pTHX_ int full)
2695 {
2696     dVAR;
2697     const int retval = PL_savestack_ix;
2698
2699     pad_block_start(full);
2700     SAVEHINTS();
2701     PL_hints &= ~HINT_BLOCK_SCOPE;
2702     SAVECOMPILEWARNINGS();
2703     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2704
2705     CALL_BLOCK_HOOKS(bhk_start, full);
2706
2707     return retval;
2708 }
2709
2710 OP*
2711 Perl_block_end(pTHX_ I32 floor, OP *seq)
2712 {
2713     dVAR;
2714     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2715     OP* retval = scalarseq(seq);
2716
2717     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2718
2719     LEAVE_SCOPE(floor);
2720     CopHINTS_set(&PL_compiling, PL_hints);
2721     if (needblockscope)
2722         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2723     pad_leavemy();
2724
2725     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2726
2727     return retval;
2728 }
2729
2730 /*
2731 =head1 Compile-time scope hooks
2732
2733 =for apidoc Aox||blockhook_register
2734
2735 Register a set of hooks to be called when the Perl lexical scope changes
2736 at compile time. See L<perlguts/"Compile-time scope hooks">.
2737
2738 =cut
2739 */
2740
2741 void
2742 Perl_blockhook_register(pTHX_ BHK *hk)
2743 {
2744     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2745
2746     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2747 }
2748
2749 STATIC OP *
2750 S_newDEFSVOP(pTHX)
2751 {
2752     dVAR;
2753     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2754     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2755         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2756     }
2757     else {
2758         OP * const o = newOP(OP_PADSV, 0);
2759         o->op_targ = offset;
2760         return o;
2761     }
2762 }
2763
2764 void
2765 Perl_newPROG(pTHX_ OP *o)
2766 {
2767     dVAR;
2768
2769     PERL_ARGS_ASSERT_NEWPROG;
2770
2771     if (PL_in_eval) {
2772         PERL_CONTEXT *cx;
2773         I32 i;
2774         if (PL_eval_root)
2775                 return;
2776         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2777                                ((PL_in_eval & EVAL_KEEPERR)
2778                                 ? OPf_SPECIAL : 0), o);
2779
2780         cx = &cxstack[cxstack_ix];
2781         assert(CxTYPE(cx) == CXt_EVAL);
2782
2783         if ((cx->blk_gimme & G_WANT) == G_VOID)
2784             scalarvoid(PL_eval_root);
2785         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2786             list(PL_eval_root);
2787         else
2788             scalar(PL_eval_root);
2789
2790         /* don't use LINKLIST, since PL_eval_root might indirect through
2791          * a rather expensive function call and LINKLIST evaluates its
2792          * argument more than once */
2793         PL_eval_start = op_linklist(PL_eval_root);
2794         PL_eval_root->op_private |= OPpREFCOUNTED;
2795         OpREFCNT_set(PL_eval_root, 1);
2796         PL_eval_root->op_next = 0;
2797         i = PL_savestack_ix;
2798         SAVEFREEOP(o);
2799         ENTER;
2800         CALL_PEEP(PL_eval_start);
2801         finalize_optree(PL_eval_root);
2802         LEAVE;
2803         PL_savestack_ix = i;
2804     }
2805     else {
2806         if (o->op_type == OP_STUB) {
2807             PL_comppad_name = 0;
2808             PL_compcv = 0;
2809             S_op_destroy(aTHX_ o);
2810             return;
2811         }
2812         PL_main_root = op_scope(sawparens(scalarvoid(o)));
2813         PL_curcop = &PL_compiling;
2814         PL_main_start = LINKLIST(PL_main_root);
2815         PL_main_root->op_private |= OPpREFCOUNTED;
2816         OpREFCNT_set(PL_main_root, 1);
2817         PL_main_root->op_next = 0;
2818         CALL_PEEP(PL_main_start);
2819         finalize_optree(PL_main_root);
2820         PL_compcv = 0;
2821
2822         /* Register with debugger */
2823         if (PERLDB_INTER) {
2824             CV * const cv = get_cvs("DB::postponed", 0);
2825             if (cv) {
2826                 dSP;
2827                 PUSHMARK(SP);
2828                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2829                 PUTBACK;
2830                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2831             }
2832         }
2833     }
2834 }
2835
2836 OP *
2837 Perl_localize(pTHX_ OP *o, I32 lex)
2838 {
2839     dVAR;
2840
2841     PERL_ARGS_ASSERT_LOCALIZE;
2842
2843     if (o->op_flags & OPf_PARENS)
2844 /* [perl #17376]: this appears to be premature, and results in code such as
2845    C< our(%x); > executing in list mode rather than void mode */
2846 #if 0
2847         list(o);
2848 #else
2849         NOOP;
2850 #endif
2851     else {
2852         if ( PL_parser->bufptr > PL_parser->oldbufptr
2853             && PL_parser->bufptr[-1] == ','
2854             && ckWARN(WARN_PARENTHESIS))
2855         {
2856             char *s = PL_parser->bufptr;
2857             bool sigil = FALSE;
2858
2859             /* some heuristics to detect a potential error */
2860             while (*s && (strchr(", \t\n", *s)))
2861                 s++;
2862
2863             while (1) {
2864                 if (*s && strchr("@$%*", *s) && *++s
2865                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2866                     s++;
2867                     sigil = TRUE;
2868                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2869                         s++;
2870                     while (*s && (strchr(", \t\n", *s)))
2871                         s++;
2872                 }
2873                 else
2874                     break;
2875             }
2876             if (sigil && (*s == ';' || *s == '=')) {
2877                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2878                                 "Parentheses missing around \"%s\" list",
2879                                 lex
2880                                     ? (PL_parser->in_my == KEY_our
2881                                         ? "our"
2882                                         : PL_parser->in_my == KEY_state
2883                                             ? "state"
2884                                             : "my")
2885                                     : "local");
2886             }
2887         }
2888     }
2889     if (lex)
2890         o = my(o);
2891     else
2892         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
2893     PL_parser->in_my = FALSE;
2894     PL_parser->in_my_stash = NULL;
2895     return o;
2896 }
2897
2898 OP *
2899 Perl_jmaybe(pTHX_ OP *o)
2900 {
2901     PERL_ARGS_ASSERT_JMAYBE;
2902
2903     if (o->op_type == OP_LIST) {
2904         OP * const o2
2905             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2906         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2907     }
2908     return o;
2909 }
2910
2911 PERL_STATIC_INLINE OP *
2912 S_op_std_init(pTHX_ OP *o)
2913 {
2914     I32 type = o->op_type;
2915
2916     PERL_ARGS_ASSERT_OP_STD_INIT;
2917
2918     if (PL_opargs[type] & OA_RETSCALAR)
2919         scalar(o);
2920     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2921         o->op_targ = pad_alloc(type, SVs_PADTMP);
2922
2923     return o;
2924 }
2925
2926 PERL_STATIC_INLINE OP *
2927 S_op_integerize(pTHX_ OP *o)
2928 {
2929     I32 type = o->op_type;
2930
2931     PERL_ARGS_ASSERT_OP_INTEGERIZE;
2932
2933     /* integerize op, unless it happens to be C<-foo>.
2934      * XXX should pp_i_negate() do magic string negation instead? */
2935     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2936         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2937              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2938     {
2939         dVAR;
2940         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2941     }
2942
2943     if (type == OP_NEGATE)
2944         /* XXX might want a ck_negate() for this */
2945         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2946
2947     return o;
2948 }
2949
2950 static OP *
2951 S_fold_constants(pTHX_ register OP *o)
2952 {
2953     dVAR;
2954     register OP * VOL curop;
2955     OP *newop;
2956     VOL I32 type = o->op_type;
2957     SV * VOL sv = NULL;
2958     int ret = 0;
2959     I32 oldscope;
2960     OP *old_next;
2961     SV * const oldwarnhook = PL_warnhook;
2962     SV * const olddiehook  = PL_diehook;
2963     COP not_compiling;
2964     dJMPENV;
2965
2966     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2967
2968     if (!(PL_opargs[type] & OA_FOLDCONST))
2969         goto nope;
2970
2971     switch (type) {
2972     case OP_UCFIRST:
2973     case OP_LCFIRST:
2974     case OP_UC:
2975     case OP_LC:
2976     case OP_SLT:
2977     case OP_SGT:
2978     case OP_SLE:
2979     case OP_SGE:
2980     case OP_SCMP:
2981     case OP_SPRINTF:
2982         /* XXX what about the numeric ops? */
2983         if (IN_LOCALE_COMPILETIME)
2984             goto nope;
2985         break;
2986     }
2987
2988     if (PL_parser && PL_parser->error_count)
2989         goto nope;              /* Don't try to run w/ errors */
2990
2991     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2992         const OPCODE type = curop->op_type;
2993         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2994             type != OP_LIST &&
2995             type != OP_SCALAR &&
2996             type != OP_NULL &&
2997             type != OP_PUSHMARK)
2998         {
2999             goto nope;
3000         }
3001     }
3002
3003     curop = LINKLIST(o);
3004     old_next = o->op_next;
3005     o->op_next = 0;
3006     PL_op = curop;
3007
3008     oldscope = PL_scopestack_ix;
3009     create_eval_scope(G_FAKINGEVAL);
3010
3011     /* Verify that we don't need to save it:  */
3012     assert(PL_curcop == &PL_compiling);
3013     StructCopy(&PL_compiling, &not_compiling, COP);
3014     PL_curcop = &not_compiling;
3015     /* The above ensures that we run with all the correct hints of the
3016        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3017     assert(IN_PERL_RUNTIME);
3018     PL_warnhook = PERL_WARNHOOK_FATAL;
3019     PL_diehook  = NULL;
3020     JMPENV_PUSH(ret);
3021
3022     switch (ret) {
3023     case 0:
3024         CALLRUNOPS(aTHX);
3025         sv = *(PL_stack_sp--);
3026         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3027 #ifdef PERL_MAD
3028             /* Can't simply swipe the SV from the pad, because that relies on
3029                the op being freed "real soon now". Under MAD, this doesn't
3030                happen (see the #ifdef below).  */
3031             sv = newSVsv(sv);
3032 #else
3033             pad_swipe(o->op_targ,  FALSE);
3034 #endif
3035         }
3036         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3037             SvREFCNT_inc_simple_void(sv);
3038             SvTEMP_off(sv);
3039         }
3040         break;
3041     case 3:
3042         /* Something tried to die.  Abandon constant folding.  */
3043         /* Pretend the error never happened.  */
3044         CLEAR_ERRSV();
3045         o->op_next = old_next;
3046         break;
3047     default:
3048         JMPENV_POP;
3049         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3050         PL_warnhook = oldwarnhook;
3051         PL_diehook  = olddiehook;
3052         /* XXX note that this croak may fail as we've already blown away
3053          * the stack - eg any nested evals */
3054         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3055     }
3056     JMPENV_POP;
3057     PL_warnhook = oldwarnhook;
3058     PL_diehook  = olddiehook;
3059     PL_curcop = &PL_compiling;
3060
3061     if (PL_scopestack_ix > oldscope)
3062         delete_eval_scope();
3063
3064     if (ret)
3065         goto nope;
3066
3067 #ifndef PERL_MAD
3068     op_free(o);
3069 #endif
3070     assert(sv);
3071     if (type == OP_RV2GV)
3072         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3073     else
3074         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3075     op_getmad(o,newop,'f');
3076     return newop;
3077
3078  nope:
3079     return o;
3080 }
3081
3082 static OP *
3083 S_gen_constant_list(pTHX_ register OP *o)
3084 {
3085     dVAR;
3086     register OP *curop;
3087     const I32 oldtmps_floor = PL_tmps_floor;
3088
3089     list(o);
3090     if (PL_parser && PL_parser->error_count)
3091         return o;               /* Don't attempt to run with errors */
3092
3093     PL_op = curop = LINKLIST(o);
3094     o->op_next = 0;
3095     CALL_PEEP(curop);
3096     Perl_pp_pushmark(aTHX);
3097     CALLRUNOPS(aTHX);
3098     PL_op = curop;
3099     assert (!(curop->op_flags & OPf_SPECIAL));
3100     assert(curop->op_type == OP_RANGE);
3101     Perl_pp_anonlist(aTHX);
3102     PL_tmps_floor = oldtmps_floor;
3103
3104     o->op_type = OP_RV2AV;
3105     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3106     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3107     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3108     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3109     curop = ((UNOP*)o)->op_first;
3110     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3111 #ifdef PERL_MAD
3112     op_getmad(curop,o,'O');
3113 #else
3114     op_free(curop);
3115 #endif
3116     LINKLIST(o);
3117     return list(o);
3118 }
3119
3120 OP *
3121 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3122 {
3123     dVAR;
3124     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3125     if (!o || o->op_type != OP_LIST)
3126         o = newLISTOP(OP_LIST, 0, o, NULL);
3127     else
3128         o->op_flags &= ~OPf_WANT;
3129
3130     if (!(PL_opargs[type] & OA_MARK))
3131         op_null(cLISTOPo->op_first);
3132     else {
3133         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3134         if (kid2 && kid2->op_type == OP_COREARGS) {
3135             op_null(cLISTOPo->op_first);
3136             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3137         }
3138     }
3139
3140     o->op_type = (OPCODE)type;
3141     o->op_ppaddr = PL_ppaddr[type];
3142     o->op_flags |= flags;
3143
3144     o = CHECKOP(type, o);
3145     if (o->op_type != (unsigned)type)
3146         return o;
3147
3148     return fold_constants(op_integerize(op_std_init(o)));
3149 }
3150
3151 /*
3152 =head1 Optree Manipulation Functions
3153 */
3154
3155 /* List constructors */
3156
3157 /*
3158 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3159
3160 Append an item to the list of ops contained directly within a list-type
3161 op, returning the lengthened list.  I<first> is the list-type op,
3162 and I<last> is the op to append to the list.  I<optype> specifies the
3163 intended opcode for the list.  If I<first> is not already a list of the
3164 right type, it will be upgraded into one.  If either I<first> or I<last>
3165 is null, the other is returned unchanged.
3166
3167 =cut
3168 */
3169
3170 OP *
3171 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3172 {
3173     if (!first)
3174         return last;
3175
3176     if (!last)
3177         return first;
3178
3179     if (first->op_type != (unsigned)type
3180         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3181     {
3182         return newLISTOP(type, 0, first, last);
3183     }
3184
3185     if (first->op_flags & OPf_KIDS)
3186         ((LISTOP*)first)->op_last->op_sibling = last;
3187     else {
3188         first->op_flags |= OPf_KIDS;
3189         ((LISTOP*)first)->op_first = last;
3190     }
3191     ((LISTOP*)first)->op_last = last;
3192     return first;
3193 }
3194
3195 /*
3196 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3197
3198 Concatenate the lists of ops contained directly within two list-type ops,
3199 returning the combined list.  I<first> and I<last> are the list-type ops
3200 to concatenate.  I<optype> specifies the intended opcode for the list.
3201 If either I<first> or I<last> is not already a list of the right type,
3202 it will be upgraded into one.  If either I<first> or I<last> is null,
3203 the other is returned unchanged.
3204
3205 =cut
3206 */
3207
3208 OP *
3209 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3210 {
3211     if (!first)
3212         return last;
3213
3214     if (!last)
3215         return first;
3216
3217     if (first->op_type != (unsigned)type)
3218         return op_prepend_elem(type, first, last);
3219
3220     if (last->op_type != (unsigned)type)
3221         return op_append_elem(type, first, last);
3222
3223     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3224     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3225     first->op_flags |= (last->op_flags & OPf_KIDS);
3226
3227 #ifdef PERL_MAD
3228     if (((LISTOP*)last)->op_first && first->op_madprop) {
3229         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3230         if (mp) {
3231             while (mp->mad_next)
3232                 mp = mp->mad_next;
3233             mp->mad_next = first->op_madprop;
3234         }
3235         else {
3236             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3237         }
3238     }
3239     first->op_madprop = last->op_madprop;
3240     last->op_madprop = 0;
3241 #endif
3242
3243     S_op_destroy(aTHX_ last);
3244
3245     return first;
3246 }
3247
3248 /*
3249 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3250
3251 Prepend an item to the list of ops contained directly within a list-type
3252 op, returning the lengthened list.  I<first> is the op to prepend to the
3253 list, and I<last> is the list-type op.  I<optype> specifies the intended
3254 opcode for the list.  If I<last> is not already a list of the right type,
3255 it will be upgraded into one.  If either I<first> or I<last> is null,
3256 the other is returned unchanged.
3257
3258 =cut
3259 */
3260
3261 OP *
3262 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3263 {
3264     if (!first)
3265         return last;
3266
3267     if (!last)
3268         return first;
3269
3270     if (last->op_type == (unsigned)type) {
3271         if (type == OP_LIST) {  /* already a PUSHMARK there */
3272             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3273             ((LISTOP*)last)->op_first->op_sibling = first;
3274             if (!(first->op_flags & OPf_PARENS))
3275                 last->op_flags &= ~OPf_PARENS;
3276         }
3277         else {
3278             if (!(last->op_flags & OPf_KIDS)) {
3279                 ((LISTOP*)last)->op_last = first;
3280                 last->op_flags |= OPf_KIDS;
3281             }
3282             first->op_sibling = ((LISTOP*)last)->op_first;
3283             ((LISTOP*)last)->op_first = first;
3284         }
3285         last->op_flags |= OPf_KIDS;
3286         return last;
3287     }
3288
3289     return newLISTOP(type, 0, first, last);
3290 }
3291
3292 /* Constructors */
3293
3294 #ifdef PERL_MAD
3295
3296 TOKEN *
3297 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3298 {
3299     TOKEN *tk;
3300     Newxz(tk, 1, TOKEN);
3301     tk->tk_type = (OPCODE)optype;
3302     tk->tk_type = 12345;
3303     tk->tk_lval = lval;
3304     tk->tk_mad = madprop;
3305     return tk;
3306 }
3307
3308 void
3309 Perl_token_free(pTHX_ TOKEN* tk)
3310 {
3311     PERL_ARGS_ASSERT_TOKEN_FREE;
3312
3313     if (tk->tk_type != 12345)
3314         return;
3315     mad_free(tk->tk_mad);
3316     Safefree(tk);
3317 }
3318
3319 void
3320 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3321 {
3322     MADPROP* mp;
3323     MADPROP* tm;
3324
3325     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3326
3327     if (tk->tk_type != 12345) {
3328         Perl_warner(aTHX_ packWARN(WARN_MISC),
3329              "Invalid TOKEN object ignored");
3330         return;
3331     }
3332     tm = tk->tk_mad;
3333     if (!tm)
3334         return;
3335
3336     /* faked up qw list? */
3337     if (slot == '(' &&
3338         tm->mad_type == MAD_SV &&
3339         SvPVX((SV *)tm->mad_val)[0] == 'q')
3340             slot = 'x';
3341
3342     if (o) {
3343         mp = o->op_madprop;
3344         if (mp) {
3345             for (;;) {
3346                 /* pretend constant fold didn't happen? */
3347                 if (mp->mad_key == 'f' &&
3348                     (o->op_type == OP_CONST ||
3349                      o->op_type == OP_GV) )
3350                 {
3351                     token_getmad(tk,(OP*)mp->mad_val,slot);
3352                     return;
3353                 }
3354                 if (!mp->mad_next)
3355                     break;
3356                 mp = mp->mad_next;
3357             }
3358             mp->mad_next = tm;
3359             mp = mp->mad_next;
3360         }
3361         else {
3362             o->op_madprop = tm;
3363             mp = o->op_madprop;
3364         }
3365         if (mp->mad_key == 'X')
3366             mp->mad_key = slot; /* just change the first one */
3367
3368         tk->tk_mad = 0;
3369     }
3370     else
3371         mad_free(tm);
3372     Safefree(tk);
3373 }
3374
3375 void
3376 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3377 {
3378     MADPROP* mp;
3379     if (!from)
3380         return;
3381     if (o) {
3382         mp = o->op_madprop;
3383         if (mp) {
3384             for (;;) {
3385                 /* pretend constant fold didn't happen? */
3386                 if (mp->mad_key == 'f' &&
3387                     (o->op_type == OP_CONST ||
3388                      o->op_type == OP_GV) )
3389                 {
3390                     op_getmad(from,(OP*)mp->mad_val,slot);
3391                     return;
3392                 }
3393                 if (!mp->mad_next)
3394                     break;
3395                 mp = mp->mad_next;
3396             }
3397             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3398         }
3399         else {
3400             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3401         }
3402     }
3403 }
3404
3405 void
3406 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3407 {
3408     MADPROP* mp;
3409     if (!from)
3410         return;
3411     if (o) {
3412         mp = o->op_madprop;
3413         if (mp) {
3414             for (;;) {
3415                 /* pretend constant fold didn't happen? */
3416                 if (mp->mad_key == 'f' &&
3417                     (o->op_type == OP_CONST ||
3418                      o->op_type == OP_GV) )
3419                 {
3420                     op_getmad(from,(OP*)mp->mad_val,slot);
3421                     return;
3422                 }
3423                 if (!mp->mad_next)
3424                     break;
3425                 mp = mp->mad_next;
3426             }
3427             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3428         }
3429         else {
3430             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3431         }
3432     }
3433     else {
3434         PerlIO_printf(PerlIO_stderr(),
3435                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3436         op_free(from);
3437     }
3438 }
3439
3440 void
3441 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3442 {
3443     MADPROP* tm;
3444     if (!mp || !o)
3445         return;
3446     if (slot)
3447         mp->mad_key = slot;
3448     tm = o->op_madprop;
3449     o->op_madprop = mp;
3450     for (;;) {
3451         if (!mp->mad_next)
3452             break;
3453         mp = mp->mad_next;
3454     }
3455     mp->mad_next = tm;
3456 }
3457
3458 void
3459 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3460 {
3461     if (!o)
3462         return;
3463     addmad(tm, &(o->op_madprop), slot);
3464 }
3465
3466 void
3467 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3468 {
3469     MADPROP* mp;
3470     if (!tm || !root)
3471         return;
3472     if (slot)
3473         tm->mad_key = slot;
3474     mp = *root;
3475     if (!mp) {
3476         *root = tm;
3477         return;
3478     }
3479     for (;;) {
3480         if (!mp->mad_next)
3481             break;
3482         mp = mp->mad_next;
3483     }
3484     mp->mad_next = tm;
3485 }
3486
3487 MADPROP *
3488 Perl_newMADsv(pTHX_ char key, SV* sv)
3489 {
3490     PERL_ARGS_ASSERT_NEWMADSV;
3491
3492     return newMADPROP(key, MAD_SV, sv, 0);
3493 }
3494
3495 MADPROP *
3496 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3497 {
3498     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3499     mp->mad_next = 0;
3500     mp->mad_key = key;
3501     mp->mad_vlen = vlen;
3502     mp->mad_type = type;
3503     mp->mad_val = val;
3504 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3505     return mp;
3506 }
3507
3508 void
3509 Perl_mad_free(pTHX_ MADPROP* mp)
3510 {
3511 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3512     if (!mp)
3513         return;
3514     if (mp->mad_next)
3515         mad_free(mp->mad_next);
3516 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3517         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3518     switch (mp->mad_type) {
3519     case MAD_NULL:
3520         break;
3521     case MAD_PV:
3522         Safefree((char*)mp->mad_val);
3523         break;
3524     case MAD_OP:
3525         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3526             op_free((OP*)mp->mad_val);
3527         break;
3528     case MAD_SV:
3529         sv_free(MUTABLE_SV(mp->mad_val));
3530         break;
3531     default:
3532         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3533         break;
3534     }
3535     PerlMemShared_free(mp);
3536 }
3537
3538 #endif
3539
3540 /*
3541 =head1 Optree construction
3542
3543 =for apidoc Am|OP *|newNULLLIST
3544
3545 Constructs, checks, and returns a new C<stub> op, which represents an
3546 empty list expression.
3547
3548 =cut
3549 */
3550
3551 OP *
3552 Perl_newNULLLIST(pTHX)
3553 {
3554     return newOP(OP_STUB, 0);
3555 }
3556
3557 static OP *
3558 S_force_list(pTHX_ OP *o)
3559 {
3560     if (!o || o->op_type != OP_LIST)
3561         o = newLISTOP(OP_LIST, 0, o, NULL);
3562     op_null(o);
3563     return o;
3564 }
3565
3566 /*
3567 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3568
3569 Constructs, checks, and returns an op of any list type.  I<type> is
3570 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3571 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3572 supply up to two ops to be direct children of the list op; they are
3573 consumed by this function and become part of the constructed op tree.
3574
3575 =cut
3576 */
3577
3578 OP *
3579 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3580 {
3581     dVAR;
3582     LISTOP *listop;
3583
3584     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3585
3586     NewOp(1101, listop, 1, LISTOP);
3587
3588     listop->op_type = (OPCODE)type;
3589     listop->op_ppaddr = PL_ppaddr[type];
3590     if (first || last)
3591         flags |= OPf_KIDS;
3592     listop->op_flags = (U8)flags;
3593
3594     if (!last && first)
3595         last = first;
3596     else if (!first && last)
3597         first = last;
3598     else if (first)
3599         first->op_sibling = last;
3600     listop->op_first = first;
3601     listop->op_last = last;
3602     if (type == OP_LIST) {
3603         OP* const pushop = newOP(OP_PUSHMARK, 0);
3604         pushop->op_sibling = first;
3605         listop->op_first = pushop;
3606         listop->op_flags |= OPf_KIDS;
3607         if (!last)
3608             listop->op_last = pushop;
3609     }
3610
3611     return CHECKOP(type, listop);
3612 }
3613
3614 /*
3615 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3616
3617 Constructs, checks, and returns an op of any base type (any type that
3618 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3619 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3620 of C<op_private>.
3621
3622 =cut
3623 */
3624
3625 OP *
3626 Perl_newOP(pTHX_ I32 type, I32 flags)
3627 {
3628     dVAR;
3629     OP *o;
3630
3631     if (type == -OP_ENTEREVAL) {
3632         type = OP_ENTEREVAL;
3633         flags |= OPpEVAL_BYTES<<8;
3634     }
3635
3636     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3637         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3638         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3639         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3640
3641     NewOp(1101, o, 1, OP);
3642     o->op_type = (OPCODE)type;
3643     o->op_ppaddr = PL_ppaddr[type];
3644     o->op_flags = (U8)flags;
3645     o->op_latefree = 0;
3646     o->op_latefreed = 0;
3647     o->op_attached = 0;
3648
3649     o->op_next = o;
3650     o->op_private = (U8)(0 | (flags >> 8));
3651     if (PL_opargs[type] & OA_RETSCALAR)
3652         scalar(o);
3653     if (PL_opargs[type] & OA_TARGET)
3654         o->op_targ = pad_alloc(type, SVs_PADTMP);
3655     return CHECKOP(type, o);
3656 }
3657
3658 /*
3659 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3660
3661 Constructs, checks, and returns an op of any unary type.  I<type> is
3662 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3663 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3664 bits, the eight bits of C<op_private>, except that the bit with value 1
3665 is automatically set.  I<first> supplies an optional op to be the direct
3666 child of the unary op; it is consumed by this function and become part
3667 of the constructed op tree.
3668
3669 =cut
3670 */
3671
3672 OP *
3673 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3674 {
3675     dVAR;
3676     UNOP *unop;
3677
3678     if (type == -OP_ENTEREVAL) {
3679         type = OP_ENTEREVAL;
3680         flags |= OPpEVAL_BYTES<<8;
3681     }
3682
3683     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3684         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3685         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3686         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3687         || type == OP_SASSIGN
3688         || type == OP_ENTERTRY
3689         || type == OP_NULL );
3690
3691     if (!first)
3692         first = newOP(OP_STUB, 0);
3693     if (PL_opargs[type] & OA_MARK)
3694         first = force_list(first);
3695
3696     NewOp(1101, unop, 1, UNOP);
3697     unop->op_type = (OPCODE)type;
3698     unop->op_ppaddr = PL_ppaddr[type];
3699     unop->op_first = first;
3700     unop->op_flags = (U8)(flags | OPf_KIDS);
3701     unop->op_private = (U8)(1 | (flags >> 8));
3702     unop = (UNOP*) CHECKOP(type, unop);
3703     if (unop->op_next)
3704         return (OP*)unop;
3705
3706     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3707 }
3708
3709 /*
3710 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3711
3712 Constructs, checks, and returns an op of any binary type.  I<type>
3713 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3714 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3715 the eight bits of C<op_private>, except that the bit with value 1 or
3716 2 is automatically set as required.  I<first> and I<last> supply up to
3717 two ops to be the direct children of the binary op; they are consumed
3718 by this function and become part of the constructed op tree.
3719
3720 =cut
3721 */
3722
3723 OP *
3724 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3725 {
3726     dVAR;
3727     BINOP *binop;
3728
3729     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3730         || type == OP_SASSIGN || type == OP_NULL );
3731
3732     NewOp(1101, binop, 1, BINOP);
3733
3734     if (!first)
3735         first = newOP(OP_NULL, 0);
3736
3737     binop->op_type = (OPCODE)type;
3738     binop->op_ppaddr = PL_ppaddr[type];
3739     binop->op_first = first;
3740     binop->op_flags = (U8)(flags | OPf_KIDS);
3741     if (!last) {
3742         last = first;
3743         binop->op_private = (U8)(1 | (flags >> 8));
3744     }
3745     else {
3746         binop->op_private = (U8)(2 | (flags >> 8));
3747         first->op_sibling = last;
3748     }
3749
3750     binop = (BINOP*)CHECKOP(type, binop);
3751     if (binop->op_next || binop->op_type != (OPCODE)type)
3752         return (OP*)binop;
3753
3754     binop->op_last = binop->op_first->op_sibling;
3755
3756     return fold_constants(op_integerize(op_std_init((OP *)binop)));
3757 }
3758
3759 static int uvcompare(const void *a, const void *b)
3760     __attribute__nonnull__(1)
3761     __attribute__nonnull__(2)
3762     __attribute__pure__;
3763 static int uvcompare(const void *a, const void *b)
3764 {
3765     if (*((const UV *)a) < (*(const UV *)b))
3766         return -1;
3767     if (*((const UV *)a) > (*(const UV *)b))
3768         return 1;
3769     if (*((const UV *)a+1) < (*(const UV *)b+1))
3770         return -1;
3771     if (*((const UV *)a+1) > (*(const UV *)b+1))
3772         return 1;
3773     return 0;
3774 }
3775
3776 static OP *
3777 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3778 {
3779     dVAR;
3780     SV * const tstr = ((SVOP*)expr)->op_sv;
3781     SV * const rstr =
3782 #ifdef PERL_MAD
3783                         (repl->op_type == OP_NULL)
3784                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3785 #endif
3786                               ((SVOP*)repl)->op_sv;
3787     STRLEN tlen;
3788     STRLEN rlen;
3789     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3790     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3791     register I32 i;
3792     register I32 j;
3793     I32 grows = 0;
3794     register short *tbl;
3795
3796     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3797     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3798     I32 del              = o->op_private & OPpTRANS_DELETE;
3799     SV* swash;
3800
3801     PERL_ARGS_ASSERT_PMTRANS;
3802
3803     PL_hints |= HINT_BLOCK_SCOPE;
3804
3805     if (SvUTF8(tstr))
3806         o->op_private |= OPpTRANS_FROM_UTF;
3807
3808     if (SvUTF8(rstr))
3809         o->op_private |= OPpTRANS_TO_UTF;
3810
3811     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3812         SV* const listsv = newSVpvs("# comment\n");
3813         SV* transv = NULL;
3814         const U8* tend = t + tlen;
3815         const U8* rend = r + rlen;
3816         STRLEN ulen;
3817         UV tfirst = 1;
3818         UV tlast = 0;
3819         IV tdiff;
3820         UV rfirst = 1;
3821         UV rlast = 0;
3822         IV rdiff;
3823         IV diff;
3824         I32 none = 0;
3825         U32 max = 0;
3826         I32 bits;
3827         I32 havefinal = 0;
3828         U32 final = 0;
3829         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3830         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3831         U8* tsave = NULL;
3832         U8* rsave = NULL;
3833         const U32 flags = UTF8_ALLOW_DEFAULT;
3834
3835         if (!from_utf) {
3836             STRLEN len = tlen;
3837             t = tsave = bytes_to_utf8(t, &len);
3838             tend = t + len;
3839         }
3840         if (!to_utf && rlen) {
3841             STRLEN len = rlen;
3842             r = rsave = bytes_to_utf8(r, &len);
3843             rend = r + len;
3844         }
3845
3846 /* There are several snags with this code on EBCDIC:
3847    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3848    2. scan_const() in toke.c has encoded chars in native encoding which makes
3849       ranges at least in EBCDIC 0..255 range the bottom odd.
3850 */
3851
3852         if (complement) {
3853             U8 tmpbuf[UTF8_MAXBYTES+1];
3854             UV *cp;
3855             UV nextmin = 0;
3856             Newx(cp, 2*tlen, UV);
3857             i = 0;
3858             transv = newSVpvs("");
3859             while (t < tend) {
3860                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3861                 t += ulen;
3862                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3863                     t++;
3864                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3865                     t += ulen;
3866                 }
3867                 else {
3868                  cp[2*i+1] = cp[2*i];
3869                 }
3870                 i++;
3871             }
3872             qsort(cp, i, 2*sizeof(UV), uvcompare);
3873             for (j = 0; j < i; j++) {
3874                 UV  val = cp[2*j];
3875                 diff = val - nextmin;
3876                 if (diff > 0) {
3877                     t = uvuni_to_utf8(tmpbuf,nextmin);
3878                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3879                     if (diff > 1) {
3880                         U8  range_mark = UTF_TO_NATIVE(0xff);
3881                         t = uvuni_to_utf8(tmpbuf, val - 1);
3882                         sv_catpvn(transv, (char *)&range_mark, 1);
3883                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3884                     }
3885                 }
3886                 val = cp[2*j+1];
3887                 if (val >= nextmin)
3888                     nextmin = val + 1;
3889             }
3890             t = uvuni_to_utf8(tmpbuf,nextmin);
3891             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3892             {
3893                 U8 range_mark = UTF_TO_NATIVE(0xff);
3894                 sv_catpvn(transv, (char *)&range_mark, 1);
3895             }
3896             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3897             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3898             t = (const U8*)SvPVX_const(transv);
3899             tlen = SvCUR(transv);
3900             tend = t + tlen;
3901             Safefree(cp);
3902         }
3903         else if (!rlen && !del) {
3904             r = t; rlen = tlen; rend = tend;
3905         }
3906         if (!squash) {
3907                 if ((!rlen && !del) || t == r ||
3908                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3909                 {
3910                     o->op_private |= OPpTRANS_IDENTICAL;
3911                 }
3912         }
3913
3914         while (t < tend || tfirst <= tlast) {
3915             /* see if we need more "t" chars */
3916             if (tfirst > tlast) {
3917                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3918                 t += ulen;
3919                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3920                     t++;
3921                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3922                     t += ulen;
3923                 }
3924                 else
3925                     tlast = tfirst;
3926             }
3927
3928             /* now see if we need more "r" chars */
3929             if (rfirst > rlast) {
3930                 if (r < rend) {
3931                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3932                     r += ulen;
3933                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3934                         r++;
3935                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3936                         r += ulen;
3937                     }
3938                     else
3939                         rlast = rfirst;
3940                 }
3941                 else {
3942                     if (!havefinal++)
3943                         final = rlast;
3944                     rfirst = rlast = 0xffffffff;
3945                 }
3946             }
3947
3948             /* now see which range will peter our first, if either. */
3949             tdiff = tlast - tfirst;
3950             rdiff = rlast - rfirst;
3951
3952             if (tdiff <= rdiff)
3953                 diff = tdiff;
3954             else
3955                 diff = rdiff;
3956
3957             if (rfirst == 0xffffffff) {
3958                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3959                 if (diff > 0)
3960                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3961                                    (long)tfirst, (long)tlast);
3962                 else
3963                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3964             }
3965             else {
3966                 if (diff > 0)
3967                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3968                                    (long)tfirst, (long)(tfirst + diff),
3969                                    (long)rfirst);
3970                 else
3971                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3972                                    (long)tfirst, (long)rfirst);
3973
3974                 if (rfirst + diff > max)
3975                     max = rfirst + diff;
3976                 if (!grows)
3977                     grows = (tfirst < rfirst &&
3978                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3979                 rfirst += diff + 1;
3980             }
3981             tfirst += diff + 1;
3982         }
3983
3984         none = ++max;
3985         if (del)
3986             del = ++max;
3987
3988         if (max > 0xffff)
3989             bits = 32;
3990         else if (max > 0xff)
3991             bits = 16;
3992         else
3993             bits = 8;
3994
3995         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3996 #ifdef USE_ITHREADS
3997         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3998         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3999         PAD_SETSV(cPADOPo->op_padix, swash);
4000         SvPADTMP_on(swash);
4001         SvREADONLY_on(swash);
4002 #else
4003         cSVOPo->op_sv = swash;
4004 #endif
4005         SvREFCNT_dec(listsv);
4006         SvREFCNT_dec(transv);
4007
4008         if (!del && havefinal && rlen)
4009             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4010                            newSVuv((UV)final), 0);
4011
4012         if (grows)
4013             o->op_private |= OPpTRANS_GROWS;
4014
4015         Safefree(tsave);
4016         Safefree(rsave);
4017
4018 #ifdef PERL_MAD
4019         op_getmad(expr,o,'e');
4020         op_getmad(repl,o,'r');
4021 #else
4022         op_free(expr);
4023         op_free(repl);
4024 #endif
4025         return o;
4026     }
4027
4028     tbl = (short*)PerlMemShared_calloc(
4029         (o->op_private & OPpTRANS_COMPLEMENT) &&
4030             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4031         sizeof(short));
4032     cPVOPo->op_pv = (char*)tbl;
4033     if (complement) {
4034         for (i = 0; i < (I32)tlen; i++)
4035             tbl[t[i]] = -1;
4036         for (i = 0, j = 0; i < 256; i++) {
4037             if (!tbl[i]) {
4038                 if (j >= (I32)rlen) {
4039                     if (del)
4040                         tbl[i] = -2;
4041                     else if (rlen)
4042                         tbl[i] = r[j-1];
4043                     else
4044                         tbl[i] = (short)i;
4045                 }
4046                 else {
4047                     if (i < 128 && r[j] >= 128)
4048                         grows = 1;
4049                     tbl[i] = r[j++];
4050                 }
4051             }
4052         }
4053         if (!del) {
4054             if (!rlen) {
4055                 j = rlen;
4056                 if (!squash)
4057                     o->op_private |= OPpTRANS_IDENTICAL;
4058             }
4059             else if (j >= (I32)rlen)
4060                 j = rlen - 1;
4061             else {
4062                 tbl =
4063                     (short *)
4064                     PerlMemShared_realloc(tbl,
4065                                           (0x101+rlen-j) * sizeof(short));
4066                 cPVOPo->op_pv = (char*)tbl;
4067             }
4068             tbl[0x100] = (short)(rlen - j);
4069             for (i=0; i < (I32)rlen - j; i++)
4070                 tbl[0x101+i] = r[j+i];
4071         }
4072     }
4073     else {
4074         if (!rlen && !del) {
4075             r = t; rlen = tlen;
4076             if (!squash)
4077                 o->op_private |= OPpTRANS_IDENTICAL;
4078         }
4079         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4080             o->op_private |= OPpTRANS_IDENTICAL;
4081         }
4082         for (i = 0; i < 256; i++)
4083             tbl[i] = -1;
4084         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4085             if (j >= (I32)rlen) {
4086                 if (del) {
4087                     if (tbl[t[i]] == -1)
4088                         tbl[t[i]] = -2;
4089                     continue;
4090                 }
4091                 --j;
4092             }
4093             if (tbl[t[i]] == -1) {
4094                 if (t[i] < 128 && r[j] >= 128)
4095                     grows = 1;
4096                 tbl[t[i]] = r[j];
4097             }
4098         }
4099     }
4100
4101     if(del && rlen == tlen) {
4102         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4103     } else if(rlen > tlen) {
4104         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4105     }
4106
4107     if (grows)
4108         o->op_private |= OPpTRANS_GROWS;
4109 #ifdef PERL_MAD
4110     op_getmad(expr,o,'e');
4111     op_getmad(repl,o,'r');
4112 #else
4113     op_free(expr);
4114     op_free(repl);
4115 #endif
4116
4117     return o;
4118 }
4119
4120 /*
4121 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4122
4123 Constructs, checks, and returns an op of any pattern matching type.
4124 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4125 and, shifted up eight bits, the eight bits of C<op_private>.
4126
4127 =cut
4128 */
4129
4130 OP *
4131 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4132 {
4133     dVAR;
4134     PMOP *pmop;
4135
4136     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4137
4138     NewOp(1101, pmop, 1, PMOP);
4139     pmop->op_type = (OPCODE)type;
4140     pmop->op_ppaddr = PL_ppaddr[type];
4141     pmop->op_flags = (U8)flags;
4142     pmop->op_private = (U8)(0 | (flags >> 8));
4143
4144     if (PL_hints & HINT_RE_TAINT)
4145         pmop->op_pmflags |= PMf_RETAINT;
4146     if (IN_LOCALE_COMPILETIME) {
4147         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4148     }
4149     else if ((! (PL_hints & HINT_BYTES))
4150                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4151              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4152     {
4153         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4154     }
4155     if (PL_hints & HINT_RE_FLAGS) {
4156         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4157          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4158         );
4159         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4160         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4161          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4162         );
4163         if (reflags && SvOK(reflags)) {
4164             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4165         }
4166     }
4167
4168
4169 #ifdef USE_ITHREADS
4170     assert(SvPOK(PL_regex_pad[0]));
4171     if (SvCUR(PL_regex_pad[0])) {
4172         /* Pop off the "packed" IV from the end.  */
4173         SV *const repointer_list = PL_regex_pad[0];
4174         const char *p = SvEND(repointer_list) - sizeof(IV);
4175         const IV offset = *((IV*)p);
4176
4177         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4178
4179         SvEND_set(repointer_list, p);
4180
4181         pmop->op_pmoffset = offset;
4182         /* This slot should be free, so assert this:  */
4183         assert(PL_regex_pad[offset] == &PL_sv_undef);
4184     } else {
4185         SV * const repointer = &PL_sv_undef;
4186         av_push(PL_regex_padav, repointer);
4187         pmop->op_pmoffset = av_len(PL_regex_padav);
4188         PL_regex_pad = AvARRAY(PL_regex_padav);
4189     }
4190 #endif
4191
4192     return CHECKOP(type, pmop);
4193 }
4194
4195 /* Given some sort of match op o, and an expression expr containing a
4196  * pattern, either compile expr into a regex and attach it to o (if it's
4197  * constant), or convert expr into a runtime regcomp op sequence (if it's
4198  * not)
4199  *
4200  * isreg indicates that the pattern is part of a regex construct, eg
4201  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4202  * split "pattern", which aren't. In the former case, expr will be a list
4203  * if the pattern contains more than one term (eg /a$b/) or if it contains
4204  * a replacement, ie s/// or tr///.
4205  */
4206
4207 OP *
4208 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4209 {
4210     dVAR;
4211     PMOP *pm;
4212     LOGOP *rcop;
4213     I32 repl_has_vars = 0;
4214     OP* repl = NULL;
4215     bool reglist;
4216
4217     PERL_ARGS_ASSERT_PMRUNTIME;
4218
4219     if (
4220         o->op_type == OP_SUBST
4221      || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4222     ) {
4223         /* last element in list is the replacement; pop it */
4224         OP* kid;
4225         repl = cLISTOPx(expr)->op_last;
4226         kid = cLISTOPx(expr)->op_first;
4227         while (kid->op_sibling != repl)
4228             kid = kid->op_sibling;
4229         kid->op_sibling = NULL;
4230         cLISTOPx(expr)->op_last = kid;
4231     }
4232
4233     if (isreg && expr->op_type == OP_LIST &&
4234         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4235     {
4236         /* convert single element list to element */
4237         OP* const oe = expr;
4238         expr = cLISTOPx(oe)->op_first->op_sibling;
4239         cLISTOPx(oe)->op_first->op_sibling = NULL;
4240         cLISTOPx(oe)->op_last = NULL;
4241         op_free(oe);
4242     }
4243
4244     if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4245         return pmtrans(o, expr, repl);
4246     }
4247
4248     reglist = isreg && expr->op_type == OP_LIST;
4249     if (reglist)
4250         op_null(expr);
4251
4252     PL_hints |= HINT_BLOCK_SCOPE;
4253     pm = (PMOP*)o;
4254
4255     if (expr->op_type == OP_CONST) {
4256         SV *pat = ((SVOP*)expr)->op_sv;
4257         U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4258
4259         if (o->op_flags & OPf_SPECIAL)
4260             pm_flags |= RXf_SPLIT;
4261
4262         if (DO_UTF8(pat)) {
4263             assert (SvUTF8(pat));
4264         } else if (SvUTF8(pat)) {
4265             /* Not doing UTF-8, despite what the SV says. Is this only if we're
4266                trapped in use 'bytes'?  */
4267             /* Make a copy of the octet sequence, but without the flag on, as
4268                the compiler now honours the SvUTF8 flag on pat.  */
4269             STRLEN len;
4270             const char *const p = SvPV(pat, len);
4271             pat = newSVpvn_flags(p, len, SVs_TEMP);
4272         }
4273
4274         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4275
4276 #ifdef PERL_MAD
4277         op_getmad(expr,(OP*)pm,'e');
4278 #else
4279         op_free(expr);
4280 #endif
4281     }
4282     else {
4283         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4284             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4285                             ? OP_REGCRESET
4286                             : OP_REGCMAYBE),0,expr);
4287
4288         NewOp(1101, rcop, 1, LOGOP);
4289         rcop->op_type = OP_REGCOMP;
4290         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4291         rcop->op_first = scalar(expr);
4292         rcop->op_flags |= OPf_KIDS
4293                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4294                             | (reglist ? OPf_STACKED : 0);
4295         rcop->op_private = 1;
4296         rcop->op_other = o;
4297         if (reglist)
4298             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4299
4300         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4301         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4302
4303         /* establish postfix order */
4304         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4305             LINKLIST(expr);
4306             rcop->op_next = expr;
4307             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4308         }
4309         else {
4310             rcop->op_next = LINKLIST(expr);
4311             expr->op_next = (OP*)rcop;
4312         }
4313
4314         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4315     }
4316
4317     if (repl) {
4318         OP *curop;
4319         if (pm->op_pmflags & PMf_EVAL) {
4320             curop = NULL;
4321             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4322                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4323         }
4324         else if (repl->op_type == OP_CONST)
4325             curop = repl;
4326         else {
4327             OP *lastop = NULL;
4328             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4329                 if (curop->op_type == OP_SCOPE
4330                         || curop->op_type == OP_LEAVE
4331                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4332                     if (curop->op_type == OP_GV) {
4333                         GV * const gv = cGVOPx_gv(curop);
4334                         repl_has_vars = 1;
4335                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4336                             break;
4337                     }
4338                     else if (curop->op_type == OP_RV2CV)
4339                         break;
4340                     else if (curop->op_type == OP_RV2SV ||
4341                              curop->op_type == OP_RV2AV ||
4342                              curop->op_type == OP_RV2HV ||
4343                              curop->op_type == OP_RV2GV) {
4344                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4345                             break;
4346                     }
4347                     else if (curop->op_type == OP_PADSV ||
4348                              curop->op_type == OP_PADAV ||
4349                              curop->op_type == OP_PADHV ||
4350                              curop->op_type == OP_PADANY)
4351                     {
4352                         repl_has_vars = 1;
4353                     }
4354                     else if (curop->op_type == OP_PUSHRE)
4355                         NOOP; /* Okay here, dangerous in newASSIGNOP */
4356                     else
4357                         break;
4358                 }
4359                 lastop = curop;
4360             }
4361         }
4362         if (curop == repl
4363             && !(repl_has_vars
4364                  && (!PM_GETRE(pm)
4365                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4366         {
4367             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4368             op_prepend_elem(o->op_type, scalar(repl), o);
4369         }
4370         else {
4371             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4372                 pm->op_pmflags |= PMf_MAYBE_CONST;
4373             }
4374             NewOp(1101, rcop, 1, LOGOP);
4375             rcop->op_type = OP_SUBSTCONT;
4376             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4377             rcop->op_first = scalar(repl);
4378             rcop->op_flags |= OPf_KIDS;
4379             rcop->op_private = 1;
4380             rcop->op_other = o;
4381
4382             /* establish postfix order */
4383             rcop->op_next = LINKLIST(repl);
4384             repl->op_next = (OP*)rcop;
4385
4386             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4387             assert(!(pm->op_pmflags & PMf_ONCE));
4388             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4389             rcop->op_next = 0;
4390         }
4391     }
4392
4393     return (OP*)pm;
4394 }
4395
4396 /*
4397 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4398
4399 Constructs, checks, and returns an op of any type that involves an
4400 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4401 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4402 takes ownership of one reference to it.
4403
4404 =cut
4405 */
4406
4407 OP *
4408 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4409 {
4410     dVAR;
4411     SVOP *svop;
4412
4413     PERL_ARGS_ASSERT_NEWSVOP;
4414
4415     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4416         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4417         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4418
4419     NewOp(1101, svop, 1, SVOP);
4420     svop->op_type = (OPCODE)type;
4421     svop->op_ppaddr = PL_ppaddr[type];
4422     svop->op_sv = sv;
4423     svop->op_next = (OP*)svop;
4424     svop->op_flags = (U8)flags;
4425     if (PL_opargs[type] & OA_RETSCALAR)
4426         scalar((OP*)svop);
4427     if (PL_opargs[type] & OA_TARGET)
4428         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4429     return CHECKOP(type, svop);
4430 }
4431
4432 #ifdef USE_ITHREADS
4433
4434 /*
4435 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4436
4437 Constructs, checks, and returns an op of any type that involves a
4438 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4439 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4440 is populated with I<sv>; this function takes ownership of one reference
4441 to it.
4442
4443 This function only exists if Perl has been compiled to use ithreads.
4444
4445 =cut
4446 */
4447
4448 OP *
4449 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4450 {
4451     dVAR;
4452     PADOP *padop;
4453
4454     PERL_ARGS_ASSERT_NEWPADOP;
4455
4456     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4457         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4458         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4459
4460     NewOp(1101, padop, 1, PADOP);
4461     padop->op_type = (OPCODE)type;
4462     padop->op_ppaddr = PL_ppaddr[type];
4463     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4464     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4465     PAD_SETSV(padop->op_padix, sv);
4466     assert(sv);
4467     SvPADTMP_on(sv);
4468     padop->op_next = (OP*)padop;
4469     padop->op_flags = (U8)flags;
4470     if (PL_opargs[type] & OA_RETSCALAR)
4471         scalar((OP*)padop);
4472     if (PL_opargs[type] & OA_TARGET)
4473         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4474     return CHECKOP(type, padop);
4475 }
4476
4477 #endif /* !USE_ITHREADS */
4478
4479 /*
4480 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4481
4482 Constructs, checks, and returns an op of any type that involves an
4483 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4484 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4485 reference; calling this function does not transfer ownership of any
4486 reference to it.
4487
4488 =cut
4489 */
4490
4491 OP *
4492 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4493 {
4494     dVAR;
4495
4496     PERL_ARGS_ASSERT_NEWGVOP;
4497
4498 #ifdef USE_ITHREADS
4499     GvIN_PAD_on(gv);
4500     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4501 #else
4502     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4503 #endif
4504 }
4505
4506 /*
4507 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4508
4509 Constructs, checks, and returns an op of any type that involves an
4510 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4511 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4512 must have been allocated using L</PerlMemShared_malloc>; the memory will
4513 be freed when the op is destroyed.
4514
4515 =cut
4516 */
4517
4518 OP *
4519 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4520 {
4521     dVAR;
4522     const bool utf8 = cBOOL(flags & SVf_UTF8);
4523     PVOP *pvop;
4524
4525     flags &= ~SVf_UTF8;
4526
4527     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4528         || type == OP_RUNCV
4529         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4530
4531     NewOp(1101, pvop, 1, PVOP);
4532     pvop->op_type = (OPCODE)type;
4533     pvop->op_ppaddr = PL_ppaddr[type];
4534     pvop->op_pv = pv;
4535     pvop->op_next = (OP*)pvop;
4536     pvop->op_flags = (U8)flags;
4537     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4538     if (PL_opargs[type] & OA_RETSCALAR)
4539         scalar((OP*)pvop);
4540     if (PL_opargs[type] & OA_TARGET)
4541         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4542     return CHECKOP(type, pvop);
4543 }
4544
4545 #ifdef PERL_MAD
4546 OP*
4547 #else
4548 void
4549 #endif
4550 Perl_package(pTHX_ OP *o)
4551 {
4552     dVAR;
4553     SV *const sv = cSVOPo->op_sv;
4554 #ifdef PERL_MAD
4555     OP *pegop;
4556 #endif
4557
4558     PERL_ARGS_ASSERT_PACKAGE;
4559
4560     SAVEGENERICSV(PL_curstash);
4561     save_item(PL_curstname);
4562
4563     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4564
4565     sv_setsv(PL_curstname, sv);
4566
4567     PL_hints |= HINT_BLOCK_SCOPE;
4568     PL_parser->copline = NOLINE;
4569     PL_parser->expect = XSTATE;
4570
4571 #ifndef PERL_MAD
4572     op_free(o);
4573 #else
4574     if (!PL_madskills) {
4575         op_free(o);
4576         return NULL;
4577     }
4578
4579     pegop = newOP(OP_NULL,0);
4580     op_getmad(o,pegop,'P');
4581     return pegop;
4582 #endif
4583 }
4584
4585 void
4586 Perl_package_version( pTHX_ OP *v )
4587 {
4588     dVAR;
4589     U32 savehints = PL_hints;
4590     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4591     PL_hints &= ~HINT_STRICT_VARS;
4592     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4593     PL_hints = savehints;
4594     op_free(v);
4595 }
4596
4597 #ifdef PERL_MAD
4598 OP*
4599 #else
4600 void
4601 #endif
4602 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4603 {
4604     dVAR;
4605     OP *pack;
4606     OP *imop;
4607     OP *veop;
4608 #ifdef PERL_MAD
4609     OP *pegop = newOP(OP_NULL,0);
4610 #endif
4611     SV *use_version = NULL;
4612
4613     PERL_ARGS_ASSERT_UTILIZE;
4614
4615     if (idop->op_type != OP_CONST)
4616         Perl_croak(aTHX_ "Module name must be constant");
4617
4618     if (PL_madskills)
4619         op_getmad(idop,pegop,'U');
4620
4621     veop = NULL;
4622
4623     if (version) {
4624         SV * const vesv = ((SVOP*)version)->op_sv;
4625
4626         if (PL_madskills)
4627             op_getmad(version,pegop,'V');
4628         if (!arg && !SvNIOKp(vesv)) {
4629             arg = version;
4630         }
4631         else {
4632             OP *pack;
4633             SV *meth;
4634
4635             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4636                 Perl_croak(aTHX_ "Version number must be a constant number");
4637
4638             /* Make copy of idop so we don't free it twice */
4639             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4640
4641             /* Fake up a method call to VERSION */
4642             meth = newSVpvs_share("VERSION");
4643             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4644                             op_append_elem(OP_LIST,
4645                                         op_prepend_elem(OP_LIST, pack, list(version)),
4646                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4647         }
4648     }
4649
4650     /* Fake up an import/unimport */
4651     if (arg && arg->op_type == OP_STUB) {
4652         if (PL_madskills)
4653             op_getmad(arg,pegop,'S');
4654         imop = arg;             /* no import on explicit () */
4655     }
4656     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4657         imop = NULL;            /* use 5.0; */
4658         if (aver)
4659             use_version = ((SVOP*)idop)->op_sv;
4660         else
4661             idop->op_private |= OPpCONST_NOVER;
4662     }
4663     else {
4664         SV *meth;
4665
4666         if (PL_madskills)
4667             op_getmad(arg,pegop,'A');
4668
4669         /* Make copy of idop so we don't free it twice */
4670         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4671
4672         /* Fake up a method call to import/unimport */
4673         meth = aver
4674             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4675         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4676                        op_append_elem(OP_LIST,
4677                                    op_prepend_elem(OP_LIST, pack, list(arg)),
4678                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4679     }
4680
4681     /* Fake up the BEGIN {}, which does its thing immediately. */
4682     newATTRSUB(floor,
4683         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4684         NULL,
4685         NULL,
4686         op_append_elem(OP_LINESEQ,
4687             op_append_elem(OP_LINESEQ,
4688                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4689                 newSTATEOP(0, NULL, veop)),
4690             newSTATEOP(0, NULL, imop) ));
4691
4692     if (use_version) {
4693         /* Enable the
4694          * feature bundle that corresponds to the required version. */
4695         use_version = sv_2mortal(new_version(use_version));
4696         S_enable_feature_bundle(aTHX_ use_version);
4697
4698         /* If a version >= 5.11.0 is requested, strictures are on by default! */
4699         if (vcmp(use_version,
4700                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4701             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4702                 PL_hints |= HINT_STRICT_REFS;
4703             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4704                 PL_hints |= HINT_STRICT_SUBS;
4705             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4706                 PL_hints |= HINT_STRICT_VARS;
4707         }
4708         /* otherwise they are off */
4709         else {
4710             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4711                 PL_hints &= ~HINT_STRICT_REFS;
4712             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4713                 PL_hints &= ~HINT_STRICT_SUBS;
4714             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4715                 PL_hints &= ~HINT_STRICT_VARS;
4716         }
4717     }
4718
4719     /* The "did you use incorrect case?" warning used to be here.
4720      * The problem is that on case-insensitive filesystems one
4721      * might get false positives for "use" (and "require"):
4722      * "use Strict" or "require CARP" will work.  This causes
4723      * portability problems for the script: in case-strict
4724      * filesystems the script will stop working.
4725      *
4726      * The "incorrect case" warning checked whether "use Foo"
4727      * imported "Foo" to your namespace, but that is wrong, too:
4728      * there is no requirement nor promise in the language that
4729      * a Foo.pm should or would contain anything in package "Foo".
4730      *
4731      * There is very little Configure-wise that can be done, either:
4732      * the case-sensitivity of the build filesystem of Perl does not
4733      * help in guessing the case-sensitivity of the runtime environment.
4734      */
4735
4736     PL_hints |= HINT_BLOCK_SCOPE;
4737     PL_parser->copline = NOLINE;
4738     PL_parser->expect = XSTATE;
4739     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4740     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4741         PL_cop_seqmax++;
4742
4743 #ifdef PERL_MAD
4744     if (!PL_madskills) {
4745         /* FIXME - don't allocate pegop if !PL_madskills */
4746         op_free(pegop);
4747         return NULL;
4748     }
4749     return pegop;
4750 #endif
4751 }
4752
4753 /*
4754 =head1 Embedding Functions
4755
4756 =for apidoc load_module
4757
4758 Loads the module whose name is pointed to by the string part of name.
4759 Note that the actual module name, not its filename, should be given.
4760 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4761 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4762 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4763 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4764 arguments can be used to specify arguments to the module's import()
4765 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4766 terminated with a final NULL pointer.  Note that this list can only
4767 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4768 Otherwise at least a single NULL pointer to designate the default
4769 import list is required.
4770
4771 The reference count for each specified C<SV*> parameter is decremented.
4772
4773 =cut */
4774
4775 void
4776 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4777 {
4778     va_list args;
4779
4780     PERL_ARGS_ASSERT_LOAD_MODULE;
4781
4782     va_start(args, ver);
4783     vload_module(flags, name, ver, &args);
4784     va_end(args);
4785 }
4786
4787 #ifdef PERL_IMPLICIT_CONTEXT
4788 void
4789 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4790 {
4791     dTHX;
4792     va_list args;
4793     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4794     va_start(args, ver);
4795     vload_module(flags, name, ver, &args);
4796     va_end(args);
4797 }
4798 #endif
4799
4800 void
4801 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4802 {
4803     dVAR;
4804     OP *veop, *imop;
4805     OP * const modname = newSVOP(OP_CONST, 0, name);
4806
4807     PERL_ARGS_ASSERT_VLOAD_MODULE;
4808
4809     modname->op_private |= OPpCONST_BARE;
4810     if (ver) {
4811         veop = newSVOP(OP_CONST, 0, ver);
4812     }
4813     else
4814         veop = NULL;
4815     if (flags & PERL_LOADMOD_NOIMPORT) {
4816         imop = sawparens(newNULLLIST());
4817     }
4818     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4819         imop = va_arg(*args, OP*);
4820     }
4821     else {
4822         SV *sv;
4823         imop = NULL;
4824         sv = va_arg(*args, SV*);
4825         while (sv) {
4826             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4827             sv = va_arg(*args, SV*);
4828         }
4829     }
4830
4831     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4832      * that it has a PL_parser to play with while doing that, and also
4833      * that it doesn't mess with any existing parser, by creating a tmp
4834      * new parser with lex_start(). This won't actually be used for much,
4835      * since pp_require() will create another parser for the real work. */
4836
4837     ENTER;
4838     SAVEVPTR(PL_curcop);
4839     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4840     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4841             veop, modname, imop);
4842     LEAVE;
4843 }
4844
4845 OP *
4846 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4847 {
4848     dVAR;
4849     OP *doop;
4850     GV *gv = NULL;
4851
4852     PERL_ARGS_ASSERT_DOFILE;
4853
4854     if (!force_builtin) {
4855         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4856         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4857             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4858             gv = gvp ? *gvp : NULL;
4859         }
4860     }
4861
4862     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4863         doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
4864                                op_append_elem(OP_LIST, term,
4865                                            scalar(newUNOP(OP_RV2CV, 0,
4866                                                           newGVOP(OP_GV, 0, gv)))));
4867     }
4868     else {
4869         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4870     }
4871     return doop;
4872 }
4873
4874 /*
4875 =head1 Optree construction
4876
4877 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4878
4879 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4880 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4881 be set automatically, and, shifted up eight bits, the eight bits of
4882 C<op_private>, except that the bit with value 1 or 2 is automatically
4883 set as required.  I<listval> and I<subscript> supply the parameters of
4884 the slice; they are consumed by this function and become part of the
4885 constructed op tree.
4886
4887 =cut
4888 */
4889
4890 OP *
4891 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4892 {
4893     return newBINOP(OP_LSLICE, flags,
4894             list(force_list(subscript)),
4895             list(force_list(listval)) );
4896 }
4897
4898 STATIC I32
4899 S_is_list_assignment(pTHX_ register const OP *o)
4900 {
4901     unsigned type;
4902     U8 flags;
4903
4904     if (!o)
4905         return TRUE;
4906
4907     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))