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) && UTF8_IS_START(name[1])) ||
 432           (name[1] == '_' && (*name == '$' || len > 2))))
 433     {
 434         /* name[2] is true if strlen(name) > 2  */
 435         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 436             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 437                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 438                               PL_parser->in_my == KEY_state ? "state" : "my"));
 439         } else {
 440             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 441                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 442         }
 443     }
 444
 445     /* allocate a spare slot and store the name in that slot */
 446
 447     off = pad_add_name_pvn(name, len,
 448                        (is_our ? padadd_OUR :
 449                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 450                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 451                     PL_parser->in_my_stash,
 452                     (is_our
 453                         /* $_ is always in main::, even with our */
 454                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 455                         : NULL
 456                     )
 457     );
 458     /* anon sub prototypes contains state vars should always be cloned,
 459      * otherwise the state var would be shared between anon subs */
 460
 461     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 462         CvCLONE_on(PL_compcv);
 463
 464     return off;
 465 }
 466
 467 /* free the body of an op without examining its contents.
 468  * Always use this rather than FreeOp directly */
 469
 470 static void
 471 S_op_destroy(pTHX_ OP *o)
 472 {
 473     if (o->op_latefree) {
 474         o->op_latefreed = 1;
 475         return;
 476     }
 477     FreeOp(o);
 478 }
 479
 480 #ifdef USE_ITHREADS
 481 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 482 #else
 483 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 484 #endif
 485
 486 /* Destructor */
 487
 488 void
 489 Perl_op_free(pTHX_ OP *o)
 490 {
 491     dVAR;
 492     OPCODE type;
 493
 494     if (!o)
 495         return;
 496     if (o->op_latefreed) {
 497         if (o->op_latefree)
 498             return;
 499         goto do_free;
 500     }
 501
 502     type = o->op_type;
 503     if (o->op_private & OPpREFCOUNTED) {
 504         switch (type) {
 505         case OP_LEAVESUB:
 506         case OP_LEAVESUBLV:
 507         case OP_LEAVEEVAL:
 508         case OP_LEAVE:
 509         case OP_SCOPE:
 510         case OP_LEAVEWRITE:
 511             {
 512             PADOFFSET refcnt;
 513             OP_REFCNT_LOCK;
 514             refcnt = OpREFCNT_dec(o);
 515             OP_REFCNT_UNLOCK;
 516             if (refcnt) {
 517                 /* Need to find and remove any pattern match ops from the list
 518                    we maintain for reset().  */
 519                 find_and_forget_pmops(o);
 520                 return;
 521             }
 522             }
 523             break;
 524         default:
 525             break;
 526         }
 527     }
 528
 529     /* Call the op_free hook if it has been set. Do it now so that it's called
 530      * at the right time for refcounted ops, but still before all of the kids
 531      * are freed. */
 532     CALL_OPFREEHOOK(o);
 533
 534     if (o->op_flags & OPf_KIDS) {
 535         register OP *kid, *nextkid;
 536         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 537             nextkid = kid->op_sibling; /* Get before next freeing kid */
 538             op_free(kid);
 539         }
 540     }
 541
 542 #ifdef PERL_DEBUG_READONLY_OPS
 543     Slab_to_rw(o);
 544 #endif
 545
 546     /* COP* is not cleared by op_clear() so that we may track line
 547      * numbers etc even after null() */
 548     if (type == OP_NEXTSTATE || type == OP_DBSTATE
 549             || (type == OP_NULL /* the COP might have been null'ed */
 550                 && ((OPCODE)o->op_targ == OP_NEXTSTATE
 551                     || (OPCODE)o->op_targ == OP_DBSTATE))) {
 552         cop_free((COP*)o);
 553     }
 554
 555     if (type == OP_NULL)
 556         type = (OPCODE)o->op_targ;
 557
 558     op_clear(o);
 559     if (o->op_latefree) {
 560         o->op_latefreed = 1;
 561         return;
 562     }
 563   do_free:
 564     FreeOp(o);
 565 #ifdef DEBUG_LEAKING_SCALARS
 566     if (PL_op == o)
 567         PL_op = NULL;
 568 #endif
 569 }
 570
 571 void
 572 Perl_op_clear(pTHX_ OP *o)
 573 {
 574
 575     dVAR;
 576
 577     PERL_ARGS_ASSERT_OP_CLEAR;
 578
 579 #ifdef PERL_MAD
 580     mad_free(o->op_madprop);
 581     o->op_madprop = 0;
 582 #endif
 583
 584  retry:
 585     switch (o->op_type) {
 586     case OP_NULL:       /* Was holding old type, if any. */
 587         if (PL_madskills && o->op_targ != OP_NULL) {
 588             o->op_type = (Optype)o->op_targ;
 589             o->op_targ = 0;
 590             goto retry;
 591         }
 592     case OP_ENTERTRY:
 593     case OP_ENTEREVAL:  /* Was holding hints. */
 594         o->op_targ = 0;
 595         break;
 596     default:
 597         if (!(o->op_flags & OPf_REF)
 598             || (PL_check[o->op_type] != Perl_ck_ftst))
 599             break;
 600         /* FALL THROUGH */
 601     case OP_GVSV:
 602     case OP_GV:
 603     case OP_AELEMFAST:
 604         {
 605             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 606 #ifdef USE_ITHREADS
 607                         && PL_curpad
 608 #endif
 609                         ? cGVOPo_gv : NULL;
 610             /* It's possible during global destruction that the GV is freed
 611                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 612                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 613                will trigger an assertion failure, because the entry to sv_clear
 614                checks that the scalar is not already freed.  A check of for
 615                !SvIS_FREED(gv) turns out to be invalid, because during global
 616                destruction the reference count can be forced down to zero
 617                (with SVf_BREAK set).  In which case raising to 1 and then
 618                dropping to 0 triggers cleanup before it should happen.  I
 619                *think* that this might actually be a general, systematic,
 620                weakness of the whole idea of SVf_BREAK, in that code *is*
 621                allowed to raise and lower references during global destruction,
 622                so any *valid* code that happens to do this during global
 623                destruction might well trigger premature cleanup.  */
 624             bool still_valid = gv && SvREFCNT(gv);
 625
 626             if (still_valid)
 627                 SvREFCNT_inc_simple_void(gv);
 628 #ifdef USE_ITHREADS
 629             if (cPADOPo->op_padix > 0) {
 630                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 631                  * may still exist on the pad */
 632                 pad_swipe(cPADOPo->op_padix, TRUE);
 633                 cPADOPo->op_padix = 0;
 634             }
 635 #else
 636             SvREFCNT_dec(cSVOPo->op_sv);
 637             cSVOPo->op_sv = NULL;
 638 #endif
 639             if (still_valid) {
 640                 int try_downgrade = SvREFCNT(gv) == 2;
 641                 SvREFCNT_dec(gv);
 642                 if (try_downgrade)
 643                     gv_try_downgrade(gv);
 644             }
 645         }
 646         break;
 647     case OP_METHOD_NAMED:
 648     case OP_CONST:
 649     case OP_HINTSEVAL:
 650         SvREFCNT_dec(cSVOPo->op_sv);
 651         cSVOPo->op_sv = NULL;
 652 #ifdef USE_ITHREADS
 653         /** Bug #15654
 654           Even if op_clear does a pad_free for the target of the op,
 655           pad_free doesn't actually remove the sv that exists in the pad;
 656           instead it lives on. This results in that it could be reused as
 657           a target later on when the pad was reallocated.
 658         **/
 659         if(o->op_targ) {
 660           pad_swipe(o->op_targ,1);
 661           o->op_targ = 0;
 662         }
 663 #endif
 664         break;
 665     case OP_GOTO:
 666     case OP_NEXT:
 667     case OP_LAST:
 668     case OP_REDO:
 669         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 670             break;
 671         /* FALL THROUGH */
 672     case OP_TRANS:
 673     case OP_TRANSR:
 674         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 675 #ifdef USE_ITHREADS
 676             if (cPADOPo->op_padix > 0) {
 677                 pad_swipe(cPADOPo->op_padix, TRUE);
 678                 cPADOPo->op_padix = 0;
 679             }
 680 #else
 681             SvREFCNT_dec(cSVOPo->op_sv);
 682             cSVOPo->op_sv = NULL;
 683 #endif
 684         }
 685         else {
 686             PerlMemShared_free(cPVOPo->op_pv);
 687             cPVOPo->op_pv = NULL;
 688         }
 689         break;
 690     case OP_SUBST:
 691         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 692         goto clear_pmop;
 693     case OP_PUSHRE:
 694 #ifdef USE_ITHREADS
 695         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 696             /* No GvIN_PAD_off here, because other references may still
 697              * exist on the pad */
 698             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 699         }
 700 #else
 701         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 702 #endif
 703         /* FALL THROUGH */
 704     case OP_MATCH:
 705     case OP_QR:
 706 clear_pmop:
 707         forget_pmop(cPMOPo, 1);
 708         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 709         /* we use the same protection as the "SAFE" version of the PM_ macros
 710          * here since sv_clean_all might release some PMOPs
 711          * after PL_regex_padav has been cleared
 712          * and the clearing of PL_regex_padav needs to
 713          * happen before sv_clean_all
 714          */
 715 #ifdef USE_ITHREADS
 716         if(PL_regex_pad) {        /* We could be in destruction */
 717             const IV offset = (cPMOPo)->op_pmoffset;
 718             ReREFCNT_dec(PM_GETRE(cPMOPo));
 719             PL_regex_pad[offset] = &PL_sv_undef;
 720             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 721                            sizeof(offset));
 722         }
 723 #else
 724         ReREFCNT_dec(PM_GETRE(cPMOPo));
 725         PM_SETRE(cPMOPo, NULL);
 726 #endif
 727
 728         break;
 729     }
 730
 731     if (o->op_targ > 0) {
 732         pad_free(o->op_targ);
 733         o->op_targ = 0;
 734     }
 735 }
 736
 737 STATIC void
 738 S_cop_free(pTHX_ COP* cop)
 739 {
 740     PERL_ARGS_ASSERT_COP_FREE;
 741
 742     CopFILE_free(cop);
 743     CopSTASH_free(cop);
 744     if (! specialWARN(cop->cop_warnings))
 745         PerlMemShared_free(cop->cop_warnings);
 746     cophh_free(CopHINTHASH_get(cop));
 747 }
 748
 749 STATIC void
 750 S_forget_pmop(pTHX_ PMOP *const o
 751 #ifdef USE_ITHREADS
 752               , U32 flags
 753 #endif
 754               )
 755 {
 756     HV * const pmstash = PmopSTASH(o);
 757
 758     PERL_ARGS_ASSERT_FORGET_PMOP;
 759
 760     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 761         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 762         if (mg) {
 763             PMOP **const array = (PMOP**) mg->mg_ptr;
 764             U32 count = mg->mg_len / sizeof(PMOP**);
 765             U32 i = count;
 766
 767             while (i--) {
 768                 if (array[i] == o) {
 769                     /* Found it. Move the entry at the end to overwrite it.  */
 770                     array[i] = array[--count];
 771                     mg->mg_len = count * sizeof(PMOP**);
 772                     /* Could realloc smaller at this point always, but probably
 773                        not worth it. Probably worth free()ing if we're the
 774                        last.  */
 775                     if(!count) {
 776                         Safefree(mg->mg_ptr);
 777                         mg->mg_ptr = NULL;
 778                     }
 779                     break;
 780                 }
 781             }
 782         }
 783     }
 784     if (PL_curpm == o)
 785         PL_curpm = NULL;
 786 #ifdef USE_ITHREADS
 787     if (flags)
 788         PmopSTASH_free(o);
 789 #endif
 790 }
 791
 792 STATIC void
 793 S_find_and_forget_pmops(pTHX_ OP *o)
 794 {
 795     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 796
 797     if (o->op_flags & OPf_KIDS) {
 798         OP *kid = cUNOPo->op_first;
 799         while (kid) {
 800             switch (kid->op_type) {
 801             case OP_SUBST:
 802             case OP_PUSHRE:
 803             case OP_MATCH:
 804             case OP_QR:
 805                 forget_pmop((PMOP*)kid, 0);
 806             }
 807             find_and_forget_pmops(kid);
 808             kid = kid->op_sibling;
 809         }
 810     }
 811 }
 812
 813 void
 814 Perl_op_null(pTHX_ OP *o)
 815 {
 816     dVAR;
 817
 818     PERL_ARGS_ASSERT_OP_NULL;
 819
 820     if (o->op_type == OP_NULL)
 821         return;
 822     if (!PL_madskills)
 823         op_clear(o);
 824     o->op_targ = o->op_type;
 825     o->op_type = OP_NULL;
 826     o->op_ppaddr = PL_ppaddr[OP_NULL];
 827 }
 828
 829 void
 830 Perl_op_refcnt_lock(pTHX)
 831 {
 832     dVAR;
 833     PERL_UNUSED_CONTEXT;
 834     OP_REFCNT_LOCK;
 835 }
 836
 837 void
 838 Perl_op_refcnt_unlock(pTHX)
 839 {
 840     dVAR;
 841     PERL_UNUSED_CONTEXT;
 842     OP_REFCNT_UNLOCK;
 843 }
 844
 845 /* Contextualizers */
 846
 847 /*
 848 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
 849
 850 Applies a syntactic context to an op tree representing an expression.
 851 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
 852 or C<G_VOID> to specify the context to apply.  The modified op tree
 853 is returned.
 854
 855 =cut
 856 */
 857
 858 OP *
 859 Perl_op_contextualize(pTHX_ OP *o, I32 context)
 860 {
 861     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
 862     switch (context) {
 863         case G_SCALAR: return scalar(o);
 864         case G_ARRAY:  return list(o);
 865         case G_VOID:   return scalarvoid(o);
 866         default:
 867             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
 868                        (long) context);
 869             return o;
 870     }
 871 }
 872
 873 /*
 874 =head1 Optree Manipulation Functions
 875
 876 =for apidoc Am|OP*|op_linklist|OP *o
 877 This function is the implementation of the L</LINKLIST> macro. It should
 878 not be called directly.
 879
 880 =cut
 881 */
 882
 883 OP *
 884 Perl_op_linklist(pTHX_ OP *o)
 885 {
 886     OP *first;
 887
 888     PERL_ARGS_ASSERT_OP_LINKLIST;
 889
 890     if (o->op_next)
 891         return o->op_next;
 892
 893     /* establish postfix order */
 894     first = cUNOPo->op_first;
 895     if (first) {
 896         register OP *kid;
 897         o->op_next = LINKLIST(first);
 898         kid = first;
 899         for (;;) {
 900             if (kid->op_sibling) {
 901                 kid->op_next = LINKLIST(kid->op_sibling);
 902                 kid = kid->op_sibling;
 903             } else {
 904                 kid->op_next = o;
 905                 break;
 906             }
 907         }
 908     }
 909     else
 910         o->op_next = o;
 911
 912     return o->op_next;
 913 }
 914
 915 static OP *
 916 S_scalarkids(pTHX_ OP *o)
 917 {
 918     if (o && o->op_flags & OPf_KIDS) {
 919         OP *kid;
 920         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 921             scalar(kid);
 922     }
 923     return o;
 924 }
 925
 926 STATIC OP *
 927 S_scalarboolean(pTHX_ OP *o)
 928 {
 929     dVAR;
 930
 931     PERL_ARGS_ASSERT_SCALARBOOLEAN;
 932
 933     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
 934      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
 935         if (ckWARN(WARN_SYNTAX)) {
 936             const line_t oldline = CopLINE(PL_curcop);
 937
 938             if (PL_parser && PL_parser->copline != NOLINE)
 939                 CopLINE_set(PL_curcop, PL_parser->copline);
 940             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 941             CopLINE_set(PL_curcop, oldline);
 942         }
 943     }
 944     return scalar(o);
 945 }
 946
 947 OP *
 948 Perl_scalar(pTHX_ OP *o)
 949 {
 950     dVAR;
 951     OP *kid;
 952
 953     /* assumes no premature commitment */
 954     if (!o || (PL_parser && PL_parser->error_count)
 955          || (o->op_flags & OPf_WANT)
 956          || o->op_type == OP_RETURN)
 957     {
 958         return o;
 959     }
 960
 961     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 962
 963     switch (o->op_type) {
 964     case OP_REPEAT:
 965         scalar(cBINOPo->op_first);
 966         break;
 967     case OP_OR:
 968     case OP_AND:
 969     case OP_COND_EXPR:
 970         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 971             scalar(kid);
 972         break;
 973         /* FALL THROUGH */
 974     case OP_SPLIT:
 975     case OP_MATCH:
 976     case OP_QR:
 977     case OP_SUBST:
 978     case OP_NULL:
 979     default:
 980         if (o->op_flags & OPf_KIDS) {
 981             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 982                 scalar(kid);
 983         }
 984         break;
 985     case OP_LEAVE:
 986     case OP_LEAVETRY:
 987         kid = cLISTOPo->op_first;
 988         scalar(kid);
 989         kid = kid->op_sibling;
 990     do_kids:
 991         while (kid) {
 992             OP *sib = kid->op_sibling;
 993             if (sib && kid->op_type != OP_LEAVEWHEN)
 994                 scalarvoid(kid);
 995             else
 996                 scalar(kid);
 997             kid = sib;
 998         }
 999         PL_curcop = &PL_compiling;
1000         break;
1001     case OP_SCOPE:
1002     case OP_LINESEQ:
1003     case OP_LIST:
1004         kid = cLISTOPo->op_first;
1005         goto do_kids;
1006     case OP_SORT:
1007         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1008         break;
1009     }
1010     return o;
1011 }
1012
1013 OP *
1014 Perl_scalarvoid(pTHX_ OP *o)
1015 {
1016     dVAR;
1017     OP *kid;
1018     const char* useless = NULL;
1019     U32 useless_is_utf8 = 0;
1020     SV* sv;
1021     U8 want;
1022
1023     PERL_ARGS_ASSERT_SCALARVOID;
1024
1025     /* trailing mad null ops don't count as "there" for void processing */
1026     if (PL_madskills &&
1027         o->op_type != OP_NULL &&
1028         o->op_sibling &&
1029         o->op_sibling->op_type == OP_NULL)
1030     {
1031         OP *sib;
1032         for (sib = o->op_sibling;
1033                 sib && sib->op_type == OP_NULL;
1034                 sib = sib->op_sibling) ;
1035
1036         if (!sib)
1037             return o;
1038     }
1039
1040     if (o->op_type == OP_NEXTSTATE
1041         || o->op_type == OP_DBSTATE
1042         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043                                       || o->op_targ == OP_DBSTATE)))
1044         PL_curcop = (COP*)o;            /* for warning below */
1045
1046     /* assumes no premature commitment */
1047     want = o->op_flags & OPf_WANT;
1048     if ((want && want != OPf_WANT_SCALAR)
1049          || (PL_parser && PL_parser->error_count)
1050          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1051     {
1052         return o;
1053     }
1054
1055     if ((o->op_private & OPpTARGET_MY)
1056         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1057     {
1058         return scalar(o);                       /* As if inside SASSIGN */
1059     }
1060
1061     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1062
1063     switch (o->op_type) {
1064     default:
1065         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1066             break;
1067         /* FALL THROUGH */
1068     case OP_REPEAT:
1069         if (o->op_flags & OPf_STACKED)
1070             break;
1071         goto func_ops;
1072     case OP_SUBSTR:
1073         if (o->op_private == 4)
1074             break;
1075         /* FALL THROUGH */
1076     case OP_GVSV:
1077     case OP_WANTARRAY:
1078     case OP_GV:
1079     case OP_SMARTMATCH:
1080     case OP_PADSV:
1081     case OP_PADAV:
1082     case OP_PADHV:
1083     case OP_PADANY:
1084     case OP_AV2ARYLEN:
1085     case OP_REF:
1086     case OP_REFGEN:
1087     case OP_SREFGEN:
1088     case OP_DEFINED:
1089     case OP_HEX:
1090     case OP_OCT:
1091     case OP_LENGTH:
1092     case OP_VEC:
1093     case OP_INDEX:
1094     case OP_RINDEX:
1095     case OP_SPRINTF:
1096     case OP_AELEM:
1097     case OP_AELEMFAST:
1098     case OP_AELEMFAST_LEX:
1099     case OP_ASLICE:
1100     case OP_HELEM:
1101     case OP_HSLICE:
1102     case OP_UNPACK:
1103     case OP_PACK:
1104     case OP_JOIN:
1105     case OP_LSLICE:
1106     case OP_ANONLIST:
1107     case OP_ANONHASH:
1108     case OP_SORT:
1109     case OP_REVERSE:
1110     case OP_RANGE:
1111     case OP_FLIP:
1112     case OP_FLOP:
1113     case OP_CALLER:
1114     case OP_FILENO:
1115     case OP_EOF:
1116     case OP_TELL:
1117     case OP_GETSOCKNAME:
1118     case OP_GETPEERNAME:
1119     case OP_READLINK:
1120     case OP_TELLDIR:
1121     case OP_GETPPID:
1122     case OP_GETPGRP:
1123     case OP_GETPRIORITY:
1124     case OP_TIME:
1125     case OP_TMS:
1126     case OP_LOCALTIME:
1127     case OP_GMTIME:
1128     case OP_GHBYNAME:
1129     case OP_GHBYADDR:
1130     case OP_GHOSTENT:
1131     case OP_GNBYNAME:
1132     case OP_GNBYADDR:
1133     case OP_GNETENT:
1134     case OP_GPBYNAME:
1135     case OP_GPBYNUMBER:
1136     case OP_GPROTOENT:
1137     case OP_GSBYNAME:
1138     case OP_GSBYPORT:
1139     case OP_GSERVENT:
1140     case OP_GPWNAM:
1141     case OP_GPWUID:
1142     case OP_GGRNAM:
1143     case OP_GGRGID:
1144     case OP_GETLOGIN:
1145     case OP_PROTOTYPE:
1146     case OP_RUNCV:
1147       func_ops:
1148         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1149             /* Otherwise it's "Useless use of grep iterator" */
1150             useless = OP_DESC(o);
1151         break;
1152
1153     case OP_SPLIT:
1154         kid = cLISTOPo->op_first;
1155         if (kid && kid->op_type == OP_PUSHRE
1156 #ifdef USE_ITHREADS
1157                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1158 #else
1159                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1160 #endif
1161             useless = OP_DESC(o);
1162         break;
1163
1164     case OP_NOT:
1165        kid = cUNOPo->op_first;
1166        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1167            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1168                 goto func_ops;
1169        }
1170        useless = "negative pattern binding (!~)";
1171        break;
1172
1173     case OP_SUBST:
1174         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1175             useless = "non-destructive substitution (s///r)";
1176         break;
1177
1178     case OP_TRANSR:
1179         useless = "non-destructive transliteration (tr///r)";
1180         break;
1181
1182     case OP_RV2GV:
1183     case OP_RV2SV:
1184     case OP_RV2AV:
1185     case OP_RV2HV:
1186         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1187                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1188             useless = "a variable";
1189         break;
1190
1191     case OP_CONST:
1192         sv = cSVOPo_sv;
1193         if (cSVOPo->op_private & OPpCONST_STRICT)
1194             no_bareword_allowed(o);
1195         else {
1196             if (ckWARN(WARN_VOID)) {
1197                 /* don't warn on optimised away booleans, eg
1198                  * use constant Foo, 5; Foo || print; */
1199                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1200                     useless = NULL;
1201                 /* the constants 0 and 1 are permitted as they are
1202                    conventionally used as dummies in constructs like
1203                         1 while some_condition_with_side_effects;  */
1204                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1205                     useless = NULL;
1206                 else if (SvPOK(sv)) {
1207                   /* perl4's way of mixing documentation and code
1208                      (before the invention of POD) was based on a
1209                      trick to mix nroff and perl code. The trick was
1210                      built upon these three nroff macros being used in
1211                      void context. The pink camel has the details in
1212                      the script wrapman near page 319. */
1213                     const char * const maybe_macro = SvPVX_const(sv);
1214                     if (strnEQ(maybe_macro, "di", 2) ||
1215                         strnEQ(maybe_macro, "ds", 2) ||
1216                         strnEQ(maybe_macro, "ig", 2))
1217                             useless = NULL;
1218                     else {
1219                         SV * const dsv = newSVpvs("");
1220                         SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1221                                     "a constant (%s)",
1222                                     pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1223                                             PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1224                         SvREFCNT_dec(dsv);
1225                         useless = SvPV_nolen(msv);
1226                         useless_is_utf8 = SvUTF8(msv);
1227                     }
1228                 }
1229                 else if (SvOK(sv)) {
1230                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1231                                 "a constant (%"SVf")", sv));
1232                     useless = SvPV_nolen(msv);
1233                 }
1234                 else
1235                     useless = "a constant (undef)";
1236             }
1237         }
1238         op_null(o);             /* don't execute or even remember it */
1239         break;
1240
1241     case OP_POSTINC:
1242         o->op_type = OP_PREINC;         /* pre-increment is faster */
1243         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1244         break;
1245
1246     case OP_POSTDEC:
1247         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1248         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1249         break;
1250
1251     case OP_I_POSTINC:
1252         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1253         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1254         break;
1255
1256     case OP_I_POSTDEC:
1257         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1258         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1259         break;
1260
1261     case OP_SASSIGN: {
1262         OP *rv2gv;
1263         UNOP *refgen, *rv2cv;
1264         LISTOP *exlist;
1265
1266         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1267             break;
1268
1269         rv2gv = ((BINOP *)o)->op_last;
1270         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1271             break;
1272
1273         refgen = (UNOP *)((BINOP *)o)->op_first;
1274
1275         if (!refgen || refgen->op_type != OP_REFGEN)
1276             break;
1277
1278         exlist = (LISTOP *)refgen->op_first;
1279         if (!exlist || exlist->op_type != OP_NULL
1280             || exlist->op_targ != OP_LIST)
1281             break;
1282
1283         if (exlist->op_first->op_type != OP_PUSHMARK)
1284             break;
1285
1286         rv2cv = (UNOP*)exlist->op_last;
1287
1288         if (rv2cv->op_type != OP_RV2CV)
1289             break;
1290
1291         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1292         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1293         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1294
1295         o->op_private |= OPpASSIGN_CV_TO_GV;
1296         rv2gv->op_private |= OPpDONT_INIT_GV;
1297         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1298
1299         break;
1300     }
1301
1302     case OP_AASSIGN: {
1303         inplace_aassign(o);
1304         break;
1305     }
1306
1307     case OP_OR:
1308     case OP_AND:
1309         kid = cLOGOPo->op_first;
1310         if (kid->op_type == OP_NOT
1311             && (kid->op_flags & OPf_KIDS)
1312             && !PL_madskills) {
1313             if (o->op_type == OP_AND) {
1314                 o->op_type = OP_OR;
1315                 o->op_ppaddr = PL_ppaddr[OP_OR];
1316             } else {
1317                 o->op_type = OP_AND;
1318                 o->op_ppaddr = PL_ppaddr[OP_AND];
1319             }
1320             op_null(kid);
1321         }
1322
1323     case OP_DOR:
1324     case OP_COND_EXPR:
1325     case OP_ENTERGIVEN:
1326     case OP_ENTERWHEN:
1327         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1328             scalarvoid(kid);
1329         break;
1330
1331     case OP_NULL:
1332         if (o->op_flags & OPf_STACKED)
1333             break;
1334         /* FALL THROUGH */
1335     case OP_NEXTSTATE:
1336     case OP_DBSTATE:
1337     case OP_ENTERTRY:
1338     case OP_ENTER:
1339         if (!(o->op_flags & OPf_KIDS))
1340             break;
1341         /* FALL THROUGH */
1342     case OP_SCOPE:
1343     case OP_LEAVE:
1344     case OP_LEAVETRY:
1345     case OP_LEAVELOOP:
1346     case OP_LINESEQ:
1347     case OP_LIST:
1348     case OP_LEAVEGIVEN:
1349     case OP_LEAVEWHEN:
1350         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1351             scalarvoid(kid);
1352         break;
1353     case OP_ENTEREVAL:
1354         scalarkids(o);
1355         break;
1356     case OP_SCALAR:
1357         return scalar(o);
1358     }
1359     if (useless)
1360        Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1361                        newSVpvn_flags(useless, strlen(useless),
1362                             SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1363     return o;
1364 }
1365
1366 static OP *
1367 S_listkids(pTHX_ OP *o)
1368 {
1369     if (o && o->op_flags & OPf_KIDS) {
1370         OP *kid;
1371         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1372             list(kid);
1373     }
1374     return o;
1375 }
1376
1377 OP *
1378 Perl_list(pTHX_ OP *o)
1379 {
1380     dVAR;
1381     OP *kid;
1382
1383     /* assumes no premature commitment */
1384     if (!o || (o->op_flags & OPf_WANT)
1385          || (PL_parser && PL_parser->error_count)
1386          || o->op_type == OP_RETURN)
1387     {
1388         return o;
1389     }
1390
1391     if ((o->op_private & OPpTARGET_MY)
1392         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1393     {
1394         return o;                               /* As if inside SASSIGN */
1395     }
1396
1397     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1398
1399     switch (o->op_type) {
1400     case OP_FLOP:
1401     case OP_REPEAT:
1402         list(cBINOPo->op_first);
1403         break;
1404     case OP_OR:
1405     case OP_AND:
1406     case OP_COND_EXPR:
1407         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1408             list(kid);
1409         break;
1410     default:
1411     case OP_MATCH:
1412     case OP_QR:
1413     case OP_SUBST:
1414     case OP_NULL:
1415         if (!(o->op_flags & OPf_KIDS))
1416             break;
1417         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1418             list(cBINOPo->op_first);
1419             return gen_constant_list(o);
1420         }
1421     case OP_LIST:
1422         listkids(o);
1423         break;
1424     case OP_LEAVE:
1425     case OP_LEAVETRY:
1426         kid = cLISTOPo->op_first;
1427         list(kid);
1428         kid = kid->op_sibling;
1429     do_kids:
1430         while (kid) {
1431             OP *sib = kid->op_sibling;
1432             if (sib && kid->op_type != OP_LEAVEWHEN)
1433                 scalarvoid(kid);
1434             else
1435                 list(kid);
1436             kid = sib;
1437         }
1438         PL_curcop = &PL_compiling;
1439         break;
1440     case OP_SCOPE:
1441     case OP_LINESEQ:
1442         kid = cLISTOPo->op_first;
1443         goto do_kids;
1444     }
1445     return o;
1446 }
1447
1448 static OP *
1449 S_scalarseq(pTHX_ OP *o)
1450 {
1451     dVAR;
1452     if (o) {
1453         const OPCODE type = o->op_type;
1454
1455         if (type == OP_LINESEQ || type == OP_SCOPE ||
1456             type == OP_LEAVE || type == OP_LEAVETRY)
1457         {
1458             OP *kid;
1459             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1460                 if (kid->op_sibling) {
1461                     scalarvoid(kid);
1462                 }
1463             }
1464             PL_curcop = &PL_compiling;
1465         }
1466         o->op_flags &= ~OPf_PARENS;
1467         if (PL_hints & HINT_BLOCK_SCOPE)
1468             o->op_flags |= OPf_PARENS;
1469     }
1470     else
1471         o = newOP(OP_STUB, 0);
1472     return o;
1473 }
1474
1475 STATIC OP *
1476 S_modkids(pTHX_ OP *o, I32 type)
1477 {
1478     if (o && o->op_flags & OPf_KIDS) {
1479         OP *kid;
1480         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1481             op_lvalue(kid, type);
1482     }
1483     return o;
1484 }
1485
1486 /*
1487 =for apidoc finalize_optree
1488
1489 This function finalizes the optree. Should be called directly after
1490 the complete optree is built. It does some additional
1491 checking which can't be done in the normal ck_xxx functions and makes
1492 the tree thread-safe.
1493
1494 =cut
1495 */
1496 void
1497 Perl_finalize_optree(pTHX_ OP* o)
1498 {
1499     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1500
1501     ENTER;
1502     SAVEVPTR(PL_curcop);
1503
1504     finalize_op(o);
1505
1506     LEAVE;
1507 }
1508
1509 STATIC void
1510 S_finalize_op(pTHX_ OP* o)
1511 {
1512     PERL_ARGS_ASSERT_FINALIZE_OP;
1513
1514 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1515     {
1516         /* Make sure mad ops are also thread-safe */
1517         MADPROP *mp = o->op_madprop;
1518         while (mp) {
1519             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1520                 OP *prop_op = (OP *) mp->mad_val;
1521                 /* We only need "Relocate sv to the pad for thread safety.", but this
1522                    easiest way to make sure it traverses everything */
1523                 if (prop_op->op_type == OP_CONST)
1524                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1525                 finalize_op(prop_op);
1526             }
1527             mp = mp->mad_next;
1528         }
1529     }
1530 #endif
1531
1532     switch (o->op_type) {
1533     case OP_NEXTSTATE:
1534     case OP_DBSTATE:
1535         PL_curcop = ((COP*)o);          /* for warnings */
1536         break;
1537     case OP_EXEC:
1538         if ( o->op_sibling
1539             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1540             && ckWARN(WARN_SYNTAX))
1541             {
1542                 if (o->op_sibling->op_sibling) {
1543                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1544                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1545                         const line_t oldline = CopLINE(PL_curcop);
1546                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1547                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1548                             "Statement unlikely to be reached");
1549                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1550                             "\t(Maybe you meant system() when you said exec()?)\n");
1551                         CopLINE_set(PL_curcop, oldline);
1552                     }
1553                 }
1554             }
1555         break;
1556
1557     case OP_GV:
1558         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1559             GV * const gv = cGVOPo_gv;
1560             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1561                 /* XXX could check prototype here instead of just carping */
1562                 SV * const sv = sv_newmortal();
1563                 gv_efullname3(sv, gv, NULL);
1564                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1565                     "%"SVf"() called too early to check prototype",
1566                     SVfARG(sv));
1567             }
1568         }
1569         break;
1570
1571     case OP_CONST:
1572         if (cSVOPo->op_private & OPpCONST_STRICT)
1573             no_bareword_allowed(o);
1574         /* FALLTHROUGH */
1575 #ifdef USE_ITHREADS
1576     case OP_HINTSEVAL:
1577     case OP_METHOD_NAMED:
1578         /* Relocate sv to the pad for thread safety.
1579          * Despite being a "constant", the SV is written to,
1580          * for reference counts, sv_upgrade() etc. */
1581         if (cSVOPo->op_sv) {
1582             const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1583             if (o->op_type != OP_METHOD_NAMED &&
1584                 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1585             {
1586                 /* If op_sv is already a PADTMP/MY then it is being used by
1587                  * some pad, so make a copy. */
1588                 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1589                 SvREADONLY_on(PAD_SVl(ix));
1590                 SvREFCNT_dec(cSVOPo->op_sv);
1591             }
1592             else if (o->op_type != OP_METHOD_NAMED
1593                 && cSVOPo->op_sv == &PL_sv_undef) {
1594                 /* PL_sv_undef is hack - it's unsafe to store it in the
1595                    AV that is the pad, because av_fetch treats values of
1596                    PL_sv_undef as a "free" AV entry and will merrily
1597                    replace them with a new SV, causing pad_alloc to think
1598                    that this pad slot is free. (When, clearly, it is not)
1599                 */
1600                 SvOK_off(PAD_SVl(ix));
1601                 SvPADTMP_on(PAD_SVl(ix));
1602                 SvREADONLY_on(PAD_SVl(ix));
1603             }
1604             else {
1605                 SvREFCNT_dec(PAD_SVl(ix));
1606                 SvPADTMP_on(cSVOPo->op_sv);
1607                 PAD_SETSV(ix, cSVOPo->op_sv);
1608                 /* XXX I don't know how this isn't readonly already. */
1609                 SvREADONLY_on(PAD_SVl(ix));
1610             }
1611             cSVOPo->op_sv = NULL;
1612             o->op_targ = ix;
1613         }
1614 #endif
1615         break;
1616
1617     case OP_HELEM: {
1618         UNOP *rop;
1619         SV *lexname;
1620         GV **fields;
1621         SV **svp, *sv;
1622         const char *key = NULL;
1623         STRLEN keylen;
1624
1625         if (((BINOP*)o)->op_last->op_type != OP_CONST)
1626             break;
1627
1628         /* Make the CONST have a shared SV */
1629         svp = cSVOPx_svp(((BINOP*)o)->op_last);
1630         if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1631             && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1632             key = SvPV_const(sv, keylen);
1633             lexname = newSVpvn_share(key,
1634                 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1635                 0);
1636             SvREFCNT_dec(sv);
1637             *svp = lexname;
1638         }
1639
1640         if ((o->op_private & (OPpLVAL_INTRO)))
1641             break;
1642
1643         rop = (UNOP*)((BINOP*)o)->op_first;
1644         if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1645             break;
1646         lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1647         if (!SvPAD_TYPED(lexname))
1648             break;
1649         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1650         if (!fields || !GvHV(*fields))
1651             break;
1652         key = SvPV_const(*svp, keylen);
1653         if (!hv_fetch(GvHV(*fields), key,
1654                 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1655             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1656                            "in variable %"SVf" of type %"HEKf,
1657                       SVfARG(*svp), SVfARG(lexname),
1658                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1659         }
1660         break;
1661     }
1662
1663     case OP_HSLICE: {
1664         UNOP *rop;
1665         SV *lexname;
1666         GV **fields;
1667         SV **svp;
1668         const char *key;
1669         STRLEN keylen;
1670         SVOP *first_key_op, *key_op;
1671
1672         if ((o->op_private & (OPpLVAL_INTRO))
1673             /* I bet there's always a pushmark... */
1674             || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1675             /* hmmm, no optimization if list contains only one key. */
1676             break;
1677         rop = (UNOP*)((LISTOP*)o)->op_last;
1678         if (rop->op_type != OP_RV2HV)
1679             break;
1680         if (rop->op_first->op_type == OP_PADSV)
1681             /* @$hash{qw(keys here)} */
1682             rop = (UNOP*)rop->op_first;
1683         else {
1684             /* @{$hash}{qw(keys here)} */
1685             if (rop->op_first->op_type == OP_SCOPE
1686                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1687                 {
1688                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1689                 }
1690             else
1691                 break;
1692         }
1693
1694         lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1695         if (!SvPAD_TYPED(lexname))
1696             break;
1697         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1698         if (!fields || !GvHV(*fields))
1699             break;
1700         /* Again guessing that the pushmark can be jumped over.... */
1701         first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1702             ->op_first->op_sibling;
1703         for (key_op = first_key_op; key_op;
1704              key_op = (SVOP*)key_op->op_sibling) {
1705             if (key_op->op_type != OP_CONST)
1706                 continue;
1707             svp = cSVOPx_svp(key_op);
1708             key = SvPV_const(*svp, keylen);
1709             if (!hv_fetch(GvHV(*fields), key,
1710                     SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1711                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1712                            "in variable %"SVf" of type %"HEKf,
1713                       SVfARG(*svp), SVfARG(lexname),
1714                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1715             }
1716         }
1717         break;
1718     }
1719     case OP_SUBST: {
1720         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1721             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1722         break;
1723     }
1724     default:
1725         break;
1726     }
1727
1728     if (o->op_flags & OPf_KIDS) {
1729         OP *kid;
1730         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1731             finalize_op(kid);
1732     }
1733 }
1734
1735 /*
1736 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1737
1738 Propagate lvalue ("modifiable") context to an op and its children.
1739 I<type> represents the context type, roughly based on the type of op that
1740 would do the modifying, although C<local()> is represented by OP_NULL,
1741 because it has no op type of its own (it is signalled by a flag on
1742 the lvalue op).
1743
1744 This function detects things that can't be modified, such as C<$x+1>, and
1745 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1746 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1747
1748 It also flags things that need to behave specially in an lvalue context,
1749 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1750
1751 =cut
1752 */
1753
1754 OP *
1755 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1756 {
1757     dVAR;
1758     OP *kid;
1759     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1760     int localize = -1;
1761
1762     if (!o || (PL_parser && PL_parser->error_count))
1763         return o;
1764
1765     if ((o->op_private & OPpTARGET_MY)
1766         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1767     {
1768         return o;
1769     }
1770
1771     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1772
1773     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1774
1775     switch (o->op_type) {
1776     case OP_UNDEF:
1777         localize = 0;
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
2027     /* [20011101.069] File test operators interpret OPf_REF to mean that
2028        their argument is a filehandle; thus \stat(".") should not set
2029        it. AMS 20011102 */
2030     if (type == OP_REFGEN &&
2031         PL_check[o->op_type] == Perl_ck_ftst)
2032         return o;
2033
2034     if (type != OP_LEAVESUBLV)
2035         o->op_flags |= OPf_MOD;
2036
2037     if (type == OP_AASSIGN || type == OP_SASSIGN)
2038         o->op_flags |= OPf_SPECIAL|OPf_REF;
2039     else if (!type) { /* local() */
2040         switch (localize) {
2041         case 1:
2042             o->op_private |= OPpLVAL_INTRO;
2043             o->op_flags &= ~OPf_SPECIAL;
2044             PL_hints |= HINT_BLOCK_SCOPE;
2045             break;
2046         case 0:
2047             break;
2048         case -1:
2049             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2050                            "Useless localization of %s", OP_DESC(o));
2051         }
2052     }
2053     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2054              && type != OP_LEAVESUBLV)
2055         o->op_flags |= OPf_REF;
2056     return o;
2057 }
2058
2059 STATIC bool
2060 S_scalar_mod_type(const OP *o, I32 type)
2061 {
2062     assert(o || type != OP_SASSIGN);
2063
2064     switch (type) {
2065     case OP_SASSIGN:
2066         if (o->op_type == OP_RV2GV)
2067             return FALSE;
2068         /* FALL THROUGH */
2069     case OP_PREINC:
2070     case OP_PREDEC:
2071     case OP_POSTINC:
2072     case OP_POSTDEC:
2073     case OP_I_PREINC:
2074     case OP_I_PREDEC:
2075     case OP_I_POSTINC:
2076     case OP_I_POSTDEC:
2077     case OP_POW:
2078     case OP_MULTIPLY:
2079     case OP_DIVIDE:
2080     case OP_MODULO:
2081     case OP_REPEAT:
2082     case OP_ADD:
2083     case OP_SUBTRACT:
2084     case OP_I_MULTIPLY:
2085     case OP_I_DIVIDE:
2086     case OP_I_MODULO:
2087     case OP_I_ADD:
2088     case OP_I_SUBTRACT:
2089     case OP_LEFT_SHIFT:
2090     case OP_RIGHT_SHIFT:
2091     case OP_BIT_AND:
2092     case OP_BIT_XOR:
2093     case OP_BIT_OR:
2094     case OP_CONCAT:
2095     case OP_SUBST:
2096     case OP_TRANS:
2097     case OP_TRANSR:
2098     case OP_READ:
2099     case OP_SYSREAD:
2100     case OP_RECV:
2101     case OP_ANDASSIGN:
2102     case OP_ORASSIGN:
2103     case OP_DORASSIGN:
2104         return TRUE;
2105     default:
2106         return FALSE;
2107     }
2108 }
2109
2110 STATIC bool
2111 S_is_handle_constructor(const OP *o, I32 numargs)
2112 {
2113     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2114
2115     switch (o->op_type) {
2116     case OP_PIPE_OP:
2117     case OP_SOCKPAIR:
2118         if (numargs == 2)
2119             return TRUE;
2120         /* FALL THROUGH */
2121     case OP_SYSOPEN:
2122     case OP_OPEN:
2123     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2124     case OP_SOCKET:
2125     case OP_OPEN_DIR:
2126     case OP_ACCEPT:
2127         if (numargs == 1)
2128             return TRUE;
2129         /* FALLTHROUGH */
2130     default:
2131         return FALSE;
2132     }
2133 }
2134
2135 static OP *
2136 S_refkids(pTHX_ OP *o, I32 type)
2137 {
2138     if (o && o->op_flags & OPf_KIDS) {
2139         OP *kid;
2140         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2141             ref(kid, type);
2142     }
2143     return o;
2144 }
2145
2146 OP *
2147 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2148 {
2149     dVAR;
2150     OP *kid;
2151
2152     PERL_ARGS_ASSERT_DOREF;
2153
2154     if (!o || (PL_parser && PL_parser->error_count))
2155         return o;
2156
2157     switch (o->op_type) {
2158     case OP_ENTERSUB:
2159         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2160             !(o->op_flags & OPf_STACKED)) {
2161             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2162             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2163             assert(cUNOPo->op_first->op_type == OP_NULL);
2164             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2165             o->op_flags |= OPf_SPECIAL;
2166             o->op_private &= ~1;
2167         }
2168         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2169             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2170                               : type == OP_RV2HV ? OPpDEREF_HV
2171                               : OPpDEREF_SV);
2172             o->op_flags |= OPf_MOD;
2173         }
2174
2175         break;
2176
2177     case OP_COND_EXPR:
2178         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2179             doref(kid, type, set_op_ref);
2180         break;
2181     case OP_RV2SV:
2182         if (type == OP_DEFINED)
2183             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2184         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2185         /* FALL THROUGH */
2186     case OP_PADSV:
2187         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2188             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2189                               : type == OP_RV2HV ? OPpDEREF_HV
2190                               : OPpDEREF_SV);
2191             o->op_flags |= OPf_MOD;
2192         }
2193         break;
2194
2195     case OP_RV2AV:
2196     case OP_RV2HV:
2197         if (set_op_ref)
2198             o->op_flags |= OPf_REF;
2199         /* FALL THROUGH */
2200     case OP_RV2GV:
2201         if (type == OP_DEFINED)
2202             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2203         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2204         break;
2205
2206     case OP_PADAV:
2207     case OP_PADHV:
2208         if (set_op_ref)
2209             o->op_flags |= OPf_REF;
2210         break;
2211
2212     case OP_SCALAR:
2213     case OP_NULL:
2214         if (!(o->op_flags & OPf_KIDS))
2215             break;
2216         doref(cBINOPo->op_first, type, set_op_ref);
2217         break;
2218     case OP_AELEM:
2219     case OP_HELEM:
2220         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2221         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2222             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2223                               : type == OP_RV2HV ? OPpDEREF_HV
2224                               : OPpDEREF_SV);
2225             o->op_flags |= OPf_MOD;
2226         }
2227         break;
2228
2229     case OP_SCOPE:
2230     case OP_LEAVE:
2231         set_op_ref = FALSE;
2232         /* FALL THROUGH */
2233     case OP_ENTER:
2234     case OP_LIST:
2235         if (!(o->op_flags & OPf_KIDS))
2236             break;
2237         doref(cLISTOPo->op_last, type, set_op_ref);
2238         break;
2239     default:
2240         break;
2241     }
2242     return scalar(o);
2243
2244 }
2245
2246 STATIC OP *
2247 S_dup_attrlist(pTHX_ OP *o)
2248 {
2249     dVAR;
2250     OP *rop;
2251
2252     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2253
2254     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2255      * where the first kid is OP_PUSHMARK and the remaining ones
2256      * are OP_CONST.  We need to push the OP_CONST values.
2257      */
2258     if (o->op_type == OP_CONST)
2259         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2260 #ifdef PERL_MAD
2261     else if (o->op_type == OP_NULL)
2262         rop = NULL;
2263 #endif
2264     else {
2265         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2266         rop = NULL;
2267         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2268             if (o->op_type == OP_CONST)
2269                 rop = op_append_elem(OP_LIST, rop,
2270                                   newSVOP(OP_CONST, o->op_flags,
2271                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2272         }
2273     }
2274     return rop;
2275 }
2276
2277 STATIC void
2278 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2279 {
2280     dVAR;
2281     SV *stashsv;
2282
2283     PERL_ARGS_ASSERT_APPLY_ATTRS;
2284
2285     /* fake up C<use attributes $pkg,$rv,@attrs> */
2286     ENTER;              /* need to protect against side-effects of 'use' */
2287     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2288
2289 #define ATTRSMODULE "attributes"
2290 #define ATTRSMODULE_PM "attributes.pm"
2291
2292     if (for_my) {
2293         /* Don't force the C<use> if we don't need it. */
2294         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2295         if (svp && *svp != &PL_sv_undef)
2296             NOOP;       /* already in %INC */
2297         else
2298             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2299                              newSVpvs(ATTRSMODULE), NULL);
2300     }
2301     else {
2302         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2303                          newSVpvs(ATTRSMODULE),
2304                          NULL,
2305                          op_prepend_elem(OP_LIST,
2306                                       newSVOP(OP_CONST, 0, stashsv),
2307                                       op_prepend_elem(OP_LIST,
2308                                                    newSVOP(OP_CONST, 0,
2309                                                            newRV(target)),
2310                                                    dup_attrlist(attrs))));
2311     }
2312     LEAVE;
2313 }
2314
2315 STATIC void
2316 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2317 {
2318     dVAR;
2319     OP *pack, *imop, *arg;
2320     SV *meth, *stashsv;
2321
2322     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2323
2324     if (!attrs)
2325         return;
2326
2327     assert(target->op_type == OP_PADSV ||
2328            target->op_type == OP_PADHV ||
2329            target->op_type == OP_PADAV);
2330
2331     /* Ensure that attributes.pm is loaded. */
2332     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2333
2334     /* Need package name for method call. */
2335     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2336
2337     /* Build up the real arg-list. */
2338     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2339
2340     arg = newOP(OP_PADSV, 0);
2341     arg->op_targ = target->op_targ;
2342     arg = op_prepend_elem(OP_LIST,
2343                        newSVOP(OP_CONST, 0, stashsv),
2344                        op_prepend_elem(OP_LIST,
2345                                     newUNOP(OP_REFGEN, 0,
2346                                             op_lvalue(arg, OP_REFGEN)),
2347                                     dup_attrlist(attrs)));
2348
2349     /* Fake up a method call to import */
2350     meth = newSVpvs_share("import");
2351     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2352                    op_append_elem(OP_LIST,
2353                                op_prepend_elem(OP_LIST, pack, list(arg)),
2354                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2355
2356     /* Combine the ops. */
2357     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2358 }
2359
2360 /*
2361 =notfor apidoc apply_attrs_string
2362
2363 Attempts to apply a list of attributes specified by the C<attrstr> and
2364 C<len> arguments to the subroutine identified by the C<cv> argument which
2365 is expected to be associated with the package identified by the C<stashpv>
2366 argument (see L<attributes>).  It gets this wrong, though, in that it
2367 does not correctly identify the boundaries of the individual attribute
2368 specifications within C<attrstr>.  This is not really intended for the
2369 public API, but has to be listed here for systems such as AIX which
2370 need an explicit export list for symbols.  (It's called from XS code
2371 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2372 to respect attribute syntax properly would be welcome.
2373
2374 =cut
2375 */
2376
2377 void
2378 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2379                         const char *attrstr, STRLEN len)
2380 {
2381     OP *attrs = NULL;
2382
2383     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2384
2385     if (!len) {
2386         len = strlen(attrstr);
2387     }
2388
2389     while (len) {
2390         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2391         if (len) {
2392             const char * const sstr = attrstr;
2393             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2394             attrs = op_append_elem(OP_LIST, attrs,
2395                                 newSVOP(OP_CONST, 0,
2396                                         newSVpvn(sstr, attrstr-sstr)));
2397         }
2398     }
2399
2400     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2401                      newSVpvs(ATTRSMODULE),
2402                      NULL, op_prepend_elem(OP_LIST,
2403                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2404                                   op_prepend_elem(OP_LIST,
2405                                                newSVOP(OP_CONST, 0,
2406                                                        newRV(MUTABLE_SV(cv))),
2407                                                attrs)));
2408 }
2409
2410 STATIC OP *
2411 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2412 {
2413     dVAR;
2414     I32 type;
2415     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2416
2417     PERL_ARGS_ASSERT_MY_KID;
2418
2419     if (!o || (PL_parser && PL_parser->error_count))
2420         return o;
2421
2422     type = o->op_type;
2423     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2424         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2425         return o;
2426     }
2427
2428     if (type == OP_LIST) {
2429         OP *kid;
2430         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2431             my_kid(kid, attrs, imopsp);
2432         return o;
2433     } else if (type == OP_UNDEF
2434 #ifdef PERL_MAD
2435                || type == OP_STUB
2436 #endif
2437                ) {
2438         return o;
2439     } else if (type == OP_RV2SV ||      /* "our" declaration */
2440                type == OP_RV2AV ||
2441                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2442         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2443             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2444                         OP_DESC(o),
2445                         PL_parser->in_my == KEY_our
2446                             ? "our"
2447                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2448         } else if (attrs) {
2449             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2450             PL_parser->in_my = FALSE;
2451             PL_parser->in_my_stash = NULL;
2452             apply_attrs(GvSTASH(gv),
2453                         (type == OP_RV2SV ? GvSV(gv) :
2454                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2455                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2456                         attrs, FALSE);
2457         }
2458         o->op_private |= OPpOUR_INTRO;
2459         return o;
2460     }
2461     else if (type != OP_PADSV &&
2462              type != OP_PADAV &&
2463              type != OP_PADHV &&
2464              type != OP_PUSHMARK)
2465     {
2466         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2467                           OP_DESC(o),
2468                           PL_parser->in_my == KEY_our
2469                             ? "our"
2470                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2471         return o;
2472     }
2473     else if (attrs && type != OP_PUSHMARK) {
2474         HV *stash;
2475
2476         PL_parser->in_my = FALSE;
2477         PL_parser->in_my_stash = NULL;
2478
2479         /* check for C<my Dog $spot> when deciding package */
2480         stash = PAD_COMPNAME_TYPE(o->op_targ);
2481         if (!stash)
2482             stash = PL_curstash;
2483         apply_attrs_my(stash, o, attrs, imopsp);
2484     }
2485     o->op_flags |= OPf_MOD;
2486     o->op_private |= OPpLVAL_INTRO;
2487     if (stately)
2488         o->op_private |= OPpPAD_STATE;
2489     return o;
2490 }
2491
2492 OP *
2493 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2494 {
2495     dVAR;
2496     OP *rops;
2497     int maybe_scalar = 0;
2498
2499     PERL_ARGS_ASSERT_MY_ATTRS;
2500
2501 /* [perl #17376]: this appears to be premature, and results in code such as
2502    C< our(%x); > executing in list mode rather than void mode */
2503 #if 0
2504     if (o->op_flags & OPf_PARENS)
2505         list(o);
2506     else
2507         maybe_scalar = 1;
2508 #else
2509     maybe_scalar = 1;
2510 #endif
2511     if (attrs)
2512         SAVEFREEOP(attrs);
2513     rops = NULL;
2514     o = my_kid(o, attrs, &rops);
2515     if (rops) {
2516         if (maybe_scalar && o->op_type == OP_PADSV) {
2517             o = scalar(op_append_list(OP_LIST, rops, o));
2518             o->op_private |= OPpLVAL_INTRO;
2519         }
2520         else {
2521             /* The listop in rops might have a pushmark at the beginning,
2522                which will mess up list assignment. */
2523             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2524             if (rops->op_type == OP_LIST &&
2525                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2526             {
2527                 OP * const pushmark = lrops->op_first;
2528                 lrops->op_first = pushmark->op_sibling;
2529                 op_free(pushmark);
2530             }
2531             o = op_append_list(OP_LIST, o, rops);
2532         }
2533     }
2534     PL_parser->in_my = FALSE;
2535     PL_parser->in_my_stash = NULL;
2536     return o;
2537 }
2538
2539 OP *
2540 Perl_sawparens(pTHX_ OP *o)
2541 {
2542     PERL_UNUSED_CONTEXT;
2543     if (o)
2544         o->op_flags |= OPf_PARENS;
2545     return o;
2546 }
2547
2548 OP *
2549 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2550 {
2551     OP *o;
2552     bool ismatchop = 0;
2553     const OPCODE ltype = left->op_type;
2554     const OPCODE rtype = right->op_type;
2555
2556     PERL_ARGS_ASSERT_BIND_MATCH;
2557
2558     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2559           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2560     {
2561       const char * const desc
2562           = PL_op_desc[(
2563                           rtype == OP_SUBST || rtype == OP_TRANS
2564                        || rtype == OP_TRANSR
2565                        )
2566                        ? (int)rtype : OP_MATCH];
2567       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2568       GV *gv;
2569       SV * const name =
2570        (ltype == OP_RV2AV || ltype == OP_RV2HV)
2571         ?    cUNOPx(left)->op_first->op_type == OP_GV
2572           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2573               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2574               : NULL
2575         : varname(
2576            (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2577           );
2578       if (name)
2579         Perl_warner(aTHX_ packWARN(WARN_MISC),
2580              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2581              desc, name, name);
2582       else {
2583         const char * const sample = (isary
2584              ? "@array" : "%hash");
2585         Perl_warner(aTHX_ packWARN(WARN_MISC),
2586              "Applying %s to %s will act on scalar(%s)",
2587              desc, sample, sample);
2588       }
2589     }
2590
2591     if (rtype == OP_CONST &&
2592         cSVOPx(right)->op_private & OPpCONST_BARE &&
2593         cSVOPx(right)->op_private & OPpCONST_STRICT)
2594     {
2595         no_bareword_allowed(right);
2596     }
2597
2598     /* !~ doesn't make sense with /r, so error on it for now */
2599     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2600         type == OP_NOT)
2601         yyerror("Using !~ with s///r doesn't make sense");
2602     if (rtype == OP_TRANSR && type == OP_NOT)
2603         yyerror("Using !~ with tr///r doesn't make sense");
2604
2605     ismatchop = (rtype == OP_MATCH ||
2606                  rtype == OP_SUBST ||
2607                  rtype == OP_TRANS || rtype == OP_TRANSR)
2608              && !(right->op_flags & OPf_SPECIAL);
2609     if (ismatchop && right->op_private & OPpTARGET_MY) {
2610         right->op_targ = 0;
2611         right->op_private &= ~OPpTARGET_MY;
2612     }
2613     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2614         OP *newleft;
2615
2616         right->op_flags |= OPf_STACKED;
2617         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2618             ! (rtype == OP_TRANS &&
2619                right->op_private & OPpTRANS_IDENTICAL) &&
2620             ! (rtype == OP_SUBST &&
2621                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2622             newleft = op_lvalue(left, rtype);
2623         else
2624             newleft = left;
2625         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2626             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2627         else
2628             o = op_prepend_elem(rtype, scalar(newleft), right);
2629         if (type == OP_NOT)
2630             return newUNOP(OP_NOT, 0, scalar(o));
2631         return o;
2632     }
2633     else
2634         return bind_match(type, left,
2635                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2636 }
2637
2638 OP *
2639 Perl_invert(pTHX_ OP *o)
2640 {
2641     if (!o)
2642         return NULL;
2643     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2644 }
2645
2646 /*
2647 =for apidoc Amx|OP *|op_scope|OP *o
2648
2649 Wraps up an op tree with some additional ops so that at runtime a dynamic
2650 scope will be created.  The original ops run in the new dynamic scope,
2651 and then, provided that they exit normally, the scope will be unwound.
2652 The additional ops used to create and unwind the dynamic scope will
2653 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2654 instead if the ops are simple enough to not need the full dynamic scope
2655 structure.
2656
2657 =cut
2658 */
2659
2660 OP *
2661 Perl_op_scope(pTHX_ OP *o)
2662 {
2663     dVAR;
2664     if (o) {
2665         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2666             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2667             o->op_type = OP_LEAVE;
2668             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2669         }
2670         else if (o->op_type == OP_LINESEQ) {
2671             OP *kid;
2672             o->op_type = OP_SCOPE;
2673             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2674             kid = ((LISTOP*)o)->op_first;
2675             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2676                 op_null(kid);
2677
2678                 /* The following deals with things like 'do {1 for 1}' */
2679                 kid = kid->op_sibling;
2680                 if (kid &&
2681                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2682                     op_null(kid);
2683             }
2684         }
2685         else
2686             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2687     }
2688     return o;
2689 }
2690
2691 int
2692 Perl_block_start(pTHX_ int full)
2693 {
2694     dVAR;
2695     const int retval = PL_savestack_ix;
2696
2697     pad_block_start(full);
2698     SAVEHINTS();
2699     PL_hints &= ~HINT_BLOCK_SCOPE;
2700     SAVECOMPILEWARNINGS();
2701     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2702
2703     CALL_BLOCK_HOOKS(bhk_start, full);
2704
2705     return retval;
2706 }
2707
2708 OP*
2709 Perl_block_end(pTHX_ I32 floor, OP *seq)
2710 {
2711     dVAR;
2712     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2713     OP* retval = scalarseq(seq);
2714
2715     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2716
2717     LEAVE_SCOPE(floor);
2718     CopHINTS_set(&PL_compiling, PL_hints);
2719     if (needblockscope)
2720         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2721     pad_leavemy();
2722
2723     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2724
2725     return retval;
2726 }
2727
2728 /*
2729 =head1 Compile-time scope hooks
2730
2731 =for apidoc Aox||blockhook_register
2732
2733 Register a set of hooks to be called when the Perl lexical scope changes
2734 at compile time. See L<perlguts/"Compile-time scope hooks">.
2735
2736 =cut
2737 */
2738
2739 void
2740 Perl_blockhook_register(pTHX_ BHK *hk)
2741 {
2742     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2743
2744     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2745 }
2746
2747 STATIC OP *
2748 S_newDEFSVOP(pTHX)
2749 {
2750     dVAR;
2751     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2752     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2753         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2754     }
2755     else {
2756         OP * const o = newOP(OP_PADSV, 0);
2757         o->op_targ = offset;
2758         return o;
2759     }
2760 }
2761
2762 void
2763 Perl_newPROG(pTHX_ OP *o)
2764 {
2765     dVAR;
2766
2767     PERL_ARGS_ASSERT_NEWPROG;
2768
2769     if (PL_in_eval) {
2770         PERL_CONTEXT *cx;
2771         I32 i;
2772         if (PL_eval_root)
2773                 return;
2774         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2775                                ((PL_in_eval & EVAL_KEEPERR)
2776                                 ? OPf_SPECIAL : 0), o);
2777
2778         cx = &cxstack[cxstack_ix];
2779         assert(CxTYPE(cx) == CXt_EVAL);
2780
2781         if ((cx->blk_gimme & G_WANT) == G_VOID)
2782             scalarvoid(PL_eval_root);
2783         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2784             list(PL_eval_root);
2785         else
2786             scalar(PL_eval_root);
2787
2788         /* don't use LINKLIST, since PL_eval_root might indirect through
2789          * a rather expensive function call and LINKLIST evaluates its
2790          * argument more than once */
2791         PL_eval_start = op_linklist(PL_eval_root);
2792         PL_eval_root->op_private |= OPpREFCOUNTED;
2793         OpREFCNT_set(PL_eval_root, 1);
2794         PL_eval_root->op_next = 0;
2795         i = PL_savestack_ix;
2796         SAVEFREEOP(o);
2797         ENTER;
2798         CALL_PEEP(PL_eval_start);
2799         finalize_optree(PL_eval_root);
2800         LEAVE;
2801         PL_savestack_ix = i;
2802     }
2803     else {
2804         if (o->op_type == OP_STUB) {
2805             PL_comppad_name = 0;
2806             PL_compcv = 0;
2807             S_op_destroy(aTHX_ o);
2808             return;
2809         }
2810         PL_main_root = op_scope(sawparens(scalarvoid(o)));
2811         PL_curcop = &PL_compiling;
2812         PL_main_start = LINKLIST(PL_main_root);
2813         PL_main_root->op_private |= OPpREFCOUNTED;
2814         OpREFCNT_set(PL_main_root, 1);
2815         PL_main_root->op_next = 0;
2816         CALL_PEEP(PL_main_start);
2817         finalize_optree(PL_main_root);
2818         PL_compcv = 0;
2819
2820         /* Register with debugger */
2821         if (PERLDB_INTER) {
2822             CV * const cv = get_cvs("DB::postponed", 0);
2823             if (cv) {
2824                 dSP;
2825                 PUSHMARK(SP);
2826                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2827                 PUTBACK;
2828                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2829             }
2830         }
2831     }
2832 }
2833
2834 OP *
2835 Perl_localize(pTHX_ OP *o, I32 lex)
2836 {
2837     dVAR;
2838
2839     PERL_ARGS_ASSERT_LOCALIZE;
2840
2841     if (o->op_flags & OPf_PARENS)
2842 /* [perl #17376]: this appears to be premature, and results in code such as
2843    C< our(%x); > executing in list mode rather than void mode */
2844 #if 0
2845         list(o);
2846 #else
2847         NOOP;
2848 #endif
2849     else {
2850         if ( PL_parser->bufptr > PL_parser->oldbufptr
2851             && PL_parser->bufptr[-1] == ','
2852             && ckWARN(WARN_PARENTHESIS))
2853         {
2854             char *s = PL_parser->bufptr;
2855             bool sigil = FALSE;
2856
2857             /* some heuristics to detect a potential error */
2858             while (*s && (strchr(", \t\n", *s)))
2859                 s++;
2860
2861             while (1) {
2862                 if (*s && strchr("@$%*", *s) && *++s
2863                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2864                     s++;
2865                     sigil = TRUE;
2866                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2867                         s++;
2868                     while (*s && (strchr(", \t\n", *s)))
2869                         s++;
2870                 }
2871                 else
2872                     break;
2873             }
2874             if (sigil && (*s == ';' || *s == '=')) {
2875                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2876                                 "Parentheses missing around \"%s\" list",
2877                                 lex
2878                                     ? (PL_parser->in_my == KEY_our
2879                                         ? "our"
2880                                         : PL_parser->in_my == KEY_state
2881                                             ? "state"
2882                                             : "my")
2883                                     : "local");
2884             }
2885         }
2886     }
2887     if (lex)
2888         o = my(o);
2889     else
2890         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
2891     PL_parser->in_my = FALSE;
2892     PL_parser->in_my_stash = NULL;
2893     return o;
2894 }
2895
2896 OP *
2897 Perl_jmaybe(pTHX_ OP *o)
2898 {
2899     PERL_ARGS_ASSERT_JMAYBE;
2900
2901     if (o->op_type == OP_LIST) {
2902         OP * const o2
2903             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2904         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2905     }
2906     return o;
2907 }
2908
2909 PERL_STATIC_INLINE OP *
2910 S_op_std_init(pTHX_ OP *o)
2911 {
2912     I32 type = o->op_type;
2913
2914     PERL_ARGS_ASSERT_OP_STD_INIT;
2915
2916     if (PL_opargs[type] & OA_RETSCALAR)
2917         scalar(o);
2918     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2919         o->op_targ = pad_alloc(type, SVs_PADTMP);
2920
2921     return o;
2922 }
2923
2924 PERL_STATIC_INLINE OP *
2925 S_op_integerize(pTHX_ OP *o)
2926 {
2927     I32 type = o->op_type;
2928
2929     PERL_ARGS_ASSERT_OP_INTEGERIZE;
2930
2931     /* integerize op, unless it happens to be C<-foo>.
2932      * XXX should pp_i_negate() do magic string negation instead? */
2933     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2934         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2935              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2936     {
2937         dVAR;
2938         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2939     }
2940
2941     if (type == OP_NEGATE)
2942         /* XXX might want a ck_negate() for this */
2943         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2944
2945     return o;
2946 }
2947
2948 static OP *
2949 S_fold_constants(pTHX_ register OP *o)
2950 {
2951     dVAR;
2952     register OP * VOL curop;
2953     OP *newop;
2954     VOL I32 type = o->op_type;
2955     SV * VOL sv = NULL;
2956     int ret = 0;
2957     I32 oldscope;
2958     OP *old_next;
2959     SV * const oldwarnhook = PL_warnhook;
2960     SV * const olddiehook  = PL_diehook;
2961     COP not_compiling;
2962     dJMPENV;
2963
2964     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2965
2966     if (!(PL_opargs[type] & OA_FOLDCONST))
2967         goto nope;
2968
2969     switch (type) {
2970     case OP_UCFIRST:
2971     case OP_LCFIRST:
2972     case OP_UC:
2973     case OP_LC:
2974     case OP_SLT:
2975     case OP_SGT:
2976     case OP_SLE:
2977     case OP_SGE:
2978     case OP_SCMP:
2979     case OP_SPRINTF:
2980         /* XXX what about the numeric ops? */
2981         if (IN_LOCALE_COMPILETIME)
2982             goto nope;
2983         break;
2984     }
2985
2986     if (PL_parser && PL_parser->error_count)
2987         goto nope;              /* Don't try to run w/ errors */
2988
2989     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2990         const OPCODE type = curop->op_type;
2991         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2992             type != OP_LIST &&
2993             type != OP_SCALAR &&
2994             type != OP_NULL &&
2995             type != OP_PUSHMARK)
2996         {
2997             goto nope;
2998         }
2999     }
3000
3001     curop = LINKLIST(o);
3002     old_next = o->op_next;
3003     o->op_next = 0;
3004     PL_op = curop;
3005
3006     oldscope = PL_scopestack_ix;
3007     create_eval_scope(G_FAKINGEVAL);
3008
3009     /* Verify that we don't need to save it:  */
3010     assert(PL_curcop == &PL_compiling);
3011     StructCopy(&PL_compiling, &not_compiling, COP);
3012     PL_curcop = &not_compiling;
3013     /* The above ensures that we run with all the correct hints of the
3014        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3015     assert(IN_PERL_RUNTIME);
3016     PL_warnhook = PERL_WARNHOOK_FATAL;
3017     PL_diehook  = NULL;
3018     JMPENV_PUSH(ret);
3019
3020     switch (ret) {
3021     case 0:
3022         CALLRUNOPS(aTHX);
3023         sv = *(PL_stack_sp--);
3024         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3025 #ifdef PERL_MAD
3026             /* Can't simply swipe the SV from the pad, because that relies on
3027                the op being freed "real soon now". Under MAD, this doesn't
3028                happen (see the #ifdef below).  */
3029             sv = newSVsv(sv);
3030 #else
3031             pad_swipe(o->op_targ,  FALSE);
3032 #endif
3033         }
3034         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3035             SvREFCNT_inc_simple_void(sv);
3036             SvTEMP_off(sv);
3037         }
3038         break;
3039     case 3:
3040         /* Something tried to die.  Abandon constant folding.  */
3041         /* Pretend the error never happened.  */
3042         CLEAR_ERRSV();
3043         o->op_next = old_next;
3044         break;
3045     default:
3046         JMPENV_POP;
3047         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3048         PL_warnhook = oldwarnhook;
3049         PL_diehook  = olddiehook;
3050         /* XXX note that this croak may fail as we've already blown away
3051          * the stack - eg any nested evals */
3052         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3053     }
3054     JMPENV_POP;
3055     PL_warnhook = oldwarnhook;
3056     PL_diehook  = olddiehook;
3057     PL_curcop = &PL_compiling;
3058
3059     if (PL_scopestack_ix > oldscope)
3060         delete_eval_scope();
3061
3062     if (ret)
3063         goto nope;
3064
3065 #ifndef PERL_MAD
3066     op_free(o);
3067 #endif
3068     assert(sv);
3069     if (type == OP_RV2GV)
3070         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3071     else
3072         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3073     op_getmad(o,newop,'f');
3074     return newop;
3075
3076  nope:
3077     return o;
3078 }
3079
3080 static OP *
3081 S_gen_constant_list(pTHX_ register OP *o)
3082 {
3083     dVAR;
3084     register OP *curop;
3085     const I32 oldtmps_floor = PL_tmps_floor;
3086
3087     list(o);
3088     if (PL_parser && PL_parser->error_count)
3089         return o;               /* Don't attempt to run with errors */
3090
3091     PL_op = curop = LINKLIST(o);
3092     o->op_next = 0;
3093     CALL_PEEP(curop);
3094     Perl_pp_pushmark(aTHX);
3095     CALLRUNOPS(aTHX);
3096     PL_op = curop;
3097     assert (!(curop->op_flags & OPf_SPECIAL));
3098     assert(curop->op_type == OP_RANGE);
3099     Perl_pp_anonlist(aTHX);
3100     PL_tmps_floor = oldtmps_floor;
3101
3102     o->op_type = OP_RV2AV;
3103     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3104     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3105     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3106     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3107     curop = ((UNOP*)o)->op_first;
3108     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3109 #ifdef PERL_MAD
3110     op_getmad(curop,o,'O');
3111 #else
3112     op_free(curop);
3113 #endif
3114     LINKLIST(o);
3115     return list(o);
3116 }
3117
3118 OP *
3119 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3120 {
3121     dVAR;
3122     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3123     if (!o || o->op_type != OP_LIST)
3124         o = newLISTOP(OP_LIST, 0, o, NULL);
3125     else
3126         o->op_flags &= ~OPf_WANT;
3127
3128     if (!(PL_opargs[type] & OA_MARK))
3129         op_null(cLISTOPo->op_first);
3130     else {
3131         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3132         if (kid2 && kid2->op_type == OP_COREARGS) {
3133             op_null(cLISTOPo->op_first);
3134             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3135         }
3136     }
3137
3138     o->op_type = (OPCODE)type;
3139     o->op_ppaddr = PL_ppaddr[type];
3140     o->op_flags |= flags;
3141
3142     o = CHECKOP(type, o);
3143     if (o->op_type != (unsigned)type)
3144         return o;
3145
3146     return fold_constants(op_integerize(op_std_init(o)));
3147 }
3148
3149 /*
3150 =head1 Optree Manipulation Functions
3151 */
3152
3153 /* List constructors */
3154
3155 /*
3156 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3157
3158 Append an item to the list of ops contained directly within a list-type
3159 op, returning the lengthened list.  I<first> is the list-type op,
3160 and I<last> is the op to append to the list.  I<optype> specifies the
3161 intended opcode for the list.  If I<first> is not already a list of the
3162 right type, it will be upgraded into one.  If either I<first> or I<last>
3163 is null, the other is returned unchanged.
3164
3165 =cut
3166 */
3167
3168 OP *
3169 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3170 {
3171     if (!first)
3172         return last;
3173
3174     if (!last)
3175         return first;
3176
3177     if (first->op_type != (unsigned)type
3178         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3179     {
3180         return newLISTOP(type, 0, first, last);
3181     }
3182
3183     if (first->op_flags & OPf_KIDS)
3184         ((LISTOP*)first)->op_last->op_sibling = last;
3185     else {
3186         first->op_flags |= OPf_KIDS;
3187         ((LISTOP*)first)->op_first = last;
3188     }
3189     ((LISTOP*)first)->op_last = last;
3190     return first;
3191 }
3192
3193 /*
3194 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3195
3196 Concatenate the lists of ops contained directly within two list-type ops,
3197 returning the combined list.  I<first> and I<last> are the list-type ops
3198 to concatenate.  I<optype> specifies the intended opcode for the list.
3199 If either I<first> or I<last> is not already a list of the right type,
3200 it will be upgraded into one.  If either I<first> or I<last> is null,
3201 the other is returned unchanged.
3202
3203 =cut
3204 */
3205
3206 OP *
3207 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3208 {
3209     if (!first)
3210         return last;
3211
3212     if (!last)
3213         return first;
3214
3215     if (first->op_type != (unsigned)type)
3216         return op_prepend_elem(type, first, last);
3217
3218     if (last->op_type != (unsigned)type)
3219         return op_append_elem(type, first, last);
3220
3221     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3222     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3223     first->op_flags |= (last->op_flags & OPf_KIDS);
3224
3225 #ifdef PERL_MAD
3226     if (((LISTOP*)last)->op_first && first->op_madprop) {
3227         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3228         if (mp) {
3229             while (mp->mad_next)
3230                 mp = mp->mad_next;
3231             mp->mad_next = first->op_madprop;
3232         }
3233         else {
3234             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3235         }
3236     }
3237     first->op_madprop = last->op_madprop;
3238     last->op_madprop = 0;
3239 #endif
3240
3241     S_op_destroy(aTHX_ last);
3242
3243     return first;
3244 }
3245
3246 /*
3247 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3248
3249 Prepend an item to the list of ops contained directly within a list-type
3250 op, returning the lengthened list.  I<first> is the op to prepend to the
3251 list, and I<last> is the list-type op.  I<optype> specifies the intended
3252 opcode for the list.  If I<last> is not already a list of the right type,
3253 it will be upgraded into one.  If either I<first> or I<last> is null,
3254 the other is returned unchanged.
3255
3256 =cut
3257 */
3258
3259 OP *
3260 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3261 {
3262     if (!first)
3263         return last;
3264
3265     if (!last)
3266         return first;
3267
3268     if (last->op_type == (unsigned)type) {
3269         if (type == OP_LIST) {  /* already a PUSHMARK there */
3270             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3271             ((LISTOP*)last)->op_first->op_sibling = first;
3272             if (!(first->op_flags & OPf_PARENS))
3273                 last->op_flags &= ~OPf_PARENS;
3274         }
3275         else {
3276             if (!(last->op_flags & OPf_KIDS)) {
3277                 ((LISTOP*)last)->op_last = first;
3278                 last->op_flags |= OPf_KIDS;
3279             }
3280             first->op_sibling = ((LISTOP*)last)->op_first;
3281             ((LISTOP*)last)->op_first = first;
3282         }
3283         last->op_flags |= OPf_KIDS;
3284         return last;
3285     }
3286
3287     return newLISTOP(type, 0, first, last);
3288 }
3289
3290 /* Constructors */
3291
3292 #ifdef PERL_MAD
3293
3294 TOKEN *
3295 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3296 {
3297     TOKEN *tk;
3298     Newxz(tk, 1, TOKEN);
3299     tk->tk_type = (OPCODE)optype;
3300     tk->tk_type = 12345;
3301     tk->tk_lval = lval;
3302     tk->tk_mad = madprop;
3303     return tk;
3304 }
3305
3306 void
3307 Perl_token_free(pTHX_ TOKEN* tk)
3308 {
3309     PERL_ARGS_ASSERT_TOKEN_FREE;
3310
3311     if (tk->tk_type != 12345)
3312         return;
3313     mad_free(tk->tk_mad);
3314     Safefree(tk);
3315 }
3316
3317 void
3318 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3319 {
3320     MADPROP* mp;
3321     MADPROP* tm;
3322
3323     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3324
3325     if (tk->tk_type != 12345) {
3326         Perl_warner(aTHX_ packWARN(WARN_MISC),
3327              "Invalid TOKEN object ignored");
3328         return;
3329     }
3330     tm = tk->tk_mad;
3331     if (!tm)
3332         return;
3333
3334     /* faked up qw list? */
3335     if (slot == '(' &&
3336         tm->mad_type == MAD_SV &&
3337         SvPVX((SV *)tm->mad_val)[0] == 'q')
3338             slot = 'x';
3339
3340     if (o) {
3341         mp = o->op_madprop;
3342         if (mp) {
3343             for (;;) {
3344                 /* pretend constant fold didn't happen? */
3345                 if (mp->mad_key == 'f' &&
3346                     (o->op_type == OP_CONST ||
3347                      o->op_type == OP_GV) )
3348                 {
3349                     token_getmad(tk,(OP*)mp->mad_val,slot);
3350                     return;
3351                 }
3352                 if (!mp->mad_next)
3353                     break;
3354                 mp = mp->mad_next;
3355             }
3356             mp->mad_next = tm;
3357             mp = mp->mad_next;
3358         }
3359         else {
3360             o->op_madprop = tm;
3361             mp = o->op_madprop;
3362         }
3363         if (mp->mad_key == 'X')
3364             mp->mad_key = slot; /* just change the first one */
3365
3366         tk->tk_mad = 0;
3367     }
3368     else
3369         mad_free(tm);
3370     Safefree(tk);
3371 }
3372
3373 void
3374 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3375 {
3376     MADPROP* mp;
3377     if (!from)
3378         return;
3379     if (o) {
3380         mp = o->op_madprop;
3381         if (mp) {
3382             for (;;) {
3383                 /* pretend constant fold didn't happen? */
3384                 if (mp->mad_key == 'f' &&
3385                     (o->op_type == OP_CONST ||
3386                      o->op_type == OP_GV) )
3387                 {
3388                     op_getmad(from,(OP*)mp->mad_val,slot);
3389                     return;
3390                 }
3391                 if (!mp->mad_next)
3392                     break;
3393                 mp = mp->mad_next;
3394             }
3395             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3396         }
3397         else {
3398             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3399         }
3400     }
3401 }
3402
3403 void
3404 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3405 {
3406     MADPROP* mp;
3407     if (!from)
3408         return;
3409     if (o) {
3410         mp = o->op_madprop;
3411         if (mp) {
3412             for (;;) {
3413                 /* pretend constant fold didn't happen? */
3414                 if (mp->mad_key == 'f' &&
3415                     (o->op_type == OP_CONST ||
3416                      o->op_type == OP_GV) )
3417                 {
3418                     op_getmad(from,(OP*)mp->mad_val,slot);
3419                     return;
3420                 }
3421                 if (!mp->mad_next)
3422                     break;
3423                 mp = mp->mad_next;
3424             }
3425             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3426         }
3427         else {
3428             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3429         }
3430     }
3431     else {
3432         PerlIO_printf(PerlIO_stderr(),
3433                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3434         op_free(from);
3435     }
3436 }
3437
3438 void
3439 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3440 {
3441     MADPROP* tm;
3442     if (!mp || !o)
3443         return;
3444     if (slot)
3445         mp->mad_key = slot;
3446     tm = o->op_madprop;
3447     o->op_madprop = mp;
3448     for (;;) {
3449         if (!mp->mad_next)
3450             break;
3451         mp = mp->mad_next;
3452     }
3453     mp->mad_next = tm;
3454 }
3455
3456 void
3457 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3458 {
3459     if (!o)
3460         return;
3461     addmad(tm, &(o->op_madprop), slot);
3462 }
3463
3464 void
3465 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3466 {
3467     MADPROP* mp;
3468     if (!tm || !root)
3469         return;
3470     if (slot)
3471         tm->mad_key = slot;
3472     mp = *root;
3473     if (!mp) {
3474         *root = tm;
3475         return;
3476     }
3477     for (;;) {
3478         if (!mp->mad_next)
3479             break;
3480         mp = mp->mad_next;
3481     }
3482     mp->mad_next = tm;
3483 }
3484
3485 MADPROP *
3486 Perl_newMADsv(pTHX_ char key, SV* sv)
3487 {
3488     PERL_ARGS_ASSERT_NEWMADSV;
3489
3490     return newMADPROP(key, MAD_SV, sv, 0);
3491 }
3492
3493 MADPROP *
3494 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3495 {
3496     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3497     mp->mad_next = 0;
3498     mp->mad_key = key;
3499     mp->mad_vlen = vlen;
3500     mp->mad_type = type;
3501     mp->mad_val = val;
3502 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3503     return mp;
3504 }
3505
3506 void
3507 Perl_mad_free(pTHX_ MADPROP* mp)
3508 {
3509 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3510     if (!mp)
3511         return;
3512     if (mp->mad_next)
3513         mad_free(mp->mad_next);
3514 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3515         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3516     switch (mp->mad_type) {
3517     case MAD_NULL:
3518         break;
3519     case MAD_PV:
3520         Safefree((char*)mp->mad_val);
3521         break;
3522     case MAD_OP:
3523         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3524             op_free((OP*)mp->mad_val);
3525         break;
3526     case MAD_SV:
3527         sv_free(MUTABLE_SV(mp->mad_val));
3528         break;
3529     default:
3530         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3531         break;
3532     }
3533     PerlMemShared_free(mp);
3534 }
3535
3536 #endif
3537
3538 /*
3539 =head1 Optree construction
3540
3541 =for apidoc Am|OP *|newNULLLIST
3542
3543 Constructs, checks, and returns a new C<stub> op, which represents an
3544 empty list expression.
3545
3546 =cut
3547 */
3548
3549 OP *
3550 Perl_newNULLLIST(pTHX)
3551 {
3552     return newOP(OP_STUB, 0);
3553 }
3554
3555 static OP *
3556 S_force_list(pTHX_ OP *o)
3557 {
3558     if (!o || o->op_type != OP_LIST)
3559         o = newLISTOP(OP_LIST, 0, o, NULL);
3560     op_null(o);
3561     return o;
3562 }
3563
3564 /*
3565 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3566
3567 Constructs, checks, and returns an op of any list type.  I<type> is
3568 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3569 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3570 supply up to two ops to be direct children of the list op; they are
3571 consumed by this function and become part of the constructed op tree.
3572
3573 =cut
3574 */
3575
3576 OP *
3577 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3578 {
3579     dVAR;
3580     LISTOP *listop;
3581
3582     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3583
3584     NewOp(1101, listop, 1, LISTOP);
3585
3586     listop->op_type = (OPCODE)type;
3587     listop->op_ppaddr = PL_ppaddr[type];
3588     if (first || last)
3589         flags |= OPf_KIDS;
3590     listop->op_flags = (U8)flags;
3591
3592     if (!last && first)
3593         last = first;
3594     else if (!first && last)
3595         first = last;
3596     else if (first)
3597         first->op_sibling = last;
3598     listop->op_first = first;
3599     listop->op_last = last;
3600     if (type == OP_LIST) {
3601         OP* const pushop = newOP(OP_PUSHMARK, 0);
3602         pushop->op_sibling = first;
3603         listop->op_first = pushop;
3604         listop->op_flags |= OPf_KIDS;
3605         if (!last)
3606             listop->op_last = pushop;
3607     }
3608
3609     return CHECKOP(type, listop);
3610 }
3611
3612 /*
3613 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3614
3615 Constructs, checks, and returns an op of any base type (any type that
3616 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3617 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3618 of C<op_private>.
3619
3620 =cut
3621 */
3622
3623 OP *
3624 Perl_newOP(pTHX_ I32 type, I32 flags)
3625 {
3626     dVAR;
3627     OP *o;
3628
3629     if (type == -OP_ENTEREVAL) {
3630         type = OP_ENTEREVAL;
3631         flags |= OPpEVAL_BYTES<<8;
3632     }
3633
3634     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3635         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3636         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3637         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3638
3639     NewOp(1101, o, 1, OP);
3640     o->op_type = (OPCODE)type;
3641     o->op_ppaddr = PL_ppaddr[type];
3642     o->op_flags = (U8)flags;
3643     o->op_latefree = 0;
3644     o->op_latefreed = 0;
3645     o->op_attached = 0;
3646
3647     o->op_next = o;
3648     o->op_private = (U8)(0 | (flags >> 8));
3649     if (PL_opargs[type] & OA_RETSCALAR)
3650         scalar(o);
3651     if (PL_opargs[type] & OA_TARGET)
3652         o->op_targ = pad_alloc(type, SVs_PADTMP);
3653     return CHECKOP(type, o);
3654 }
3655
3656 /*
3657 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3658
3659 Constructs, checks, and returns an op of any unary type.  I<type> is
3660 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3661 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3662 bits, the eight bits of C<op_private>, except that the bit with value 1
3663 is automatically set.  I<first> supplies an optional op to be the direct
3664 child of the unary op; it is consumed by this function and become part
3665 of the constructed op tree.
3666
3667 =cut
3668 */
3669
3670 OP *
3671 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3672 {
3673     dVAR;
3674     UNOP *unop;
3675
3676     if (type == -OP_ENTEREVAL) {
3677         type = OP_ENTEREVAL;
3678         flags |= OPpEVAL_BYTES<<8;
3679     }
3680
3681     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3682         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3683         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3684         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3685         || type == OP_SASSIGN
3686         || type == OP_ENTERTRY
3687         || type == OP_NULL );
3688
3689     if (!first)
3690         first = newOP(OP_STUB, 0);
3691     if (PL_opargs[type] & OA_MARK)
3692         first = force_list(first);
3693
3694     NewOp(1101, unop, 1, UNOP);
3695     unop->op_type = (OPCODE)type;
3696     unop->op_ppaddr = PL_ppaddr[type];
3697     unop->op_first = first;
3698     unop->op_flags = (U8)(flags | OPf_KIDS);
3699     unop->op_private = (U8)(1 | (flags >> 8));
3700     unop = (UNOP*) CHECKOP(type, unop);
3701     if (unop->op_next)
3702         return (OP*)unop;
3703
3704     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3705 }
3706
3707 /*
3708 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3709
3710 Constructs, checks, and returns an op of any binary type.  I<type>
3711 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3712 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3713 the eight bits of C<op_private>, except that the bit with value 1 or
3714 2 is automatically set as required.  I<first> and I<last> supply up to
3715 two ops to be the direct children of the binary op; they are consumed
3716 by this function and become part of the constructed op tree.
3717
3718 =cut
3719 */
3720
3721 OP *
3722 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3723 {
3724     dVAR;
3725     BINOP *binop;
3726
3727     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3728         || type == OP_SASSIGN || type == OP_NULL );
3729
3730     NewOp(1101, binop, 1, BINOP);
3731
3732     if (!first)
3733         first = newOP(OP_NULL, 0);
3734
3735     binop->op_type = (OPCODE)type;
3736     binop->op_ppaddr = PL_ppaddr[type];
3737     binop->op_first = first;
3738     binop->op_flags = (U8)(flags | OPf_KIDS);
3739     if (!last) {
3740         last = first;
3741         binop->op_private = (U8)(1 | (flags >> 8));
3742     }
3743     else {
3744         binop->op_private = (U8)(2 | (flags >> 8));
3745         first->op_sibling = last;
3746     }
3747
3748     binop = (BINOP*)CHECKOP(type, binop);
3749     if (binop->op_next || binop->op_type != (OPCODE)type)
3750         return (OP*)binop;
3751
3752     binop->op_last = binop->op_first->op_sibling;
3753
3754     return fold_constants(op_integerize(op_std_init((OP *)binop)));
3755 }
3756
3757 static int uvcompare(const void *a, const void *b)
3758     __attribute__nonnull__(1)
3759     __attribute__nonnull__(2)
3760     __attribute__pure__;
3761 static int uvcompare(const void *a, const void *b)
3762 {
3763     if (*((const UV *)a) < (*(const UV *)b))
3764         return -1;
3765     if (*((const UV *)a) > (*(const UV *)b))
3766         return 1;
3767     if (*((const UV *)a+1) < (*(const UV *)b+1))
3768         return -1;
3769     if (*((const UV *)a+1) > (*(const UV *)b+1))
3770         return 1;
3771     return 0;
3772 }
3773
3774 static OP *
3775 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3776 {
3777     dVAR;
3778     SV * const tstr = ((SVOP*)expr)->op_sv;
3779     SV * const rstr =
3780 #ifdef PERL_MAD
3781                         (repl->op_type == OP_NULL)
3782                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3783 #endif
3784                               ((SVOP*)repl)->op_sv;
3785     STRLEN tlen;
3786     STRLEN rlen;
3787     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3788     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3789     register I32 i;
3790     register I32 j;
3791     I32 grows = 0;
3792     register short *tbl;
3793
3794     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3795     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3796     I32 del              = o->op_private & OPpTRANS_DELETE;
3797     SV* swash;
3798
3799     PERL_ARGS_ASSERT_PMTRANS;
3800
3801     PL_hints |= HINT_BLOCK_SCOPE;
3802
3803     if (SvUTF8(tstr))
3804         o->op_private |= OPpTRANS_FROM_UTF;
3805
3806     if (SvUTF8(rstr))
3807         o->op_private |= OPpTRANS_TO_UTF;
3808
3809     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3810         SV* const listsv = newSVpvs("# comment\n");
3811         SV* transv = NULL;
3812         const U8* tend = t + tlen;
3813         const U8* rend = r + rlen;
3814         STRLEN ulen;
3815         UV tfirst = 1;
3816         UV tlast = 0;
3817         IV tdiff;
3818         UV rfirst = 1;
3819         UV rlast = 0;
3820         IV rdiff;
3821         IV diff;
3822         I32 none = 0;
3823         U32 max = 0;
3824         I32 bits;
3825         I32 havefinal = 0;
3826         U32 final = 0;
3827         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3828         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3829         U8* tsave = NULL;
3830         U8* rsave = NULL;
3831         const U32 flags = UTF8_ALLOW_DEFAULT;
3832
3833         if (!from_utf) {
3834             STRLEN len = tlen;
3835             t = tsave = bytes_to_utf8(t, &len);
3836             tend = t + len;
3837         }
3838         if (!to_utf && rlen) {
3839             STRLEN len = rlen;
3840             r = rsave = bytes_to_utf8(r, &len);
3841             rend = r + len;
3842         }
3843
3844 /* There are several snags with this code on EBCDIC:
3845    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3846    2. scan_const() in toke.c has encoded chars in native encoding which makes
3847       ranges at least in EBCDIC 0..255 range the bottom odd.
3848 */
3849
3850         if (complement) {
3851             U8 tmpbuf[UTF8_MAXBYTES+1];
3852             UV *cp;
3853             UV nextmin = 0;
3854             Newx(cp, 2*tlen, UV);
3855             i = 0;
3856             transv = newSVpvs("");
3857             while (t < tend) {
3858                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3859                 t += ulen;
3860                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3861                     t++;
3862                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3863                     t += ulen;
3864                 }
3865                 else {
3866                  cp[2*i+1] = cp[2*i];
3867                 }
3868                 i++;
3869             }
3870             qsort(cp, i, 2*sizeof(UV), uvcompare);
3871             for (j = 0; j < i; j++) {
3872                 UV  val = cp[2*j];
3873                 diff = val - nextmin;
3874                 if (diff > 0) {
3875                     t = uvuni_to_utf8(tmpbuf,nextmin);
3876                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3877                     if (diff > 1) {
3878                         U8  range_mark = UTF_TO_NATIVE(0xff);
3879                         t = uvuni_to_utf8(tmpbuf, val - 1);
3880                         sv_catpvn(transv, (char *)&range_mark, 1);
3881                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3882                     }
3883                 }
3884                 val = cp[2*j+1];
3885                 if (val >= nextmin)
3886                     nextmin = val + 1;
3887             }
3888             t = uvuni_to_utf8(tmpbuf,nextmin);
3889             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3890             {
3891                 U8 range_mark = UTF_TO_NATIVE(0xff);
3892                 sv_catpvn(transv, (char *)&range_mark, 1);
3893             }
3894             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3895             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3896             t = (const U8*)SvPVX_const(transv);
3897             tlen = SvCUR(transv);
3898             tend = t + tlen;
3899             Safefree(cp);
3900         }
3901         else if (!rlen && !del) {
3902             r = t; rlen = tlen; rend = tend;
3903         }
3904         if (!squash) {
3905                 if ((!rlen && !del) || t == r ||
3906                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3907                 {
3908                     o->op_private |= OPpTRANS_IDENTICAL;
3909                 }
3910         }
3911
3912         while (t < tend || tfirst <= tlast) {
3913             /* see if we need more "t" chars */
3914             if (tfirst > tlast) {
3915                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3916                 t += ulen;
3917                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3918                     t++;
3919                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3920                     t += ulen;
3921                 }
3922                 else
3923                     tlast = tfirst;
3924             }
3925
3926             /* now see if we need more "r" chars */
3927             if (rfirst > rlast) {
3928                 if (r < rend) {
3929                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3930                     r += ulen;
3931                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3932                         r++;
3933                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3934                         r += ulen;
3935                     }
3936                     else
3937                         rlast = rfirst;
3938                 }
3939                 else {
3940                     if (!havefinal++)
3941                         final = rlast;
3942                     rfirst = rlast = 0xffffffff;
3943                 }
3944             }
3945
3946             /* now see which range will peter our first, if either. */
3947             tdiff = tlast - tfirst;
3948             rdiff = rlast - rfirst;
3949
3950             if (tdiff <= rdiff)
3951                 diff = tdiff;
3952             else
3953                 diff = rdiff;
3954
3955             if (rfirst == 0xffffffff) {
3956                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3957                 if (diff > 0)
3958                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3959                                    (long)tfirst, (long)tlast);
3960                 else
3961                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3962             }
3963             else {
3964                 if (diff > 0)
3965                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3966                                    (long)tfirst, (long)(tfirst + diff),
3967                                    (long)rfirst);
3968                 else
3969                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3970                                    (long)tfirst, (long)rfirst);
3971
3972                 if (rfirst + diff > max)
3973                     max = rfirst + diff;
3974                 if (!grows)
3975                     grows = (tfirst < rfirst &&
3976                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3977                 rfirst += diff + 1;
3978             }
3979             tfirst += diff + 1;
3980         }
3981
3982         none = ++max;
3983         if (del)
3984             del = ++max;
3985
3986         if (max > 0xffff)
3987             bits = 32;
3988         else if (max > 0xff)
3989             bits = 16;
3990         else
3991             bits = 8;
3992
3993         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3994 #ifdef USE_ITHREADS
3995         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3996         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3997         PAD_SETSV(cPADOPo->op_padix, swash);
3998         SvPADTMP_on(swash);
3999         SvREADONLY_on(swash);
4000 #else
4001         cSVOPo->op_sv = swash;
4002 #endif
4003         SvREFCNT_dec(listsv);
4004         SvREFCNT_dec(transv);
4005
4006         if (!del && havefinal && rlen)
4007             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4008                            newSVuv((UV)final), 0);
4009
4010         if (grows)
4011             o->op_private |= OPpTRANS_GROWS;
4012
4013         Safefree(tsave);
4014         Safefree(rsave);
4015
4016 #ifdef PERL_MAD
4017         op_getmad(expr,o,'e');
4018         op_getmad(repl,o,'r');
4019 #else
4020         op_free(expr);
4021         op_free(repl);
4022 #endif
4023         return o;
4024     }
4025
4026     tbl = (short*)PerlMemShared_calloc(
4027         (o->op_private & OPpTRANS_COMPLEMENT) &&
4028             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4029         sizeof(short));
4030     cPVOPo->op_pv = (char*)tbl;
4031     if (complement) {
4032         for (i = 0; i < (I32)tlen; i++)
4033             tbl[t[i]] = -1;
4034         for (i = 0, j = 0; i < 256; i++) {
4035             if (!tbl[i]) {
4036                 if (j >= (I32)rlen) {
4037                     if (del)
4038                         tbl[i] = -2;
4039                     else if (rlen)
4040                         tbl[i] = r[j-1];
4041                     else
4042                         tbl[i] = (short)i;
4043                 }
4044                 else {
4045                     if (i < 128 && r[j] >= 128)
4046                         grows = 1;
4047                     tbl[i] = r[j++];
4048                 }
4049             }
4050         }
4051         if (!del) {
4052             if (!rlen) {
4053                 j = rlen;
4054                 if (!squash)
4055                     o->op_private |= OPpTRANS_IDENTICAL;
4056             }
4057             else if (j >= (I32)rlen)
4058                 j = rlen - 1;
4059             else {
4060                 tbl =
4061                     (short *)
4062                     PerlMemShared_realloc(tbl,
4063                                           (0x101+rlen-j) * sizeof(short));
4064                 cPVOPo->op_pv = (char*)tbl;
4065             }
4066             tbl[0x100] = (short)(rlen - j);
4067             for (i=0; i < (I32)rlen - j; i++)
4068                 tbl[0x101+i] = r[j+i];
4069         }
4070     }
4071     else {
4072         if (!rlen && !del) {
4073             r = t; rlen = tlen;
4074             if (!squash)
4075                 o->op_private |= OPpTRANS_IDENTICAL;
4076         }
4077         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4078             o->op_private |= OPpTRANS_IDENTICAL;
4079         }
4080         for (i = 0; i < 256; i++)
4081             tbl[i] = -1;
4082         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4083             if (j >= (I32)rlen) {
4084                 if (del) {
4085                     if (tbl[t[i]] == -1)
4086                         tbl[t[i]] = -2;
4087                     continue;
4088                 }
4089                 --j;
4090             }
4091             if (tbl[t[i]] == -1) {
4092                 if (t[i] < 128 && r[j] >= 128)
4093                     grows = 1;
4094                 tbl[t[i]] = r[j];
4095             }
4096         }
4097     }
4098
4099     if(del && rlen == tlen) {
4100         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4101     } else if(rlen > tlen) {
4102         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4103     }
4104
4105     if (grows)
4106         o->op_private |= OPpTRANS_GROWS;
4107 #ifdef PERL_MAD
4108     op_getmad(expr,o,'e');
4109     op_getmad(repl,o,'r');
4110 #else
4111     op_free(expr);
4112     op_free(repl);
4113 #endif
4114
4115     return o;
4116 }
4117
4118 /*
4119 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4120
4121 Constructs, checks, and returns an op of any pattern matching type.
4122 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4123 and, shifted up eight bits, the eight bits of C<op_private>.
4124
4125 =cut
4126 */
4127
4128 OP *
4129 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4130 {
4131     dVAR;
4132     PMOP *pmop;
4133
4134     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4135
4136     NewOp(1101, pmop, 1, PMOP);
4137     pmop->op_type = (OPCODE)type;
4138     pmop->op_ppaddr = PL_ppaddr[type];
4139     pmop->op_flags = (U8)flags;
4140     pmop->op_private = (U8)(0 | (flags >> 8));
4141
4142     if (PL_hints & HINT_RE_TAINT)
4143         pmop->op_pmflags |= PMf_RETAINT;
4144     if (IN_LOCALE_COMPILETIME) {
4145         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4146     }
4147     else if ((! (PL_hints & HINT_BYTES))
4148                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4149              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4150     {
4151         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4152     }
4153     if (PL_hints & HINT_RE_FLAGS) {
4154         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4155          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4156         );
4157         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4158         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4159          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4160         );
4161         if (reflags && SvOK(reflags)) {
4162             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4163         }
4164     }
4165
4166
4167 #ifdef USE_ITHREADS
4168     assert(SvPOK(PL_regex_pad[0]));
4169     if (SvCUR(PL_regex_pad[0])) {
4170         /* Pop off the "packed" IV from the end.  */
4171         SV *const repointer_list = PL_regex_pad[0];
4172         const char *p = SvEND(repointer_list) - sizeof(IV);
4173         const IV offset = *((IV*)p);
4174
4175         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4176
4177         SvEND_set(repointer_list, p);
4178
4179         pmop->op_pmoffset = offset;
4180         /* This slot should be free, so assert this:  */
4181         assert(PL_regex_pad[offset] == &PL_sv_undef);
4182     } else {
4183         SV * const repointer = &PL_sv_undef;
4184         av_push(PL_regex_padav, repointer);
4185         pmop->op_pmoffset = av_len(PL_regex_padav);
4186         PL_regex_pad = AvARRAY(PL_regex_padav);
4187     }
4188 #endif
4189
4190     return CHECKOP(type, pmop);
4191 }
4192
4193 /* Given some sort of match op o, and an expression expr containing a
4194  * pattern, either compile expr into a regex and attach it to o (if it's
4195  * constant), or convert expr into a runtime regcomp op sequence (if it's
4196  * not)
4197  *
4198  * isreg indicates that the pattern is part of a regex construct, eg
4199  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4200  * split "pattern", which aren't. In the former case, expr will be a list
4201  * if the pattern contains more than one term (eg /a$b/) or if it contains
4202  * a replacement, ie s/// or tr///.
4203  */
4204
4205 OP *
4206 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4207 {
4208     dVAR;
4209     PMOP *pm;
4210     LOGOP *rcop;
4211     I32 repl_has_vars = 0;
4212     OP* repl = NULL;
4213     bool reglist;
4214
4215     PERL_ARGS_ASSERT_PMRUNTIME;
4216
4217     if (
4218         o->op_type == OP_SUBST
4219      || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4220     ) {
4221         /* last element in list is the replacement; pop it */
4222         OP* kid;
4223         repl = cLISTOPx(expr)->op_last;
4224         kid = cLISTOPx(expr)->op_first;
4225         while (kid->op_sibling != repl)
4226             kid = kid->op_sibling;
4227         kid->op_sibling = NULL;
4228         cLISTOPx(expr)->op_last = kid;
4229     }
4230
4231     if (isreg && expr->op_type == OP_LIST &&
4232         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4233     {
4234         /* convert single element list to element */
4235         OP* const oe = expr;
4236         expr = cLISTOPx(oe)->op_first->op_sibling;
4237         cLISTOPx(oe)->op_first->op_sibling = NULL;
4238         cLISTOPx(oe)->op_last = NULL;
4239         op_free(oe);
4240     }
4241
4242     if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4243         return pmtrans(o, expr, repl);
4244     }
4245
4246     reglist = isreg && expr->op_type == OP_LIST;
4247     if (reglist)
4248         op_null(expr);
4249
4250     PL_hints |= HINT_BLOCK_SCOPE;
4251     pm = (PMOP*)o;
4252
4253     if (expr->op_type == OP_CONST) {
4254         SV *pat = ((SVOP*)expr)->op_sv;
4255         U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4256
4257         if (o->op_flags & OPf_SPECIAL)
4258             pm_flags |= RXf_SPLIT;
4259
4260         if (DO_UTF8(pat)) {
4261             assert (SvUTF8(pat));
4262         } else if (SvUTF8(pat)) {
4263             /* Not doing UTF-8, despite what the SV says. Is this only if we're
4264                trapped in use 'bytes'?  */
4265             /* Make a copy of the octet sequence, but without the flag on, as
4266                the compiler now honours the SvUTF8 flag on pat.  */
4267             STRLEN len;
4268             const char *const p = SvPV(pat, len);
4269             pat = newSVpvn_flags(p, len, SVs_TEMP);
4270         }
4271
4272         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4273
4274 #ifdef PERL_MAD
4275         op_getmad(expr,(OP*)pm,'e');
4276 #else
4277         op_free(expr);
4278 #endif
4279     }
4280     else {
4281         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4282             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4283                             ? OP_REGCRESET
4284                             : OP_REGCMAYBE),0,expr);
4285
4286         NewOp(1101, rcop, 1, LOGOP);
4287         rcop->op_type = OP_REGCOMP;
4288         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4289         rcop->op_first = scalar(expr);
4290         rcop->op_flags |= OPf_KIDS
4291                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4292                             | (reglist ? OPf_STACKED : 0);
4293         rcop->op_private = 1;
4294         rcop->op_other = o;
4295         if (reglist)
4296             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4297
4298         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4299         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4300
4301         /* establish postfix order */
4302         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4303             LINKLIST(expr);
4304             rcop->op_next = expr;
4305             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4306         }
4307         else {
4308             rcop->op_next = LINKLIST(expr);
4309             expr->op_next = (OP*)rcop;
4310         }
4311
4312         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4313     }
4314
4315     if (repl) {
4316         OP *curop;
4317         if (pm->op_pmflags & PMf_EVAL) {
4318             curop = NULL;
4319             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4320                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4321         }
4322         else if (repl->op_type == OP_CONST)
4323             curop = repl;
4324         else {
4325             OP *lastop = NULL;
4326             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4327                 if (curop->op_type == OP_SCOPE
4328                         || curop->op_type == OP_LEAVE
4329                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4330                     if (curop->op_type == OP_GV) {
4331                         GV * const gv = cGVOPx_gv(curop);
4332                         repl_has_vars = 1;
4333                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4334                             break;
4335                     }
4336                     else if (curop->op_type == OP_RV2CV)
4337                         break;
4338                     else if (curop->op_type == OP_RV2SV ||
4339                              curop->op_type == OP_RV2AV ||
4340                              curop->op_type == OP_RV2HV ||
4341                              curop->op_type == OP_RV2GV) {
4342                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4343                             break;
4344                     }
4345                     else if (curop->op_type == OP_PADSV ||
4346                              curop->op_type == OP_PADAV ||
4347                              curop->op_type == OP_PADHV ||
4348                              curop->op_type == OP_PADANY)
4349                     {
4350                         repl_has_vars = 1;
4351                     }
4352                     else if (curop->op_type == OP_PUSHRE)
4353                         NOOP; /* Okay here, dangerous in newASSIGNOP */
4354                     else
4355                         break;
4356                 }
4357                 lastop = curop;
4358             }
4359         }
4360         if (curop == repl
4361             && !(repl_has_vars
4362                  && (!PM_GETRE(pm)
4363                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4364         {
4365             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4366             op_prepend_elem(o->op_type, scalar(repl), o);
4367         }
4368         else {
4369             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4370                 pm->op_pmflags |= PMf_MAYBE_CONST;
4371             }
4372             NewOp(1101, rcop, 1, LOGOP);
4373             rcop->op_type = OP_SUBSTCONT;
4374             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4375             rcop->op_first = scalar(repl);
4376             rcop->op_flags |= OPf_KIDS;
4377             rcop->op_private = 1;
4378             rcop->op_other = o;
4379
4380             /* establish postfix order */
4381             rcop->op_next = LINKLIST(repl);
4382             repl->op_next = (OP*)rcop;
4383
4384             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4385             assert(!(pm->op_pmflags & PMf_ONCE));
4386             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4387             rcop->op_next = 0;
4388         }
4389     }
4390
4391     return (OP*)pm;
4392 }
4393
4394 /*
4395 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4396
4397 Constructs, checks, and returns an op of any type that involves an
4398 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4399 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4400 takes ownership of one reference to it.
4401
4402 =cut
4403 */
4404
4405 OP *
4406 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4407 {
4408     dVAR;
4409     SVOP *svop;
4410
4411     PERL_ARGS_ASSERT_NEWSVOP;
4412
4413     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4414         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4415         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4416
4417     NewOp(1101, svop, 1, SVOP);
4418     svop->op_type = (OPCODE)type;
4419     svop->op_ppaddr = PL_ppaddr[type];
4420     svop->op_sv = sv;
4421     svop->op_next = (OP*)svop;
4422     svop->op_flags = (U8)flags;
4423     if (PL_opargs[type] & OA_RETSCALAR)
4424         scalar((OP*)svop);
4425     if (PL_opargs[type] & OA_TARGET)
4426         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4427     return CHECKOP(type, svop);
4428 }
4429
4430 #ifdef USE_ITHREADS
4431
4432 /*
4433 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4434
4435 Constructs, checks, and returns an op of any type that involves a
4436 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4437 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4438 is populated with I<sv>; this function takes ownership of one reference
4439 to it.
4440
4441 This function only exists if Perl has been compiled to use ithreads.
4442
4443 =cut
4444 */
4445
4446 OP *
4447 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4448 {
4449     dVAR;
4450     PADOP *padop;
4451
4452     PERL_ARGS_ASSERT_NEWPADOP;
4453
4454     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4455         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4456         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4457
4458     NewOp(1101, padop, 1, PADOP);
4459     padop->op_type = (OPCODE)type;
4460     padop->op_ppaddr = PL_ppaddr[type];
4461     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4462     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4463     PAD_SETSV(padop->op_padix, sv);
4464     assert(sv);
4465     SvPADTMP_on(sv);
4466     padop->op_next = (OP*)padop;
4467     padop->op_flags = (U8)flags;
4468     if (PL_opargs[type] & OA_RETSCALAR)
4469         scalar((OP*)padop);
4470     if (PL_opargs[type] & OA_TARGET)
4471         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4472     return CHECKOP(type, padop);
4473 }
4474
4475 #endif /* !USE_ITHREADS */
4476
4477 /*
4478 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4479
4480 Constructs, checks, and returns an op of any type that involves an
4481 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4482 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4483 reference; calling this function does not transfer ownership of any
4484 reference to it.
4485
4486 =cut
4487 */
4488
4489 OP *
4490 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4491 {
4492     dVAR;
4493
4494     PERL_ARGS_ASSERT_NEWGVOP;
4495
4496 #ifdef USE_ITHREADS
4497     GvIN_PAD_on(gv);
4498     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4499 #else
4500     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4501 #endif
4502 }
4503
4504 /*
4505 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4506
4507 Constructs, checks, and returns an op of any type that involves an
4508 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4509 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4510 must have been allocated using L</PerlMemShared_malloc>; the memory will
4511 be freed when the op is destroyed.
4512
4513 =cut
4514 */
4515
4516 OP *
4517 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4518 {
4519     dVAR;
4520     const bool utf8 = cBOOL(flags & SVf_UTF8);
4521     PVOP *pvop;
4522
4523     flags &= ~SVf_UTF8;
4524
4525     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4526         || type == OP_RUNCV
4527         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4528
4529     NewOp(1101, pvop, 1, PVOP);
4530     pvop->op_type = (OPCODE)type;
4531     pvop->op_ppaddr = PL_ppaddr[type];
4532     pvop->op_pv = pv;
4533     pvop->op_next = (OP*)pvop;
4534     pvop->op_flags = (U8)flags;
4535     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4536     if (PL_opargs[type] & OA_RETSCALAR)
4537         scalar((OP*)pvop);
4538     if (PL_opargs[type] & OA_TARGET)
4539         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4540     return CHECKOP(type, pvop);
4541 }
4542
4543 #ifdef PERL_MAD
4544 OP*
4545 #else
4546 void
4547 #endif
4548 Perl_package(pTHX_ OP *o)
4549 {
4550     dVAR;
4551     SV *const sv = cSVOPo->op_sv;
4552 #ifdef PERL_MAD
4553     OP *pegop;
4554 #endif
4555
4556     PERL_ARGS_ASSERT_PACKAGE;
4557
4558     SAVEGENERICSV(PL_curstash);
4559     save_item(PL_curstname);
4560
4561     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4562
4563     sv_setsv(PL_curstname, sv);
4564
4565     PL_hints |= HINT_BLOCK_SCOPE;
4566     PL_parser->copline = NOLINE;
4567     PL_parser->expect = XSTATE;
4568
4569 #ifndef PERL_MAD
4570     op_free(o);
4571 #else
4572     if (!PL_madskills) {
4573         op_free(o);
4574         return NULL;
4575     }
4576
4577     pegop = newOP(OP_NULL,0);
4578     op_getmad(o,pegop,'P');
4579     return pegop;
4580 #endif
4581 }
4582
4583 void
4584 Perl_package_version( pTHX_ OP *v )
4585 {
4586     dVAR;
4587     U32 savehints = PL_hints;
4588     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4589     PL_hints &= ~HINT_STRICT_VARS;
4590     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4591     PL_hints = savehints;
4592     op_free(v);
4593 }
4594
4595 #ifdef PERL_MAD
4596 OP*
4597 #else
4598 void
4599 #endif
4600 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4601 {
4602     dVAR;
4603     OP *pack;
4604     OP *imop;
4605     OP *veop;
4606 #ifdef PERL_MAD
4607     OP *pegop = newOP(OP_NULL,0);
4608 #endif
4609     SV *use_version = NULL;
4610
4611     PERL_ARGS_ASSERT_UTILIZE;
4612
4613     if (idop->op_type != OP_CONST)
4614         Perl_croak(aTHX_ "Module name must be constant");
4615
4616     if (PL_madskills)
4617         op_getmad(idop,pegop,'U');
4618
4619     veop = NULL;
4620
4621     if (version) {
4622         SV * const vesv = ((SVOP*)version)->op_sv;
4623
4624         if (PL_madskills)
4625             op_getmad(version,pegop,'V');
4626         if (!arg && !SvNIOKp(vesv)) {
4627             arg = version;
4628         }
4629         else {
4630             OP *pack;
4631             SV *meth;
4632
4633             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4634                 Perl_croak(aTHX_ "Version number must be a constant number");
4635
4636             /* Make copy of idop so we don't free it twice */
4637             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4638
4639             /* Fake up a method call to VERSION */
4640             meth = newSVpvs_share("VERSION");
4641             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4642                             op_append_elem(OP_LIST,
4643                                         op_prepend_elem(OP_LIST, pack, list(version)),
4644                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4645         }
4646     }
4647
4648     /* Fake up an import/unimport */
4649     if (arg && arg->op_type == OP_STUB) {
4650         if (PL_madskills)
4651             op_getmad(arg,pegop,'S');
4652         imop = arg;             /* no import on explicit () */
4653     }
4654     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4655         imop = NULL;            /* use 5.0; */
4656         if (aver)
4657             use_version = ((SVOP*)idop)->op_sv;
4658         else
4659             idop->op_private |= OPpCONST_NOVER;
4660     }
4661     else {
4662         SV *meth;
4663
4664         if (PL_madskills)
4665             op_getmad(arg,pegop,'A');
4666
4667         /* Make copy of idop so we don't free it twice */
4668         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4669
4670         /* Fake up a method call to import/unimport */
4671         meth = aver
4672             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4673         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4674                        op_append_elem(OP_LIST,
4675                                    op_prepend_elem(OP_LIST, pack, list(arg)),
4676                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4677     }
4678
4679     /* Fake up the BEGIN {}, which does its thing immediately. */
4680     newATTRSUB(floor,
4681         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4682         NULL,
4683         NULL,
4684         op_append_elem(OP_LINESEQ,
4685             op_append_elem(OP_LINESEQ,
4686                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4687                 newSTATEOP(0, NULL, veop)),
4688             newSTATEOP(0, NULL, imop) ));
4689
4690     if (use_version) {
4691         /* Enable the
4692          * feature bundle that corresponds to the required version. */
4693         use_version = sv_2mortal(new_version(use_version));
4694         S_enable_feature_bundle(aTHX_ use_version);
4695
4696         /* If a version >= 5.11.0 is requested, strictures are on by default! */
4697         if (vcmp(use_version,
4698                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4699             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4700                 PL_hints |= HINT_STRICT_REFS;
4701             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4702                 PL_hints |= HINT_STRICT_SUBS;
4703             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4704                 PL_hints |= HINT_STRICT_VARS;
4705         }
4706         /* otherwise they are off */
4707         else {
4708             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4709                 PL_hints &= ~HINT_STRICT_REFS;
4710             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4711                 PL_hints &= ~HINT_STRICT_SUBS;
4712             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4713                 PL_hints &= ~HINT_STRICT_VARS;
4714         }
4715     }
4716
4717     /* The "did you use incorrect case?" warning used to be here.
4718      * The problem is that on case-insensitive filesystems one
4719      * might get false positives for "use" (and "require"):
4720      * "use Strict" or "require CARP" will work.  This causes
4721      * portability problems for the script: in case-strict
4722      * filesystems the script will stop working.
4723      *
4724      * The "incorrect case" warning checked whether "use Foo"
4725      * imported "Foo" to your namespace, but that is wrong, too:
4726      * there is no requirement nor promise in the language that
4727      * a Foo.pm should or would contain anything in package "Foo".
4728      *
4729      * There is very little Configure-wise that can be done, either:
4730      * the case-sensitivity of the build filesystem of Perl does not
4731      * help in guessing the case-sensitivity of the runtime environment.
4732      */
4733
4734     PL_hints |= HINT_BLOCK_SCOPE;
4735     PL_parser->copline = NOLINE;
4736     PL_parser->expect = XSTATE;
4737     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4738     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4739         PL_cop_seqmax++;
4740
4741 #ifdef PERL_MAD
4742     if (!PL_madskills) {
4743         /* FIXME - don't allocate pegop if !PL_madskills */
4744         op_free(pegop);
4745         return NULL;
4746     }
4747     return pegop;
4748 #endif
4749 }
4750
4751 /*
4752 =head1 Embedding Functions
4753
4754 =for apidoc load_module
4755
4756 Loads the module whose name is pointed to by the string part of name.
4757 Note that the actual module name, not its filename, should be given.
4758 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4759 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4760 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4761 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4762 arguments can be used to specify arguments to the module's import()
4763 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4764 terminated with a final NULL pointer.  Note that this list can only
4765 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4766 Otherwise at least a single NULL pointer to designate the default
4767 import list is required.
4768
4769 The reference count for each specified C<SV*> parameter is decremented.
4770
4771 =cut */
4772
4773 void
4774 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4775 {
4776     va_list args;
4777
4778     PERL_ARGS_ASSERT_LOAD_MODULE;
4779
4780     va_start(args, ver);
4781     vload_module(flags, name, ver, &args);
4782     va_end(args);
4783 }
4784
4785 #ifdef PERL_IMPLICIT_CONTEXT
4786 void
4787 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4788 {
4789     dTHX;
4790     va_list args;
4791     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4792     va_start(args, ver);
4793     vload_module(flags, name, ver, &args);
4794     va_end(args);
4795 }
4796 #endif
4797
4798 void
4799 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4800 {
4801     dVAR;
4802     OP *veop, *imop;
4803     OP * const modname = newSVOP(OP_CONST, 0, name);
4804
4805     PERL_ARGS_ASSERT_VLOAD_MODULE;
4806
4807     modname->op_private |= OPpCONST_BARE;
4808     if (ver) {
4809         veop = newSVOP(OP_CONST, 0, ver);
4810     }
4811     else
4812         veop = NULL;
4813     if (flags & PERL_LOADMOD_NOIMPORT) {
4814         imop = sawparens(newNULLLIST());
4815     }
4816     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4817         imop = va_arg(*args, OP*);
4818     }
4819     else {
4820         SV *sv;
4821         imop = NULL;
4822         sv = va_arg(*args, SV*);
4823         while (sv) {
4824             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4825             sv = va_arg(*args, SV*);
4826         }
4827     }
4828
4829     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4830      * that it has a PL_parser to play with while doing that, and also
4831      * that it doesn't mess with any existing parser, by creating a tmp
4832      * new parser with lex_start(). This won't actually be used for much,
4833      * since pp_require() will create another parser for the real work. */
4834
4835     ENTER;
4836     SAVEVPTR(PL_curcop);
4837     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4838     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4839             veop, modname, imop);
4840     LEAVE;
4841 }
4842
4843 OP *
4844 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4845 {
4846     dVAR;
4847     OP *doop;
4848     GV *gv = NULL;
4849
4850     PERL_ARGS_ASSERT_DOFILE;
4851
4852     if (!force_builtin) {
4853         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4854         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4855             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4856             gv = gvp ? *gvp : NULL;
4857         }
4858     }
4859
4860     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4861         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4862                                op_append_elem(OP_LIST, term,
4863                                            scalar(newUNOP(OP_RV2CV, 0,
4864                                                           newGVOP(OP_GV, 0, gv))))));
4865     }
4866     else {
4867         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4868     }
4869     return doop;
4870 }
4871
4872 /*
4873 =head1 Optree construction
4874
4875 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4876
4877 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4878 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4879 be set automatically, and, shifted up eight bits, the eight bits of
4880 C<op_private>, except that the bit with value 1 or 2 is automatically
4881 set as required.  I<listval> and I<subscript> supply the parameters of
4882 the slice; they are consumed by this function and become part of the
4883 constructed op tree.
4884
4885 =cut
4886 */
4887
4888 OP *
4889 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4890 {
4891     return newBINOP(OP_LSLICE, flags,
4892             list(force_list(subscript)),
4893             list(force_list(listval)) );
4894 }
4895
4896 STATIC I32
4897 S_is_list_assignment(pTHX_ register const OP *o)
4898 {
4899     unsigned type;
4900     U8 flags;
4901
4902     if (!o)
4903         return TRUE;
4904
4905     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4906         o = cUNOPo->op_first;
4907