op.c

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