op.c

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