op.c

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