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