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