op.c

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