op.c

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