op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  13  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  14  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  15  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  16  * either way, as the saying is, if you follow me."  --the Gaffer
  17  */
  18
  19 /* This file contains the functions that create, manipulate and optimize
  20  * the OP structures that hold a compiled perl program.
  21  *
  22  * A Perl program is compiled into a tree of OPs. Each op contains
  23  * structural pointers (eg to its siblings and the next op in the
  24  * execution sequence), a pointer to the function that would execute the
  25  * op, plus any data specific to that op. For example, an OP_CONST op
  26  * points to the pp_const() function and to an SV containing the constant
  27  * value. When pp_const() is executed, its job is to push that SV onto the
  28  * stack.
  29  *
  30  * OPs are mainly created by the newFOO() functions, which are mainly
  31  * called from the parser (in perly.y) as the code is parsed. For example
  32  * the Perl code $a + $b * $c would cause the equivalent of the following
  33  * to be called (oversimplifying a bit):
  34  *
  35  *  newBINOP(OP_ADD, flags,
  36  *      newSVREF($a),
  37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  38  *  )
  39  *
  40  * Note that during the build of miniperl, a temporary copy of this file
  41  * is made, called opmini.c.
  42  */
  43
  44 /*
  45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  46
  47     A bottom-up pass
  48     A top-down pass
  49     An execution-order pass
  50
  51 The bottom-up pass is represented by all the "newOP" routines and
  52 the ck_ routines.  The bottom-upness is actually driven by yacc.
  53 So at the point that a ck_ routine fires, we have no idea what the
  54 context is, either upward in the syntax tree, or either forward or
  55 backward in the execution order.  (The bottom-up parser builds that
  56 part of the execution order it knows about, but if you follow the "next"
  57 links around, you'll find it's actually a closed loop through the
  58 top level node.
  59
  60 Whenever the bottom-up parser gets to a node that supplies context to
  61 its components, it invokes that portion of the top-down pass that applies
  62 to that part of the subtree (and marks the top node as processed, so
  63 if a node further up supplies context, it doesn't have to take the
  64 plunge again).  As a particular subcase of this, as the new node is
  65 built, it takes all the closed execution loops of its subcomponents
  66 and links them into a new closed loop for the higher level node.  But
  67 it's still not the real execution order.
  68
  69 The actual execution order is not known till we get a grammar reduction
  70 to a top-level unit like a subroutine or file that will be called by
  71 "name" rather than via a "next" pointer.  At that point, we can call
  72 into peep() to do that code's portion of the 3rd pass.  It has to be
  73 recursive, but it's recursive on basic blocks, not on tree nodes.
  74 */
  75
  76 /* To implement user lexical pragmas, there needs to be a way at run time to
  77    get the compile time state of %^H for that block.  Storing %^H in every
  78    block (or even COP) would be very expensive, so a different approach is
  79    taken.  The (running) state of %^H is serialised into a tree of HE-like
  80    structs.  Stores into %^H are chained onto the current leaf as a struct
  81    refcounted_he * with the key and the value.  Deletes from %^H are saved
  82    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  83    turned back into a regular HV by walking back up the tree from that point's
  84    leaf, ignoring any key you've already seen (placeholder or not), storing
  85    the rest into the HV structure, then removing the placeholders. Hence
  86    memory is only used to store the %^H deltas from the enclosing COP, rather
  87    than the entire %^H on each COP.
  88
  89    To cause actions on %^H to write out the serialisation records, it has
  90    magic type 'H'. This magic (itself) does nothing, but its presence causes
  91    the values to gain magic type 'h', which has entries for set and clear.
  92    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  93    record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
  94    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  95    it will be correctly restored when any inner compiling scope is exited.
  96 */
  97
  98 #include "EXTERN.h"
  99 #define PERL_IN_OP_C
 100 #include "perl.h"
 101 #include "keywords.h"
 102
 103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
 104
 105 #if defined(PL_OP_SLAB_ALLOC)
 106
 107 #ifdef PERL_DEBUG_READONLY_OPS
 108 #  define PERL_SLAB_SIZE 4096
 109 #  include <sys/mman.h>
 110 #endif
 111
 112 #ifndef PERL_SLAB_SIZE
 113 #define PERL_SLAB_SIZE 2048
 114 #endif
 115
 116 void *
 117 Perl_Slab_Alloc(pTHX_ size_t sz)
 118 {
 119     dVAR;
 120     /*
 121      * To make incrementing use count easy PL_OpSlab is an I32 *
 122      * To make inserting the link to slab PL_OpPtr is I32 **
 123      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
 124      * Add an overhead for pointer to slab and round up as a number of pointers
 125      */
 126     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
 127     if ((PL_OpSpace -= sz) < 0) {
 128 #ifdef PERL_DEBUG_READONLY_OPS
 129         /* We need to allocate chunk by chunk so that we can control the VM
 130            mapping */
 131         PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
 132                         MAP_ANON|MAP_PRIVATE, -1, 0);
 133
 134         DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 135                               (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
 136                               PL_OpPtr));
 137         if(PL_OpPtr == MAP_FAILED) {
 138             perror("mmap failed");
 139             abort();
 140         }
 141 #else
 142
 143         PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
 144 #endif
 145         if (!PL_OpPtr) {
 146             return NULL;
 147         }
 148         /* We reserve the 0'th I32 sized chunk as a use count */
 149         PL_OpSlab = (I32 *) PL_OpPtr;
 150         /* Reduce size by the use count word, and by the size we need.
 151          * Latter is to mimic the '-=' in the if() above
 152          */
 153         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 154         /* Allocation pointer starts at the top.
 155            Theory: because we build leaves before trunk allocating at end
 156            means that at run time access is cache friendly upward
 157          */
 158         PL_OpPtr += PERL_SLAB_SIZE;
 159
 160 #ifdef PERL_DEBUG_READONLY_OPS
 161         /* We remember this slab.  */
 162         /* This implementation isn't efficient, but it is simple. */
 163         PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
 164         PL_slabs[PL_slab_count++] = PL_OpSlab;
 165         DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
 166 #endif
 167     }
 168     assert( PL_OpSpace >= 0 );
 169     /* Move the allocation pointer down */
 170     PL_OpPtr   -= sz;
 171     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 172     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 173     (*PL_OpSlab)++;             /* Increment use count of slab */
 174     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 175     assert( *PL_OpSlab > 0 );
 176     return (void *)(PL_OpPtr + 1);
 177 }
 178
 179 #ifdef PERL_DEBUG_READONLY_OPS
 180 void
 181 Perl_pending_Slabs_to_ro(pTHX) {
 182     /* Turn all the allocated op slabs read only.  */
 183     U32 count = PL_slab_count;
 184     I32 **const slabs = PL_slabs;
 185
 186     /* Reset the array of pending OP slabs, as we're about to turn this lot
 187        read only. Also, do it ahead of the loop in case the warn triggers,
 188        and a warn handler has an eval */
 189
 190     PL_slabs = NULL;
 191     PL_slab_count = 0;
 192
 193     /* Force a new slab for any further allocation.  */
 194     PL_OpSpace = 0;
 195
 196     while (count--) {
 197         void *const start = slabs[count];
 198         const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
 199         if(mprotect(start, size, PROT_READ)) {
 200             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
 201                       start, (unsigned long) size, errno);
 202         }
 203     }
 204
 205     free(slabs);
 206 }
 207
 208 STATIC void
 209 S_Slab_to_rw(pTHX_ void *op)
 210 {
 211     I32 * const * const ptr = (I32 **) op;
 212     I32 * const slab = ptr[-1];
 213
 214     PERL_ARGS_ASSERT_SLAB_TO_RW;
 215
 216     assert( ptr-1 > (I32 **) slab );
 217     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 218     assert( *slab > 0 );
 219     if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
 220         Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
 221                   slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
 222     }
 223 }
 224
 225 OP *
 226 Perl_op_refcnt_inc(pTHX_ OP *o)
 227 {
 228     if(o) {
 229         Slab_to_rw(o);
 230         ++o->op_targ;
 231     }
 232     return o;
 233
 234 }
 235
 236 PADOFFSET
 237 Perl_op_refcnt_dec(pTHX_ OP *o)
 238 {
 239     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 240     Slab_to_rw(o);
 241     return --o->op_targ;
 242 }
 243 #else
 244 #  define Slab_to_rw(op)
 245 #endif
 246
 247 void
 248 Perl_Slab_Free(pTHX_ void *op)
 249 {
 250     I32 * const * const ptr = (I32 **) op;
 251     I32 * const slab = ptr[-1];
 252     PERL_ARGS_ASSERT_SLAB_FREE;
 253     assert( ptr-1 > (I32 **) slab );
 254     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 255     assert( *slab > 0 );
 256     Slab_to_rw(op);
 257     if (--(*slab) == 0) {
 258 #  ifdef NETWARE
 259 #    define PerlMemShared PerlMem
 260 #  endif
 261
 262 #ifdef PERL_DEBUG_READONLY_OPS
 263         U32 count = PL_slab_count;
 264         /* Need to remove this slab from our list of slabs */
 265         if (count) {
 266             while (count--) {
 267                 if (PL_slabs[count] == slab) {
 268                     dVAR;
 269                     /* Found it. Move the entry at the end to overwrite it.  */
 270                     DEBUG_m(PerlIO_printf(Perl_debug_log,
 271                                           "Deallocate %p by moving %p from %lu to %lu\n",
 272                                           PL_OpSlab,
 273                                           PL_slabs[PL_slab_count - 1],
 274                                           PL_slab_count, count));
 275                     PL_slabs[count] = PL_slabs[--PL_slab_count];
 276                     /* Could realloc smaller at this point, but probably not
 277                        worth it.  */
 278                     if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
 279                         perror("munmap failed");
 280                         abort();
 281                     }
 282                     break;
 283                 }
 284             }
 285         }
 286 #else
 287     PerlMemShared_free(slab);
 288 #endif
 289         if (slab == PL_OpSlab) {
 290             PL_OpSpace = 0;
 291         }
 292     }
 293 }
 294 #endif
 295 /*
 296  * In the following definition, the ", (OP*)0" is just to make the compiler
 297  * think the expression is of the right type: croak actually does a Siglongjmp.
 298  */
 299 #define CHECKOP(type,o) \
 300     ((PL_op_mask && PL_op_mask[type])                           \
 301      ? ( op_free((OP*)o),                                       \
 302          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 303          (OP*)0 )                                               \
 304      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 305
 306 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 307
 308 STATIC const char*
 309 S_gv_ename(pTHX_ GV *gv)
 310 {
 311     SV* const tmpsv = sv_newmortal();
 312
 313     PERL_ARGS_ASSERT_GV_ENAME;
 314
 315     gv_efullname3(tmpsv, gv, NULL);
 316     return SvPV_nolen_const(tmpsv);
 317 }
 318
 319 STATIC OP *
 320 S_no_fh_allowed(pTHX_ OP *o)
 321 {
 322     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 323
 324     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 325                  OP_DESC(o)));
 326     return o;
 327 }
 328
 329 STATIC OP *
 330 S_too_few_arguments(pTHX_ OP *o, const char *name)
 331 {
 332     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
 333
 334     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 335     return o;
 336 }
 337
 338 STATIC OP *
 339 S_too_many_arguments(pTHX_ OP *o, const char *name)
 340 {
 341     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
 342
 343     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 344     return o;
 345 }
 346
 347 STATIC void
 348 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 349 {
 350     PERL_ARGS_ASSERT_BAD_TYPE;
 351
 352     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 353                  (int)n, name, t, OP_DESC(kid)));
 354 }
 355
 356 STATIC void
 357 S_no_bareword_allowed(pTHX_ const OP *o)
 358 {
 359     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 360
 361     if (PL_madskills)
 362         return;         /* various ok barewords are hidden in extra OP_NULL */
 363     qerror(Perl_mess(aTHX_
 364                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 365                      SVfARG(cSVOPo_sv)));
 366 }
 367
 368 /* "register" allocation */
 369
 370 PADOFFSET
 371 Perl_allocmy(pTHX_ const char *const name)
 372 {
 373     dVAR;
 374     PADOFFSET off;
 375     const bool is_our = (PL_parser->in_my == KEY_our);
 376
 377     PERL_ARGS_ASSERT_ALLOCMY;
 378
 379     /* complain about "my $<special_var>" etc etc */
 380     if (*name &&
 381         !(is_our ||
 382           isALPHA(name[1]) ||
 383           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 384           (name[1] == '_' && (*name == '$' || name[2]))))
 385     {
 386         /* name[2] is true if strlen(name) > 2  */
 387         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 388             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
 389                               name[0], toCTRL(name[1]), name + 2,
 390                               PL_parser->in_my == KEY_state ? "state" : "my"));
 391         } else {
 392             yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
 393                               PL_parser->in_my == KEY_state ? "state" : "my"));
 394         }
 395     }
 396
 397     /* check for duplicate declaration */
 398     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 399
 400     if (PL_parser->in_my_stash && *name != '$') {
 401         yyerror(Perl_form(aTHX_
 402                     "Can't declare class for non-scalar %s in \"%s\"",
 403                      name,
 404                      is_our ? "our"
 405                             : PL_parser->in_my == KEY_state ? "state" : "my"));
 406     }
 407
 408     /* allocate a spare slot and store the name in that slot */
 409
 410     off = pad_add_name(name,
 411                     PL_parser->in_my_stash,
 412                     (is_our
 413                         /* $_ is always in main::, even with our */
 414                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 415                         : NULL
 416                     ),
 417                     0, /*  not fake */
 418                     PL_parser->in_my == KEY_state
 419     );
 420     /* anon sub prototypes contains state vars should always be cloned,
 421      * otherwise the state var would be shared between anon subs */
 422
 423     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 424         CvCLONE_on(PL_compcv);
 425
 426     return off;
 427 }
 428
 429 /* free the body of an op without examining its contents.
 430  * Always use this rather than FreeOp directly */
 431
 432 static void
 433 S_op_destroy(pTHX_ OP *o)
 434 {
 435     if (o->op_latefree) {
 436         o->op_latefreed = 1;
 437         return;
 438     }
 439     FreeOp(o);
 440 }
 441
 442 #ifdef USE_ITHREADS
 443 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 444 #else
 445 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 446 #endif
 447
 448 /* Destructor */
 449
 450 void
 451 Perl_op_free(pTHX_ OP *o)
 452 {
 453     dVAR;
 454     OPCODE type;
 455
 456     if (!o)
 457         return;
 458     if (o->op_latefreed) {
 459         if (o->op_latefree)
 460             return;
 461         goto do_free;
 462     }
 463
 464     type = o->op_type;
 465     if (o->op_private & OPpREFCOUNTED) {
 466         switch (type) {
 467         case OP_LEAVESUB:
 468         case OP_LEAVESUBLV:
 469         case OP_LEAVEEVAL:
 470         case OP_LEAVE:
 471         case OP_SCOPE:
 472         case OP_LEAVEWRITE:
 473             {
 474             PADOFFSET refcnt;
 475             OP_REFCNT_LOCK;
 476             refcnt = OpREFCNT_dec(o);
 477             OP_REFCNT_UNLOCK;
 478             if (refcnt) {
 479                 /* Need to find and remove any pattern match ops from the list
 480                    we maintain for reset().  */
 481                 find_and_forget_pmops(o);
 482                 return;
 483             }
 484             }
 485             break;
 486         default:
 487             break;
 488         }
 489     }
 490
 491     if (o->op_flags & OPf_KIDS) {
 492         register OP *kid, *nextkid;
 493         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 494             nextkid = kid->op_sibling; /* Get before next freeing kid */
 495             op_free(kid);
 496         }
 497     }
 498     if (type == OP_NULL)
 499         type = (OPCODE)o->op_targ;
 500
 501 #ifdef PERL_DEBUG_READONLY_OPS
 502     Slab_to_rw(o);
 503 #endif
 504
 505     /* COP* is not cleared by op_clear() so that we may track line
 506      * numbers etc even after null() */
 507     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 508         cop_free((COP*)o);
 509     }
 510
 511     op_clear(o);
 512     if (o->op_latefree) {
 513         o->op_latefreed = 1;
 514         return;
 515     }
 516   do_free:
 517     FreeOp(o);
 518 #ifdef DEBUG_LEAKING_SCALARS
 519     if (PL_op == o)
 520         PL_op = NULL;
 521 #endif
 522 }
 523
 524 void
 525 Perl_op_clear(pTHX_ OP *o)
 526 {
 527
 528     dVAR;
 529
 530     PERL_ARGS_ASSERT_OP_CLEAR;
 531
 532 #ifdef PERL_MAD
 533     /* if (o->op_madprop && o->op_madprop->mad_next)
 534        abort(); */
 535     /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
 536        "modification of a read only value" for a reason I can't fathom why.
 537        It's the "" stringification of $_, where $_ was set to '' in a foreach
 538        loop, but it defies simplification into a small test case.
 539        However, commenting them out has caused ext/List/Util/t/weak.t to fail
 540        the last test.  */
 541     /*
 542       mad_free(o->op_madprop);
 543       o->op_madprop = 0;
 544     */
 545 #endif
 546
 547  retry:
 548     switch (o->op_type) {
 549     case OP_NULL:       /* Was holding old type, if any. */
 550         if (PL_madskills && o->op_targ != OP_NULL) {
 551             o->op_type = o->op_targ;
 552             o->op_targ = 0;
 553             goto retry;
 554         }
 555     case OP_ENTEREVAL:  /* Was holding hints. */
 556         o->op_targ = 0;
 557         break;
 558     default:
 559         if (!(o->op_flags & OPf_REF)
 560             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 561             break;
 562         /* FALL THROUGH */
 563     case OP_GVSV:
 564     case OP_GV:
 565     case OP_AELEMFAST:
 566         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 567             /* not an OP_PADAV replacement */
 568 #ifdef USE_ITHREADS
 569             if (cPADOPo->op_padix > 0) {
 570                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 571                  * may still exist on the pad */
 572                 pad_swipe(cPADOPo->op_padix, TRUE);
 573                 cPADOPo->op_padix = 0;
 574             }
 575 #else
 576             SvREFCNT_dec(cSVOPo->op_sv);
 577             cSVOPo->op_sv = NULL;
 578 #endif
 579         }
 580         break;
 581     case OP_METHOD_NAMED:
 582     case OP_CONST:
 583         SvREFCNT_dec(cSVOPo->op_sv);
 584         cSVOPo->op_sv = NULL;
 585 #ifdef USE_ITHREADS
 586         /** Bug #15654
 587           Even if op_clear does a pad_free for the target of the op,
 588           pad_free doesn't actually remove the sv that exists in the pad;
 589           instead it lives on. This results in that it could be reused as
 590           a target later on when the pad was reallocated.
 591         **/
 592         if(o->op_targ) {
 593           pad_swipe(o->op_targ,1);
 594           o->op_targ = 0;
 595         }
 596 #endif
 597         break;
 598     case OP_GOTO:
 599     case OP_NEXT:
 600     case OP_LAST:
 601     case OP_REDO:
 602         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 603             break;
 604         /* FALL THROUGH */
 605     case OP_TRANS:
 606         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 607 #ifdef USE_ITHREADS
 608             if (cPADOPo->op_padix > 0) {
 609                 pad_swipe(cPADOPo->op_padix, TRUE);
 610                 cPADOPo->op_padix = 0;
 611             }
 612 #else
 613             SvREFCNT_dec(cSVOPo->op_sv);
 614             cSVOPo->op_sv = NULL;
 615 #endif
 616         }
 617         else {
 618             PerlMemShared_free(cPVOPo->op_pv);
 619             cPVOPo->op_pv = NULL;
 620         }
 621         break;
 622     case OP_SUBST:
 623         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 624         goto clear_pmop;
 625     case OP_PUSHRE:
 626 #ifdef USE_ITHREADS
 627         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 628             /* No GvIN_PAD_off here, because other references may still
 629              * exist on the pad */
 630             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 631         }
 632 #else
 633         SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
 634 #endif
 635         /* FALL THROUGH */
 636     case OP_MATCH:
 637     case OP_QR:
 638 clear_pmop:
 639         forget_pmop(cPMOPo, 1);
 640         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 641         /* we use the same protection as the "SAFE" version of the PM_ macros
 642          * here since sv_clean_all might release some PMOPs
 643          * after PL_regex_padav has been cleared
 644          * and the clearing of PL_regex_padav needs to
 645          * happen before sv_clean_all
 646          */
 647 #ifdef USE_ITHREADS
 648         if(PL_regex_pad) {        /* We could be in destruction */
 649             const IV offset = (cPMOPo)->op_pmoffset;
 650             ReREFCNT_dec(PM_GETRE(cPMOPo));
 651             PL_regex_pad[offset] = &PL_sv_undef;
 652             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 653                            sizeof(offset));
 654         }
 655 #else
 656         ReREFCNT_dec(PM_GETRE(cPMOPo));
 657         PM_SETRE(cPMOPo, NULL);
 658 #endif
 659
 660         break;
 661     }
 662
 663     if (o->op_targ > 0) {
 664         pad_free(o->op_targ);
 665         o->op_targ = 0;
 666     }
 667 }
 668
 669 STATIC void
 670 S_cop_free(pTHX_ COP* cop)
 671 {
 672     PERL_ARGS_ASSERT_COP_FREE;
 673
 674     CopLABEL_free(cop);
 675     CopFILE_free(cop);
 676     CopSTASH_free(cop);
 677     if (! specialWARN(cop->cop_warnings))
 678         PerlMemShared_free(cop->cop_warnings);
 679     Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
 680 }
 681
 682 STATIC void
 683 S_forget_pmop(pTHX_ PMOP *const o
 684 #ifdef USE_ITHREADS
 685               , U32 flags
 686 #endif
 687               )
 688 {
 689     HV * const pmstash = PmopSTASH(o);
 690
 691     PERL_ARGS_ASSERT_FORGET_PMOP;
 692
 693     if (pmstash && !SvIS_FREED(pmstash)) {
 694         MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
 695         if (mg) {
 696             PMOP **const array = (PMOP**) mg->mg_ptr;
 697             U32 count = mg->mg_len / sizeof(PMOP**);
 698             U32 i = count;
 699
 700             while (i--) {
 701                 if (array[i] == o) {
 702                     /* Found it. Move the entry at the end to overwrite it.  */
 703                     array[i] = array[--count];
 704                     mg->mg_len = count * sizeof(PMOP**);
 705                     /* Could realloc smaller at this point always, but probably
 706                        not worth it. Probably worth free()ing if we're the
 707                        last.  */
 708                     if(!count) {
 709                         Safefree(mg->mg_ptr);
 710                         mg->mg_ptr = NULL;
 711                     }
 712                     break;
 713                 }
 714             }
 715         }
 716     }
 717     if (PL_curpm == o)
 718         PL_curpm = NULL;
 719 #ifdef USE_ITHREADS
 720     if (flags)
 721         PmopSTASH_free(o);
 722 #endif
 723 }
 724
 725 STATIC void
 726 S_find_and_forget_pmops(pTHX_ OP *o)
 727 {
 728     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 729
 730     if (o->op_flags & OPf_KIDS) {
 731         OP *kid = cUNOPo->op_first;
 732         while (kid) {
 733             switch (kid->op_type) {
 734             case OP_SUBST:
 735             case OP_PUSHRE:
 736             case OP_MATCH:
 737             case OP_QR:
 738                 forget_pmop((PMOP*)kid, 0);
 739             }
 740             find_and_forget_pmops(kid);
 741             kid = kid->op_sibling;
 742         }
 743     }
 744 }
 745
 746 void
 747 Perl_op_null(pTHX_ OP *o)
 748 {
 749     dVAR;
 750
 751     PERL_ARGS_ASSERT_OP_NULL;
 752
 753     if (o->op_type == OP_NULL)
 754         return;
 755     if (!PL_madskills)
 756         op_clear(o);
 757     o->op_targ = o->op_type;
 758     o->op_type = OP_NULL;
 759     o->op_ppaddr = PL_ppaddr[OP_NULL];
 760 }
 761
 762 void
 763 Perl_op_refcnt_lock(pTHX)
 764 {
 765     dVAR;
 766     PERL_UNUSED_CONTEXT;
 767     OP_REFCNT_LOCK;
 768 }
 769
 770 void
 771 Perl_op_refcnt_unlock(pTHX)
 772 {
 773     dVAR;
 774     PERL_UNUSED_CONTEXT;
 775     OP_REFCNT_UNLOCK;
 776 }
 777
 778 /* Contextualizers */
 779
 780 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 781
 782 OP *
 783 Perl_linklist(pTHX_ OP *o)
 784 {
 785     OP *first;
 786
 787     PERL_ARGS_ASSERT_LINKLIST;
 788
 789     if (o->op_next)
 790         return o->op_next;
 791
 792     /* establish postfix order */
 793     first = cUNOPo->op_first;
 794     if (first) {
 795         register OP *kid;
 796         o->op_next = LINKLIST(first);
 797         kid = first;
 798         for (;;) {
 799             if (kid->op_sibling) {
 800                 kid->op_next = LINKLIST(kid->op_sibling);
 801                 kid = kid->op_sibling;
 802             } else {
 803                 kid->op_next = o;
 804                 break;
 805             }
 806         }
 807     }
 808     else
 809         o->op_next = o;
 810
 811     return o->op_next;
 812 }
 813
 814 OP *
 815 Perl_scalarkids(pTHX_ OP *o)
 816 {
 817     if (o && o->op_flags & OPf_KIDS) {
 818         OP *kid;
 819         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 820             scalar(kid);
 821     }
 822     return o;
 823 }
 824
 825 STATIC OP *
 826 S_scalarboolean(pTHX_ OP *o)
 827 {
 828     dVAR;
 829
 830     PERL_ARGS_ASSERT_SCALARBOOLEAN;
 831
 832     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 833         if (ckWARN(WARN_SYNTAX)) {
 834             const line_t oldline = CopLINE(PL_curcop);
 835
 836             if (PL_parser && PL_parser->copline != NOLINE)
 837                 CopLINE_set(PL_curcop, PL_parser->copline);
 838             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 839             CopLINE_set(PL_curcop, oldline);
 840         }
 841     }
 842     return scalar(o);
 843 }
 844
 845 OP *
 846 Perl_scalar(pTHX_ OP *o)
 847 {
 848     dVAR;
 849     OP *kid;
 850
 851     /* assumes no premature commitment */
 852     if (!o || (PL_parser && PL_parser->error_count)
 853          || (o->op_flags & OPf_WANT)
 854          || o->op_type == OP_RETURN)
 855     {
 856         return o;
 857     }
 858
 859     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 860
 861     switch (o->op_type) {
 862     case OP_REPEAT:
 863         scalar(cBINOPo->op_first);
 864         break;
 865     case OP_OR:
 866     case OP_AND:
 867     case OP_COND_EXPR:
 868         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 869             scalar(kid);
 870         break;
 871     case OP_SPLIT:
 872         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 873             if (!kPMOP->op_pmreplrootu.op_pmreplroot)
 874                 deprecate_old("implicit split to @_");
 875         }
 876         /* FALL THROUGH */
 877     case OP_MATCH:
 878     case OP_QR:
 879     case OP_SUBST:
 880     case OP_NULL:
 881     default:
 882         if (o->op_flags & OPf_KIDS) {
 883             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 884                 scalar(kid);
 885         }
 886         break;
 887     case OP_LEAVE:
 888     case OP_LEAVETRY:
 889         kid = cLISTOPo->op_first;
 890         scalar(kid);
 891         while ((kid = kid->op_sibling)) {
 892             if (kid->op_sibling)
 893                 scalarvoid(kid);
 894             else
 895                 scalar(kid);
 896         }
 897         PL_curcop = &PL_compiling;
 898         break;
 899     case OP_SCOPE:
 900     case OP_LINESEQ:
 901     case OP_LIST:
 902         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 903             if (kid->op_sibling)
 904                 scalarvoid(kid);
 905             else
 906                 scalar(kid);
 907         }
 908         PL_curcop = &PL_compiling;
 909         break;
 910     case OP_SORT:
 911         if (ckWARN(WARN_VOID))
 912             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 913     }
 914     return o;
 915 }
 916
 917 OP *
 918 Perl_scalarvoid(pTHX_ OP *o)
 919 {
 920     dVAR;
 921     OP *kid;
 922     const char* useless = NULL;
 923     SV* sv;
 924     U8 want;
 925
 926     PERL_ARGS_ASSERT_SCALARVOID;
 927
 928     /* trailing mad null ops don't count as "there" for void processing */
 929     if (PL_madskills &&
 930         o->op_type != OP_NULL &&
 931         o->op_sibling &&
 932         o->op_sibling->op_type == OP_NULL)
 933     {
 934         OP *sib;
 935         for (sib = o->op_sibling;
 936                 sib && sib->op_type == OP_NULL;
 937                 sib = sib->op_sibling) ;
 938
 939         if (!sib)
 940             return o;
 941     }
 942
 943     if (o->op_type == OP_NEXTSTATE
 944         || o->op_type == OP_DBSTATE
 945         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 946                                       || o->op_targ == OP_DBSTATE)))
 947         PL_curcop = (COP*)o;            /* for warning below */
 948
 949     /* assumes no premature commitment */
 950     want = o->op_flags & OPf_WANT;
 951     if ((want && want != OPf_WANT_SCALAR)
 952          || (PL_parser && PL_parser->error_count)
 953          || o->op_type == OP_RETURN)
 954     {
 955         return o;
 956     }
 957
 958     if ((o->op_private & OPpTARGET_MY)
 959         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 960     {
 961         return scalar(o);                       /* As if inside SASSIGN */
 962     }
 963
 964     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 965
 966     switch (o->op_type) {
 967     default:
 968         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 969             break;
 970         /* FALL THROUGH */
 971     case OP_REPEAT:
 972         if (o->op_flags & OPf_STACKED)
 973             break;
 974         goto func_ops;
 975     case OP_SUBSTR:
 976         if (o->op_private == 4)
 977             break;
 978         /* FALL THROUGH */
 979     case OP_GVSV:
 980     case OP_WANTARRAY:
 981     case OP_GV:
 982     case OP_SMARTMATCH:
 983     case OP_PADSV:
 984     case OP_PADAV:
 985     case OP_PADHV:
 986     case OP_PADANY:
 987     case OP_AV2ARYLEN:
 988     case OP_REF:
 989     case OP_REFGEN:
 990     case OP_SREFGEN:
 991     case OP_DEFINED:
 992     case OP_HEX:
 993     case OP_OCT:
 994     case OP_LENGTH:
 995     case OP_VEC:
 996     case OP_INDEX:
 997     case OP_RINDEX:
 998     case OP_SPRINTF:
 999     case OP_AELEM:
1000     case OP_AELEMFAST:
1001     case OP_ASLICE:
1002     case OP_HELEM:
1003     case OP_HSLICE:
1004     case OP_UNPACK:
1005     case OP_PACK:
1006     case OP_JOIN:
1007     case OP_LSLICE:
1008     case OP_ANONLIST:
1009     case OP_ANONHASH:
1010     case OP_SORT:
1011     case OP_REVERSE:
1012     case OP_RANGE:
1013     case OP_FLIP:
1014     case OP_FLOP:
1015     case OP_CALLER:
1016     case OP_FILENO:
1017     case OP_EOF:
1018     case OP_TELL:
1019     case OP_GETSOCKNAME:
1020     case OP_GETPEERNAME:
1021     case OP_READLINK:
1022     case OP_TELLDIR:
1023     case OP_GETPPID:
1024     case OP_GETPGRP:
1025     case OP_GETPRIORITY:
1026     case OP_TIME:
1027     case OP_TMS:
1028     case OP_LOCALTIME:
1029     case OP_GMTIME:
1030     case OP_GHBYNAME:
1031     case OP_GHBYADDR:
1032     case OP_GHOSTENT:
1033     case OP_GNBYNAME:
1034     case OP_GNBYADDR:
1035     case OP_GNETENT:
1036     case OP_GPBYNAME:
1037     case OP_GPBYNUMBER:
1038     case OP_GPROTOENT:
1039     case OP_GSBYNAME:
1040     case OP_GSBYPORT:
1041     case OP_GSERVENT:
1042     case OP_GPWNAM:
1043     case OP_GPWUID:
1044     case OP_GGRNAM:
1045     case OP_GGRGID:
1046     case OP_GETLOGIN:
1047     case OP_PROTOTYPE:
1048       func_ops:
1049         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1050             /* Otherwise it's "Useless use of grep iterator" */
1051             useless = OP_DESC(o);
1052         break;
1053
1054     case OP_NOT:
1055        kid = cUNOPo->op_first;
1056        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1057            kid->op_type != OP_TRANS) {
1058                 goto func_ops;
1059        }
1060        useless = "negative pattern binding (!~)";
1061        break;
1062
1063     case OP_RV2GV:
1064     case OP_RV2SV:
1065     case OP_RV2AV:
1066     case OP_RV2HV:
1067         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1068                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1069             useless = "a variable";
1070         break;
1071
1072     case OP_CONST:
1073         sv = cSVOPo_sv;
1074         if (cSVOPo->op_private & OPpCONST_STRICT)
1075             no_bareword_allowed(o);
1076         else {
1077             if (ckWARN(WARN_VOID)) {
1078                 SV* msv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1079                 useless = SvPV_nolen(msv);
1080                 if (o->op_private & OPpCONST_ARYBASE)
1081                     useless = NULL;
1082                 /* don't warn on optimised away booleans, eg
1083                  * use constant Foo, 5; Foo || print; */
1084                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1085                     useless = NULL;
1086                 /* the constants 0 and 1 are permitted as they are
1087                    conventionally used as dummies in constructs like
1088                         1 while some_condition_with_side_effects;  */
1089                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1090                     useless = NULL;
1091                 else if (SvPOK(sv)) {
1092                   /* perl4's way of mixing documentation and code
1093                      (before the invention of POD) was based on a
1094                      trick to mix nroff and perl code. The trick was
1095                      built upon these three nroff macros being used in
1096                      void context. The pink camel has the details in
1097                      the script wrapman near page 319. */
1098                     const char * const maybe_macro = SvPVX_const(sv);
1099                     if (strnEQ(maybe_macro, "di", 2) ||
1100                         strnEQ(maybe_macro, "ds", 2) ||
1101                         strnEQ(maybe_macro, "ig", 2))
1102                             useless = NULL;
1103                 }
1104             }
1105         }
1106         op_null(o);             /* don't execute or even remember it */
1107         break;
1108
1109     case OP_POSTINC:
1110         o->op_type = OP_PREINC;         /* pre-increment is faster */
1111         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1112         break;
1113
1114     case OP_POSTDEC:
1115         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1116         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1117         break;
1118
1119     case OP_I_POSTINC:
1120         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1121         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1122         break;
1123
1124     case OP_I_POSTDEC:
1125         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1126         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1127         break;
1128
1129     case OP_OR:
1130     case OP_AND:
1131     case OP_DOR:
1132     case OP_COND_EXPR:
1133     case OP_ENTERGIVEN:
1134     case OP_ENTERWHEN:
1135         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1136             scalarvoid(kid);
1137         break;
1138
1139     case OP_NULL:
1140         if (o->op_flags & OPf_STACKED)
1141             break;
1142         /* FALL THROUGH */
1143     case OP_NEXTSTATE:
1144     case OP_DBSTATE:
1145     case OP_ENTERTRY:
1146     case OP_ENTER:
1147         if (!(o->op_flags & OPf_KIDS))
1148             break;
1149         /* FALL THROUGH */
1150     case OP_SCOPE:
1151     case OP_LEAVE:
1152     case OP_LEAVETRY:
1153     case OP_LEAVELOOP:
1154     case OP_LINESEQ:
1155     case OP_LIST:
1156     case OP_LEAVEGIVEN:
1157     case OP_LEAVEWHEN:
1158         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1159             scalarvoid(kid);
1160         break;
1161     case OP_ENTEREVAL:
1162         scalarkids(o);
1163         break;
1164     case OP_REQUIRE:
1165         /* all requires must return a boolean value */
1166         o->op_flags &= ~OPf_WANT;
1167         /* FALL THROUGH */
1168     case OP_SCALAR:
1169         return scalar(o);
1170     case OP_SPLIT:
1171         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1172             if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1173                 deprecate_old("implicit split to @_");
1174         }
1175         break;
1176     }
1177     if (useless && ckWARN(WARN_VOID))
1178         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1179     return o;
1180 }
1181
1182 OP *
1183 Perl_listkids(pTHX_ OP *o)
1184 {
1185     if (o && o->op_flags & OPf_KIDS) {
1186         OP *kid;
1187         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1188             list(kid);
1189     }
1190     return o;
1191 }
1192
1193 OP *
1194 Perl_list(pTHX_ OP *o)
1195 {
1196     dVAR;
1197     OP *kid;
1198
1199     /* assumes no premature commitment */
1200     if (!o || (o->op_flags & OPf_WANT)
1201          || (PL_parser && PL_parser->error_count)
1202          || o->op_type == OP_RETURN)
1203     {
1204         return o;
1205     }
1206
1207     if ((o->op_private & OPpTARGET_MY)
1208         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1209     {
1210         return o;                               /* As if inside SASSIGN */
1211     }
1212
1213     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1214
1215     switch (o->op_type) {
1216     case OP_FLOP:
1217     case OP_REPEAT:
1218         list(cBINOPo->op_first);
1219         break;
1220     case OP_OR:
1221     case OP_AND:
1222     case OP_COND_EXPR:
1223         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1224             list(kid);
1225         break;
1226     default:
1227     case OP_MATCH:
1228     case OP_QR:
1229     case OP_SUBST:
1230     case OP_NULL:
1231         if (!(o->op_flags & OPf_KIDS))
1232             break;
1233         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1234             list(cBINOPo->op_first);
1235             return gen_constant_list(o);
1236         }
1237     case OP_LIST:
1238         listkids(o);
1239         break;
1240     case OP_LEAVE:
1241     case OP_LEAVETRY:
1242         kid = cLISTOPo->op_first;
1243         list(kid);
1244         while ((kid = kid->op_sibling)) {
1245             if (kid->op_sibling)
1246                 scalarvoid(kid);
1247             else
1248                 list(kid);
1249         }
1250         PL_curcop = &PL_compiling;
1251         break;
1252     case OP_SCOPE:
1253     case OP_LINESEQ:
1254         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1255             if (kid->op_sibling)
1256                 scalarvoid(kid);
1257             else
1258                 list(kid);
1259         }
1260         PL_curcop = &PL_compiling;
1261         break;
1262     case OP_REQUIRE:
1263         /* all requires must return a boolean value */
1264         o->op_flags &= ~OPf_WANT;
1265         return scalar(o);
1266     }
1267     return o;
1268 }
1269
1270 OP *
1271 Perl_scalarseq(pTHX_ OP *o)
1272 {
1273     dVAR;
1274     if (o) {
1275         const OPCODE type = o->op_type;
1276
1277         if (type == OP_LINESEQ || type == OP_SCOPE ||
1278             type == OP_LEAVE || type == OP_LEAVETRY)
1279         {
1280             OP *kid;
1281             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1282                 if (kid->op_sibling) {
1283                     scalarvoid(kid);
1284                 }
1285             }
1286             PL_curcop = &PL_compiling;
1287         }
1288         o->op_flags &= ~OPf_PARENS;
1289         if (PL_hints & HINT_BLOCK_SCOPE)
1290             o->op_flags |= OPf_PARENS;
1291     }
1292     else
1293         o = newOP(OP_STUB, 0);
1294     return o;
1295 }
1296
1297 STATIC OP *
1298 S_modkids(pTHX_ OP *o, I32 type)
1299 {
1300     if (o && o->op_flags & OPf_KIDS) {
1301         OP *kid;
1302         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1303             mod(kid, type);
1304     }
1305     return o;
1306 }
1307
1308 /* Propagate lvalue ("modifiable") context to an op and its children.
1309  * 'type' represents the context type, roughly based on the type of op that
1310  * would do the modifying, although local() is represented by OP_NULL.
1311  * It's responsible for detecting things that can't be modified,  flag
1312  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1313  * might have to vivify a reference in $x), and so on.
1314  *
1315  * For example, "$a+1 = 2" would cause mod() to be called with o being
1316  * OP_ADD and type being OP_SASSIGN, and would output an error.
1317  */
1318
1319 OP *
1320 Perl_mod(pTHX_ OP *o, I32 type)
1321 {
1322     dVAR;
1323     OP *kid;
1324     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1325     int localize = -1;
1326
1327     if (!o || (PL_parser && PL_parser->error_count))
1328         return o;
1329
1330     if ((o->op_private & OPpTARGET_MY)
1331         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1332     {
1333         return o;
1334     }
1335
1336     switch (o->op_type) {
1337     case OP_UNDEF:
1338         localize = 0;
1339         PL_modcount++;
1340         return o;
1341     case OP_CONST:
1342         if (!(o->op_private & OPpCONST_ARYBASE))
1343             goto nomod;
1344         localize = 0;
1345         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1346             CopARYBASE_set(&PL_compiling,
1347                            (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1348             PL_eval_start = 0;
1349         }
1350         else if (!type) {
1351             SAVECOPARYBASE(&PL_compiling);
1352             CopARYBASE_set(&PL_compiling, 0);
1353         }
1354         else if (type == OP_REFGEN)
1355             goto nomod;
1356         else
1357             Perl_croak(aTHX_ "That use of $[ is unsupported");
1358         break;
1359     case OP_STUB:
1360         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1361             break;
1362         goto nomod;
1363     case OP_ENTERSUB:
1364         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1365             !(o->op_flags & OPf_STACKED)) {
1366             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1367             /* The default is to set op_private to the number of children,
1368                which for a UNOP such as RV2CV is always 1. And w're using
1369                the bit for a flag in RV2CV, so we need it clear.  */
1370             o->op_private &= ~1;
1371             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1372             assert(cUNOPo->op_first->op_type == OP_NULL);
1373             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1374             break;
1375         }
1376         else if (o->op_private & OPpENTERSUB_NOMOD)
1377             return o;
1378         else {                          /* lvalue subroutine call */
1379             o->op_private |= OPpLVAL_INTRO;
1380             PL_modcount = RETURN_UNLIMITED_NUMBER;
1381             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1382                 /* Backward compatibility mode: */
1383                 o->op_private |= OPpENTERSUB_INARGS;
1384                 break;
1385             }
1386             else {                      /* Compile-time error message: */
1387                 OP *kid = cUNOPo->op_first;
1388                 CV *cv;
1389                 OP *okid;
1390
1391                 if (kid->op_type != OP_PUSHMARK) {
1392                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1393                         Perl_croak(aTHX_
1394                                 "panic: unexpected lvalue entersub "
1395                                 "args: type/targ %ld:%"UVuf,
1396                                 (long)kid->op_type, (UV)kid->op_targ);
1397                     kid = kLISTOP->op_first;
1398                 }
1399                 while (kid->op_sibling)
1400                     kid = kid->op_sibling;
1401                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1402                     /* Indirect call */
1403                     if (kid->op_type == OP_METHOD_NAMED
1404                         || kid->op_type == OP_METHOD)
1405                     {
1406                         UNOP *newop;
1407
1408                         NewOp(1101, newop, 1, UNOP);
1409                         newop->op_type = OP_RV2CV;
1410                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1411                         newop->op_first = NULL;
1412                         newop->op_next = (OP*)newop;
1413                         kid->op_sibling = (OP*)newop;
1414                         newop->op_private |= OPpLVAL_INTRO;
1415                         newop->op_private &= ~1;
1416                         break;
1417                     }
1418
1419                     if (kid->op_type != OP_RV2CV)
1420                         Perl_croak(aTHX_
1421                                    "panic: unexpected lvalue entersub "
1422                                    "entry via type/targ %ld:%"UVuf,
1423                                    (long)kid->op_type, (UV)kid->op_targ);
1424                     kid->op_private |= OPpLVAL_INTRO;
1425                     break;      /* Postpone until runtime */
1426                 }
1427
1428                 okid = kid;
1429                 kid = kUNOP->op_first;
1430                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1431                     kid = kUNOP->op_first;
1432                 if (kid->op_type == OP_NULL)
1433                     Perl_croak(aTHX_
1434                                "Unexpected constant lvalue entersub "
1435                                "entry via type/targ %ld:%"UVuf,
1436                                (long)kid->op_type, (UV)kid->op_targ);
1437                 if (kid->op_type != OP_GV) {
1438                     /* Restore RV2CV to check lvalueness */
1439                   restore_2cv:
1440                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1441                         okid->op_next = kid->op_next;
1442                         kid->op_next = okid;
1443                     }
1444                     else
1445                         okid->op_next = NULL;
1446                     okid->op_type = OP_RV2CV;
1447                     okid->op_targ = 0;
1448                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1449                     okid->op_private |= OPpLVAL_INTRO;
1450                     okid->op_private &= ~1;
1451                     break;
1452                 }
1453
1454                 cv = GvCV(kGVOP_gv);
1455                 if (!cv)
1456                     goto restore_2cv;
1457                 if (CvLVALUE(cv))
1458                     break;
1459             }
1460         }
1461         /* FALL THROUGH */
1462     default:
1463       nomod:
1464         /* grep, foreach, subcalls, refgen */
1465         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1466             break;
1467         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1468                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1469                       ? "do block"
1470                       : (o->op_type == OP_ENTERSUB
1471                         ? "non-lvalue subroutine call"
1472                         : OP_DESC(o))),
1473                      type ? PL_op_desc[type] : "local"));
1474         return o;
1475
1476     case OP_PREINC:
1477     case OP_PREDEC:
1478     case OP_POW:
1479     case OP_MULTIPLY:
1480     case OP_DIVIDE:
1481     case OP_MODULO:
1482     case OP_REPEAT:
1483     case OP_ADD:
1484     case OP_SUBTRACT:
1485     case OP_CONCAT:
1486     case OP_LEFT_SHIFT:
1487     case OP_RIGHT_SHIFT:
1488     case OP_BIT_AND:
1489     case OP_BIT_XOR:
1490     case OP_BIT_OR:
1491     case OP_I_MULTIPLY:
1492     case OP_I_DIVIDE:
1493     case OP_I_MODULO:
1494     case OP_I_ADD:
1495     case OP_I_SUBTRACT:
1496         if (!(o->op_flags & OPf_STACKED))
1497             goto nomod;
1498         PL_modcount++;
1499         break;
1500
1501     case OP_COND_EXPR:
1502         localize = 1;
1503         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1504             mod(kid, type);
1505         break;
1506
1507     case OP_RV2AV:
1508     case OP_RV2HV:
1509         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1510            PL_modcount = RETURN_UNLIMITED_NUMBER;
1511             return o;           /* Treat \(@foo) like ordinary list. */
1512         }
1513         /* FALL THROUGH */
1514     case OP_RV2GV:
1515         if (scalar_mod_type(o, type))
1516             goto nomod;
1517         ref(cUNOPo->op_first, o->op_type);
1518         /* FALL THROUGH */
1519     case OP_ASLICE:
1520     case OP_HSLICE:
1521         if (type == OP_LEAVESUBLV)
1522             o->op_private |= OPpMAYBE_LVSUB;
1523         localize = 1;
1524         /* FALL THROUGH */
1525     case OP_AASSIGN:
1526     case OP_NEXTSTATE:
1527     case OP_DBSTATE:
1528        PL_modcount = RETURN_UNLIMITED_NUMBER;
1529         break;
1530     case OP_RV2SV:
1531         ref(cUNOPo->op_first, o->op_type);
1532         localize = 1;
1533         /* FALL THROUGH */
1534     case OP_GV:
1535     case OP_AV2ARYLEN:
1536         PL_hints |= HINT_BLOCK_SCOPE;
1537     case OP_SASSIGN:
1538     case OP_ANDASSIGN:
1539     case OP_ORASSIGN:
1540     case OP_DORASSIGN:
1541         PL_modcount++;
1542         break;
1543
1544     case OP_AELEMFAST:
1545         localize = -1;
1546         PL_modcount++;
1547         break;
1548
1549     case OP_PADAV:
1550     case OP_PADHV:
1551        PL_modcount = RETURN_UNLIMITED_NUMBER;
1552         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1553             return o;           /* Treat \(@foo) like ordinary list. */
1554         if (scalar_mod_type(o, type))
1555             goto nomod;
1556         if (type == OP_LEAVESUBLV)
1557             o->op_private |= OPpMAYBE_LVSUB;
1558         /* FALL THROUGH */
1559     case OP_PADSV:
1560         PL_modcount++;
1561         if (!type) /* local() */
1562             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1563                  PAD_COMPNAME_PV(o->op_targ));
1564         break;
1565
1566     case OP_PUSHMARK:
1567         localize = 0;
1568         break;
1569
1570     case OP_KEYS:
1571         if (type != OP_SASSIGN)
1572             goto nomod;
1573         goto lvalue_func;
1574     case OP_SUBSTR:
1575         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1576             goto nomod;
1577         /* FALL THROUGH */
1578     case OP_POS:
1579     case OP_VEC:
1580         if (type == OP_LEAVESUBLV)
1581             o->op_private |= OPpMAYBE_LVSUB;
1582       lvalue_func:
1583         pad_free(o->op_targ);
1584         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1585         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1586         if (o->op_flags & OPf_KIDS)
1587             mod(cBINOPo->op_first->op_sibling, type);
1588         break;
1589
1590     case OP_AELEM:
1591     case OP_HELEM:
1592         ref(cBINOPo->op_first, o->op_type);
1593         if (type == OP_ENTERSUB &&
1594              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1595             o->op_private |= OPpLVAL_DEFER;
1596         if (type == OP_LEAVESUBLV)
1597             o->op_private |= OPpMAYBE_LVSUB;
1598         localize = 1;
1599         PL_modcount++;
1600         break;
1601
1602     case OP_SCOPE:
1603     case OP_LEAVE:
1604     case OP_ENTER:
1605     case OP_LINESEQ:
1606         localize = 0;
1607         if (o->op_flags & OPf_KIDS)
1608             mod(cLISTOPo->op_last, type);
1609         break;
1610
1611     case OP_NULL:
1612         localize = 0;
1613         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1614             goto nomod;
1615         else if (!(o->op_flags & OPf_KIDS))
1616             break;
1617         if (o->op_targ != OP_LIST) {
1618             mod(cBINOPo->op_first, type);
1619             break;
1620         }
1621         /* FALL THROUGH */
1622     case OP_LIST:
1623         localize = 0;
1624         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1625             mod(kid, type);
1626         break;
1627
1628     case OP_RETURN:
1629         if (type != OP_LEAVESUBLV)
1630             goto nomod;
1631         break; /* mod()ing was handled by ck_return() */
1632     }
1633
1634     /* [20011101.069] File test operators interpret OPf_REF to mean that
1635        their argument is a filehandle; thus \stat(".") should not set
1636        it. AMS 20011102 */
1637     if (type == OP_REFGEN &&
1638         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1639         return o;
1640
1641     if (type != OP_LEAVESUBLV)
1642         o->op_flags |= OPf_MOD;
1643
1644     if (type == OP_AASSIGN || type == OP_SASSIGN)
1645         o->op_flags |= OPf_SPECIAL|OPf_REF;
1646     else if (!type) { /* local() */
1647         switch (localize) {
1648         case 1:
1649             o->op_private |= OPpLVAL_INTRO;
1650             o->op_flags &= ~OPf_SPECIAL;
1651             PL_hints |= HINT_BLOCK_SCOPE;
1652             break;
1653         case 0:
1654             break;
1655         case -1:
1656             if (ckWARN(WARN_SYNTAX)) {
1657                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1658                     "Useless localization of %s", OP_DESC(o));
1659             }
1660         }
1661     }
1662     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1663              && type != OP_LEAVESUBLV)
1664         o->op_flags |= OPf_REF;
1665     return o;
1666 }
1667
1668 STATIC bool
1669 S_scalar_mod_type(const OP *o, I32 type)
1670 {
1671     PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1672
1673     switch (type) {
1674     case OP_SASSIGN:
1675         if (o->op_type == OP_RV2GV)
1676             return FALSE;
1677         /* FALL THROUGH */
1678     case OP_PREINC:
1679     case OP_PREDEC:
1680     case OP_POSTINC:
1681     case OP_POSTDEC:
1682     case OP_I_PREINC:
1683     case OP_I_PREDEC:
1684     case OP_I_POSTINC:
1685     case OP_I_POSTDEC:
1686     case OP_POW:
1687     case OP_MULTIPLY:
1688     case OP_DIVIDE:
1689     case OP_MODULO:
1690     case OP_REPEAT:
1691     case OP_ADD:
1692     case OP_SUBTRACT:
1693     case OP_I_MULTIPLY:
1694     case OP_I_DIVIDE:
1695     case OP_I_MODULO:
1696     case OP_I_ADD:
1697     case OP_I_SUBTRACT:
1698     case OP_LEFT_SHIFT:
1699     case OP_RIGHT_SHIFT:
1700     case OP_BIT_AND:
1701     case OP_BIT_XOR:
1702     case OP_BIT_OR:
1703     case OP_CONCAT:
1704     case OP_SUBST:
1705     case OP_TRANS:
1706     case OP_READ:
1707     case OP_SYSREAD:
1708     case OP_RECV:
1709     case OP_ANDASSIGN:
1710     case OP_ORASSIGN:
1711     case OP_DORASSIGN:
1712         return TRUE;
1713     default:
1714         return FALSE;
1715     }
1716 }
1717
1718 STATIC bool
1719 S_is_handle_constructor(const OP *o, I32 numargs)
1720 {
1721     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1722
1723     switch (o->op_type) {
1724     case OP_PIPE_OP:
1725     case OP_SOCKPAIR:
1726         if (numargs == 2)
1727             return TRUE;
1728         /* FALL THROUGH */
1729     case OP_SYSOPEN:
1730     case OP_OPEN:
1731     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1732     case OP_SOCKET:
1733     case OP_OPEN_DIR:
1734     case OP_ACCEPT:
1735         if (numargs == 1)
1736             return TRUE;
1737         /* FALLTHROUGH */
1738     default:
1739         return FALSE;
1740     }
1741 }
1742
1743 OP *
1744 Perl_refkids(pTHX_ OP *o, I32 type)
1745 {
1746     if (o && o->op_flags & OPf_KIDS) {
1747         OP *kid;
1748         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1749             ref(kid, type);
1750     }
1751     return o;
1752 }
1753
1754 OP *
1755 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1756 {
1757     dVAR;
1758     OP *kid;
1759
1760     PERL_ARGS_ASSERT_DOREF;
1761
1762     if (!o || (PL_parser && PL_parser->error_count))
1763         return o;
1764
1765     switch (o->op_type) {
1766     case OP_ENTERSUB:
1767         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1768             !(o->op_flags & OPf_STACKED)) {
1769             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1770             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1771             assert(cUNOPo->op_first->op_type == OP_NULL);
1772             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1773             o->op_flags |= OPf_SPECIAL;
1774             o->op_private &= ~1;
1775         }
1776         break;
1777
1778     case OP_COND_EXPR:
1779         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1780             doref(kid, type, set_op_ref);
1781         break;
1782     case OP_RV2SV:
1783         if (type == OP_DEFINED)
1784             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1785         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1786         /* FALL THROUGH */
1787     case OP_PADSV:
1788         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1789             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1790                               : type == OP_RV2HV ? OPpDEREF_HV
1791                               : OPpDEREF_SV);
1792             o->op_flags |= OPf_MOD;
1793         }
1794         break;
1795
1796     case OP_RV2AV:
1797     case OP_RV2HV:
1798         if (set_op_ref)
1799             o->op_flags |= OPf_REF;
1800         /* FALL THROUGH */
1801     case OP_RV2GV:
1802         if (type == OP_DEFINED)
1803             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1804         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1805         break;
1806
1807     case OP_PADAV:
1808     case OP_PADHV:
1809         if (set_op_ref)
1810             o->op_flags |= OPf_REF;
1811         break;
1812
1813     case OP_SCALAR:
1814     case OP_NULL:
1815         if (!(o->op_flags & OPf_KIDS))
1816             break;
1817         doref(cBINOPo->op_first, type, set_op_ref);
1818         break;
1819     case OP_AELEM:
1820     case OP_HELEM:
1821         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1822         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1823             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1824                               : type == OP_RV2HV ? OPpDEREF_HV
1825                               : OPpDEREF_SV);
1826             o->op_flags |= OPf_MOD;
1827         }
1828         break;
1829
1830     case OP_SCOPE:
1831     case OP_LEAVE:
1832         set_op_ref = FALSE;
1833         /* FALL THROUGH */
1834     case OP_ENTER:
1835     case OP_LIST:
1836         if (!(o->op_flags & OPf_KIDS))
1837             break;
1838         doref(cLISTOPo->op_last, type, set_op_ref);
1839         break;
1840     default:
1841         break;
1842     }
1843     return scalar(o);
1844
1845 }
1846
1847 STATIC OP *
1848 S_dup_attrlist(pTHX_ OP *o)
1849 {
1850     dVAR;
1851     OP *rop;
1852
1853     PERL_ARGS_ASSERT_DUP_ATTRLIST;
1854
1855     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1856      * where the first kid is OP_PUSHMARK and the remaining ones
1857      * are OP_CONST.  We need to push the OP_CONST values.
1858      */
1859     if (o->op_type == OP_CONST)
1860         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1861 #ifdef PERL_MAD
1862     else if (o->op_type == OP_NULL)
1863         rop = NULL;
1864 #endif
1865     else {
1866         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1867         rop = NULL;
1868         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1869             if (o->op_type == OP_CONST)
1870                 rop = append_elem(OP_LIST, rop,
1871                                   newSVOP(OP_CONST, o->op_flags,
1872                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
1873         }
1874     }
1875     return rop;
1876 }
1877
1878 STATIC void
1879 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1880 {
1881     dVAR;
1882     SV *stashsv;
1883
1884     PERL_ARGS_ASSERT_APPLY_ATTRS;
1885
1886     /* fake up C<use attributes $pkg,$rv,@attrs> */
1887     ENTER;              /* need to protect against side-effects of 'use' */
1888     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1889
1890 #define ATTRSMODULE "attributes"
1891 #define ATTRSMODULE_PM "attributes.pm"
1892
1893     if (for_my) {
1894         /* Don't force the C<use> if we don't need it. */
1895         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1896         if (svp && *svp != &PL_sv_undef)
1897             NOOP;       /* already in %INC */
1898         else
1899             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1900                              newSVpvs(ATTRSMODULE), NULL);
1901     }
1902     else {
1903         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1904                          newSVpvs(ATTRSMODULE),
1905                          NULL,
1906                          prepend_elem(OP_LIST,
1907                                       newSVOP(OP_CONST, 0, stashsv),
1908                                       prepend_elem(OP_LIST,
1909                                                    newSVOP(OP_CONST, 0,
1910                                                            newRV(target)),
1911                                                    dup_attrlist(attrs))));
1912     }
1913     LEAVE;
1914 }
1915
1916 STATIC void
1917 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1918 {
1919     dVAR;
1920     OP *pack, *imop, *arg;
1921     SV *meth, *stashsv;
1922
1923     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1924
1925     if (!attrs)
1926         return;
1927
1928     assert(target->op_type == OP_PADSV ||
1929            target->op_type == OP_PADHV ||
1930            target->op_type == OP_PADAV);
1931
1932     /* Ensure that attributes.pm is loaded. */
1933     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1934
1935     /* Need package name for method call. */
1936     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1937
1938     /* Build up the real arg-list. */
1939     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1940
1941     arg = newOP(OP_PADSV, 0);
1942     arg->op_targ = target->op_targ;
1943     arg = prepend_elem(OP_LIST,
1944                        newSVOP(OP_CONST, 0, stashsv),
1945                        prepend_elem(OP_LIST,
1946                                     newUNOP(OP_REFGEN, 0,
1947                                             mod(arg, OP_REFGEN)),
1948                                     dup_attrlist(attrs)));
1949
1950     /* Fake up a method call to import */
1951     meth = newSVpvs_share("import");
1952     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1953                    append_elem(OP_LIST,
1954                                prepend_elem(OP_LIST, pack, list(arg)),
1955                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1956     imop->op_private |= OPpENTERSUB_NOMOD;
1957
1958     /* Combine the ops. */
1959     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1960 }
1961
1962 /*
1963 =notfor apidoc apply_attrs_string
1964
1965 Attempts to apply a list of attributes specified by the C<attrstr> and
1966 C<len> arguments to the subroutine identified by the C<cv> argument which
1967 is expected to be associated with the package identified by the C<stashpv>
1968 argument (see L<attributes>).  It gets this wrong, though, in that it
1969 does not correctly identify the boundaries of the individual attribute
1970 specifications within C<attrstr>.  This is not really intended for the
1971 public API, but has to be listed here for systems such as AIX which
1972 need an explicit export list for symbols.  (It's called from XS code
1973 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1974 to respect attribute syntax properly would be welcome.
1975
1976 =cut
1977 */
1978
1979 void
1980 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1981                         const char *attrstr, STRLEN len)
1982 {
1983     OP *attrs = NULL;
1984
1985     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1986
1987     if (!len) {
1988         len = strlen(attrstr);
1989     }
1990
1991     while (len) {
1992         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1993         if (len) {
1994             const char * const sstr = attrstr;
1995             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1996             attrs = append_elem(OP_LIST, attrs,
1997                                 newSVOP(OP_CONST, 0,
1998                                         newSVpvn(sstr, attrstr-sstr)));
1999         }
2000     }
2001
2002     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2003                      newSVpvs(ATTRSMODULE),
2004                      NULL, prepend_elem(OP_LIST,
2005                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2006                                   prepend_elem(OP_LIST,
2007                                                newSVOP(OP_CONST, 0,
2008                                                        newRV((SV*)cv)),
2009                                                attrs)));
2010 }
2011
2012 STATIC OP *
2013 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2014 {
2015     dVAR;
2016     I32 type;
2017
2018     PERL_ARGS_ASSERT_MY_KID;
2019
2020     if (!o || (PL_parser && PL_parser->error_count))
2021         return o;
2022
2023     type = o->op_type;
2024     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2025         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2026         return o;
2027     }
2028
2029     if (type == OP_LIST) {
2030         OP *kid;
2031         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2032             my_kid(kid, attrs, imopsp);
2033     } else if (type == OP_UNDEF
2034 #ifdef PERL_MAD
2035                || type == OP_STUB
2036 #endif
2037                ) {
2038         return o;
2039     } else if (type == OP_RV2SV ||      /* "our" declaration */
2040                type == OP_RV2AV ||
2041                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2042         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2043             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2044                         OP_DESC(o),
2045                         PL_parser->in_my == KEY_our
2046                             ? "our"
2047                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2048         } else if (attrs) {
2049             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2050             PL_parser->in_my = FALSE;
2051             PL_parser->in_my_stash = NULL;
2052             apply_attrs(GvSTASH(gv),
2053                         (type == OP_RV2SV ? GvSV(gv) :
2054                          type == OP_RV2AV ? (SV*)GvAV(gv) :
2055                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2056                         attrs, FALSE);
2057         }
2058         o->op_private |= OPpOUR_INTRO;
2059         return o;
2060     }
2061     else if (type != OP_PADSV &&
2062              type != OP_PADAV &&
2063              type != OP_PADHV &&
2064              type != OP_PUSHMARK)
2065     {
2066         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2067                           OP_DESC(o),
2068                           PL_parser->in_my == KEY_our
2069                             ? "our"
2070                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2071         return o;
2072     }
2073     else if (attrs && type != OP_PUSHMARK) {
2074         HV *stash;
2075
2076         PL_parser->in_my = FALSE;
2077         PL_parser->in_my_stash = NULL;
2078
2079         /* check for C<my Dog $spot> when deciding package */
2080         stash = PAD_COMPNAME_TYPE(o->op_targ);
2081         if (!stash)
2082             stash = PL_curstash;
2083         apply_attrs_my(stash, o, attrs, imopsp);
2084     }
2085     o->op_flags |= OPf_MOD;
2086     o->op_private |= OPpLVAL_INTRO;
2087     if (PL_parser->in_my == KEY_state)
2088         o->op_private |= OPpPAD_STATE;
2089     return o;
2090 }
2091
2092 OP *
2093 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2094 {
2095     dVAR;
2096     OP *rops;
2097     int maybe_scalar = 0;
2098
2099     PERL_ARGS_ASSERT_MY_ATTRS;
2100
2101 /* [perl #17376]: this appears to be premature, and results in code such as
2102    C< our(%x); > executing in list mode rather than void mode */
2103 #if 0
2104     if (o->op_flags & OPf_PARENS)
2105         list(o);
2106     else
2107         maybe_scalar = 1;
2108 #else
2109     maybe_scalar = 1;
2110 #endif
2111     if (attrs)
2112         SAVEFREEOP(attrs);
2113     rops = NULL;
2114     o = my_kid(o, attrs, &rops);
2115     if (rops) {
2116         if (maybe_scalar && o->op_type == OP_PADSV) {
2117             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2118             o->op_private |= OPpLVAL_INTRO;
2119         }
2120         else
2121             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2122     }
2123     PL_parser->in_my = FALSE;
2124     PL_parser->in_my_stash = NULL;
2125     return o;
2126 }
2127
2128 OP *
2129 Perl_my(pTHX_ OP *o)
2130 {
2131     PERL_ARGS_ASSERT_MY;
2132
2133     return my_attrs(o, NULL);
2134 }
2135
2136 OP *
2137 Perl_sawparens(pTHX_ OP *o)
2138 {
2139     PERL_UNUSED_CONTEXT;
2140     if (o)
2141         o->op_flags |= OPf_PARENS;
2142     return o;
2143 }
2144
2145 OP *
2146 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2147 {
2148     OP *o;
2149     bool ismatchop = 0;
2150     const OPCODE ltype = left->op_type;
2151     const OPCODE rtype = right->op_type;
2152
2153     PERL_ARGS_ASSERT_BIND_MATCH;
2154
2155     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2156           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2157     {
2158       const char * const desc
2159           = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2160                        ? (int)rtype : OP_MATCH];
2161       const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2162              ? "@array" : "%hash");
2163       Perl_warner(aTHX_ packWARN(WARN_MISC),
2164              "Applying %s to %s will act on scalar(%s)",
2165              desc, sample, sample);
2166     }
2167
2168     if (rtype == OP_CONST &&
2169         cSVOPx(right)->op_private & OPpCONST_BARE &&
2170         cSVOPx(right)->op_private & OPpCONST_STRICT)
2171     {
2172         no_bareword_allowed(right);
2173     }
2174
2175     ismatchop = rtype == OP_MATCH ||
2176                 rtype == OP_SUBST ||
2177                 rtype == OP_TRANS;
2178     if (ismatchop && right->op_private & OPpTARGET_MY) {
2179         right->op_targ = 0;
2180         right->op_private &= ~OPpTARGET_MY;
2181     }
2182     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2183         OP *newleft;
2184
2185         right->op_flags |= OPf_STACKED;
2186         if (rtype != OP_MATCH &&
2187             ! (rtype == OP_TRANS &&
2188                right->op_private & OPpTRANS_IDENTICAL))
2189             newleft = mod(left, rtype);
2190         else
2191             newleft = left;
2192         if (right->op_type == OP_TRANS)
2193             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2194         else
2195             o = prepend_elem(rtype, scalar(newleft), right);
2196         if (type == OP_NOT)
2197             return newUNOP(OP_NOT, 0, scalar(o));
2198         return o;
2199     }
2200     else
2201         return bind_match(type, left,
2202                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2203 }
2204
2205 OP *
2206 Perl_invert(pTHX_ OP *o)
2207 {
2208     if (!o)
2209         return NULL;
2210     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2211 }
2212
2213 OP *
2214 Perl_scope(pTHX_ OP *o)
2215 {
2216     dVAR;
2217     if (o) {
2218         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2219             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2220             o->op_type = OP_LEAVE;
2221             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2222         }
2223         else if (o->op_type == OP_LINESEQ) {
2224             OP *kid;
2225             o->op_type = OP_SCOPE;
2226             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2227             kid = ((LISTOP*)o)->op_first;
2228             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2229                 op_null(kid);
2230
2231                 /* The following deals with things like 'do {1 for 1}' */
2232                 kid = kid->op_sibling;
2233                 if (kid &&
2234                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2235                     op_null(kid);
2236             }
2237         }
2238         else
2239             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2240     }
2241     return o;
2242 }
2243
2244 int
2245 Perl_block_start(pTHX_ int full)
2246 {
2247     dVAR;
2248     const int retval = PL_savestack_ix;
2249     pad_block_start(full);
2250     SAVEHINTS();
2251     PL_hints &= ~HINT_BLOCK_SCOPE;
2252     SAVECOMPILEWARNINGS();
2253     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2254     return retval;
2255 }
2256
2257 OP*
2258 Perl_block_end(pTHX_ I32 floor, OP *seq)
2259 {
2260     dVAR;
2261     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2262     OP* const retval = scalarseq(seq);
2263     LEAVE_SCOPE(floor);
2264     CopHINTS_set(&PL_compiling, PL_hints);
2265     if (needblockscope)
2266         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2267     pad_leavemy();
2268     return retval;
2269 }
2270
2271 STATIC OP *
2272 S_newDEFSVOP(pTHX)
2273 {
2274     dVAR;
2275     const PADOFFSET offset = pad_findmy("$_");
2276     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2277         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2278     }
2279     else {
2280         OP * const o = newOP(OP_PADSV, 0);
2281         o->op_targ = offset;
2282         return o;
2283     }
2284 }
2285
2286 void
2287 Perl_newPROG(pTHX_ OP *o)
2288 {
2289     dVAR;
2290
2291     PERL_ARGS_ASSERT_NEWPROG;
2292
2293     if (PL_in_eval) {
2294         if (PL_eval_root)
2295                 return;
2296         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2297                                ((PL_in_eval & EVAL_KEEPERR)
2298                                 ? OPf_SPECIAL : 0), o);
2299         PL_eval_start = linklist(PL_eval_root);
2300         PL_eval_root->op_private |= OPpREFCOUNTED;
2301         OpREFCNT_set(PL_eval_root, 1);
2302         PL_eval_root->op_next = 0;
2303         CALL_PEEP(PL_eval_start);
2304     }
2305     else {
2306         if (o->op_type == OP_STUB) {
2307             PL_comppad_name = 0;
2308             PL_compcv = 0;
2309             S_op_destroy(aTHX_ o);
2310             return;
2311         }
2312         PL_main_root = scope(sawparens(scalarvoid(o)));
2313         PL_curcop = &PL_compiling;
2314         PL_main_start = LINKLIST(PL_main_root);
2315         PL_main_root->op_private |= OPpREFCOUNTED;
2316         OpREFCNT_set(PL_main_root, 1);
2317         PL_main_root->op_next = 0;
2318         CALL_PEEP(PL_main_start);
2319         PL_compcv = 0;
2320
2321         /* Register with debugger */
2322         if (PERLDB_INTER) {
2323             CV * const cv
2324                 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2325             if (cv) {
2326                 dSP;
2327                 PUSHMARK(SP);
2328                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2329                 PUTBACK;
2330                 call_sv((SV*)cv, G_DISCARD);
2331             }
2332         }
2333     }
2334 }
2335
2336 OP *
2337 Perl_localize(pTHX_ OP *o, I32 lex)
2338 {
2339     dVAR;
2340
2341     PERL_ARGS_ASSERT_LOCALIZE;
2342
2343     if (o->op_flags & OPf_PARENS)
2344 /* [perl #17376]: this appears to be premature, and results in code such as
2345    C< our(%x); > executing in list mode rather than void mode */
2346 #if 0
2347         list(o);
2348 #else
2349         NOOP;
2350 #endif
2351     else {
2352         if ( PL_parser->bufptr > PL_parser->oldbufptr
2353             && PL_parser->bufptr[-1] == ','
2354             && ckWARN(WARN_PARENTHESIS))
2355         {
2356             char *s = PL_parser->bufptr;
2357             bool sigil = FALSE;
2358
2359             /* some heuristics to detect a potential error */
2360             while (*s && (strchr(", \t\n", *s)))
2361                 s++;
2362
2363             while (1) {
2364                 if (*s && strchr("@$%*", *s) && *++s
2365                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2366                     s++;
2367                     sigil = TRUE;
2368                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2369                         s++;
2370                     while (*s && (strchr(", \t\n", *s)))
2371                         s++;
2372                 }
2373                 else
2374                     break;
2375             }
2376             if (sigil && (*s == ';' || *s == '=')) {
2377                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2378                                 "Parentheses missing around \"%s\" list",
2379                                 lex
2380                                     ? (PL_parser->in_my == KEY_our
2381                                         ? "our"
2382                                         : PL_parser->in_my == KEY_state
2383                                             ? "state"
2384                                             : "my")
2385                                     : "local");
2386             }
2387         }
2388     }
2389     if (lex)
2390         o = my(o);
2391     else
2392         o = mod(o, OP_NULL);            /* a bit kludgey */
2393     PL_parser->in_my = FALSE;
2394     PL_parser->in_my_stash = NULL;
2395     return o;
2396 }
2397
2398 OP *
2399 Perl_jmaybe(pTHX_ OP *o)
2400 {
2401     PERL_ARGS_ASSERT_JMAYBE;
2402
2403     if (o->op_type == OP_LIST) {
2404         OP * const o2
2405             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2406         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2407     }
2408     return o;
2409 }
2410
2411 OP *
2412 Perl_fold_constants(pTHX_ register OP *o)
2413 {
2414     dVAR;
2415     register OP * VOL curop;
2416     OP *newop;
2417     VOL I32 type = o->op_type;
2418     SV * VOL sv = NULL;
2419     int ret = 0;
2420     I32 oldscope;
2421     OP *old_next;
2422     SV * const oldwarnhook = PL_warnhook;
2423     SV * const olddiehook  = PL_diehook;
2424     dJMPENV;
2425
2426     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2427
2428     if (PL_opargs[type] & OA_RETSCALAR)
2429         scalar(o);
2430     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2431         o->op_targ = pad_alloc(type, SVs_PADTMP);
2432
2433     /* integerize op, unless it happens to be C<-foo>.
2434      * XXX should pp_i_negate() do magic string negation instead? */
2435     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2436         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2437              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2438     {
2439         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2440     }
2441
2442     if (!(PL_opargs[type] & OA_FOLDCONST))
2443         goto nope;
2444
2445     switch (type) {
2446     case OP_NEGATE:
2447         /* XXX might want a ck_negate() for this */
2448         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2449         break;
2450     case OP_UCFIRST:
2451     case OP_LCFIRST:
2452     case OP_UC:
2453     case OP_LC:
2454     case OP_SLT:
2455     case OP_SGT:
2456     case OP_SLE:
2457     case OP_SGE:
2458     case OP_SCMP:
2459         /* XXX what about the numeric ops? */
2460         if (PL_hints & HINT_LOCALE)
2461             goto nope;
2462     }
2463
2464     if (PL_parser && PL_parser->error_count)
2465         goto nope;              /* Don't try to run w/ errors */
2466
2467     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2468         const OPCODE type = curop->op_type;
2469         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2470             type != OP_LIST &&
2471             type != OP_SCALAR &&
2472             type != OP_NULL &&
2473             type != OP_PUSHMARK)
2474         {
2475             goto nope;
2476         }
2477     }
2478
2479     curop = LINKLIST(o);
2480     old_next = o->op_next;
2481     o->op_next = 0;
2482     PL_op = curop;
2483
2484     oldscope = PL_scopestack_ix;
2485     create_eval_scope(G_FAKINGEVAL);
2486
2487     PL_warnhook = PERL_WARNHOOK_FATAL;
2488     PL_diehook  = NULL;
2489     JMPENV_PUSH(ret);
2490
2491     switch (ret) {
2492     case 0:
2493         CALLRUNOPS(aTHX);
2494         sv = *(PL_stack_sp--);
2495         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2496             pad_swipe(o->op_targ,  FALSE);
2497         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2498             SvREFCNT_inc_simple_void(sv);
2499             SvTEMP_off(sv);
2500         }
2501         break;
2502     case 3:
2503         /* Something tried to die.  Abandon constant folding.  */
2504         /* Pretend the error never happened.  */
2505         sv_setpvn(ERRSV,"",0);
2506         o->op_next = old_next;
2507         break;
2508     default:
2509         JMPENV_POP;
2510         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2511         PL_warnhook = oldwarnhook;
2512         PL_diehook  = olddiehook;
2513         /* XXX note that this croak may fail as we've already blown away
2514          * the stack - eg any nested evals */
2515         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2516     }
2517     JMPENV_POP;
2518     PL_warnhook = oldwarnhook;
2519     PL_diehook  = olddiehook;
2520
2521     if (PL_scopestack_ix > oldscope)
2522         delete_eval_scope();
2523
2524     if (ret)
2525         goto nope;
2526
2527 #ifndef PERL_MAD
2528     op_free(o);
2529 #endif
2530     assert(sv);
2531     if (type == OP_RV2GV)
2532         newop = newGVOP(OP_GV, 0, (GV*)sv);
2533     else
2534         newop = newSVOP(OP_CONST, 0, (SV*)sv);
2535     op_getmad(o,newop,'f');
2536     return newop;
2537
2538  nope:
2539     return o;
2540 }
2541
2542 OP *
2543 Perl_gen_constant_list(pTHX_ register OP *o)
2544 {
2545     dVAR;
2546     register OP *curop;
2547     const I32 oldtmps_floor = PL_tmps_floor;
2548
2549     list(o);
2550     if (PL_parser && PL_parser->error_count)
2551         return o;               /* Don't attempt to run with errors */
2552
2553     PL_op = curop = LINKLIST(o);
2554     o->op_next = 0;
2555     CALL_PEEP(curop);
2556     pp_pushmark();
2557     CALLRUNOPS(aTHX);
2558     PL_op = curop;
2559     assert (!(curop->op_flags & OPf_SPECIAL));
2560     assert(curop->op_type == OP_RANGE);
2561     pp_anonlist();
2562     PL_tmps_floor = oldtmps_floor;
2563
2564     o->op_type = OP_RV2AV;
2565     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2566     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2567     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2568     o->op_opt = 0;              /* needs to be revisited in peep() */
2569     curop = ((UNOP*)o)->op_first;
2570     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2571 #ifdef PERL_MAD
2572     op_getmad(curop,o,'O');
2573 #else
2574     op_free(curop);
2575 #endif
2576     linklist(o);
2577     return list(o);
2578 }
2579
2580 OP *
2581 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2582 {
2583     dVAR;
2584     if (!o || o->op_type != OP_LIST)
2585         o = newLISTOP(OP_LIST, 0, o, NULL);
2586     else
2587         o->op_flags &= ~OPf_WANT;
2588
2589     if (!(PL_opargs[type] & OA_MARK))
2590         op_null(cLISTOPo->op_first);
2591
2592     o->op_type = (OPCODE)type;
2593     o->op_ppaddr = PL_ppaddr[type];
2594     o->op_flags |= flags;
2595
2596     o = CHECKOP(type, o);
2597     if (o->op_type != (unsigned)type)
2598         return o;
2599
2600     return fold_constants(o);
2601 }
2602
2603 /* List constructors */
2604
2605 OP *
2606 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2607 {
2608     if (!first)
2609         return last;
2610
2611     if (!last)
2612         return first;
2613
2614     if (first->op_type != (unsigned)type
2615         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2616     {
2617         return newLISTOP(type, 0, first, last);
2618     }
2619
2620     if (first->op_flags & OPf_KIDS)
2621         ((LISTOP*)first)->op_last->op_sibling = last;
2622     else {
2623         first->op_flags |= OPf_KIDS;
2624         ((LISTOP*)first)->op_first = last;
2625     }
2626     ((LISTOP*)first)->op_last = last;
2627     return first;
2628 }
2629
2630 OP *
2631 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2632 {
2633     if (!first)
2634         return (OP*)last;
2635
2636     if (!last)
2637         return (OP*)first;
2638
2639     if (first->op_type != (unsigned)type)
2640         return prepend_elem(type, (OP*)first, (OP*)last);
2641
2642     if (last->op_type != (unsigned)type)
2643         return append_elem(type, (OP*)first, (OP*)last);
2644
2645     first->op_last->op_sibling = last->op_first;
2646     first->op_last = last->op_last;
2647     first->op_flags |= (last->op_flags & OPf_KIDS);
2648
2649 #ifdef PERL_MAD
2650     if (last->op_first && first->op_madprop) {
2651         MADPROP *mp = last->op_first->op_madprop;
2652         if (mp) {
2653             while (mp->mad_next)
2654                 mp = mp->mad_next;
2655             mp->mad_next = first->op_madprop;
2656         }
2657         else {
2658             last->op_first->op_madprop = first->op_madprop;
2659         }
2660     }
2661     first->op_madprop = last->op_madprop;
2662     last->op_madprop = 0;
2663 #endif
2664
2665     S_op_destroy(aTHX_ (OP*)last);
2666
2667     return (OP*)first;
2668 }
2669
2670 OP *
2671 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2672 {
2673     if (!first)
2674         return last;
2675
2676     if (!last)
2677         return first;
2678
2679     if (last->op_type == (unsigned)type) {
2680         if (type == OP_LIST) {  /* already a PUSHMARK there */
2681             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2682             ((LISTOP*)last)->op_first->op_sibling = first;
2683             if (!(first->op_flags & OPf_PARENS))
2684                 last->op_flags &= ~OPf_PARENS;
2685         }
2686         else {
2687             if (!(last->op_flags & OPf_KIDS)) {
2688                 ((LISTOP*)last)->op_last = first;
2689                 last->op_flags |= OPf_KIDS;
2690             }
2691             first->op_sibling = ((LISTOP*)last)->op_first;
2692             ((LISTOP*)last)->op_first = first;
2693         }
2694         last->op_flags |= OPf_KIDS;
2695         return last;
2696     }
2697
2698     return newLISTOP(type, 0, first, last);
2699 }
2700
2701 /* Constructors */
2702
2703 #ifdef PERL_MAD
2704
2705 TOKEN *
2706 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2707 {
2708     TOKEN *tk;
2709     Newxz(tk, 1, TOKEN);
2710     tk->tk_type = (OPCODE)optype;
2711     tk->tk_type = 12345;
2712     tk->tk_lval = lval;
2713     tk->tk_mad = madprop;
2714     return tk;
2715 }
2716
2717 void
2718 Perl_token_free(pTHX_ TOKEN* tk)
2719 {
2720     PERL_ARGS_ASSERT_TOKEN_FREE;
2721
2722     if (tk->tk_type != 12345)
2723         return;
2724     mad_free(tk->tk_mad);
2725     Safefree(tk);
2726 }
2727
2728 void
2729 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2730 {
2731     MADPROP* mp;
2732     MADPROP* tm;
2733
2734     PERL_ARGS_ASSERT_TOKEN_GETMAD;
2735
2736     if (tk->tk_type != 12345) {
2737         Perl_warner(aTHX_ packWARN(WARN_MISC),
2738              "Invalid TOKEN object ignored");
2739         return;
2740     }
2741     tm = tk->tk_mad;
2742     if (!tm)
2743         return;
2744
2745     /* faked up qw list? */
2746     if (slot == '(' &&
2747         tm->mad_type == MAD_SV &&
2748         SvPVX((SV*)tm->mad_val)[0] == 'q')
2749             slot = 'x';
2750
2751     if (o) {
2752         mp = o->op_madprop;
2753         if (mp) {
2754             for (;;) {
2755                 /* pretend constant fold didn't happen? */
2756                 if (mp->mad_key == 'f' &&
2757                     (o->op_type == OP_CONST ||
2758                      o->op_type == OP_GV) )
2759                 {
2760                     token_getmad(tk,(OP*)mp->mad_val,slot);
2761                     return;
2762                 }
2763                 if (!mp->mad_next)
2764                     break;
2765                 mp = mp->mad_next;
2766             }
2767             mp->mad_next = tm;
2768             mp = mp->mad_next;
2769         }
2770         else {
2771             o->op_madprop = tm;
2772             mp = o->op_madprop;
2773         }
2774         if (mp->mad_key == 'X')
2775             mp->mad_key = slot; /* just change the first one */
2776
2777         tk->tk_mad = 0;
2778     }
2779     else
2780         mad_free(tm);
2781     Safefree(tk);
2782 }
2783
2784 void
2785 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2786 {
2787     MADPROP* mp;
2788     if (!from)
2789         return;
2790     if (o) {
2791         mp = o->op_madprop;
2792         if (mp) {
2793             for (;;) {
2794                 /* pretend constant fold didn't happen? */
2795                 if (mp->mad_key == 'f' &&
2796                     (o->op_type == OP_CONST ||
2797                      o->op_type == OP_GV) )
2798                 {
2799                     op_getmad(from,(OP*)mp->mad_val,slot);
2800                     return;
2801                 }
2802                 if (!mp->mad_next)
2803                     break;
2804                 mp = mp->mad_next;
2805             }
2806             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2807         }
2808         else {
2809             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2810         }
2811     }
2812 }
2813
2814 void
2815 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2816 {
2817     MADPROP* mp;
2818     if (!from)
2819         return;
2820     if (o) {
2821         mp = o->op_madprop;
2822         if (mp) {
2823             for (;;) {
2824                 /* pretend constant fold didn't happen? */
2825                 if (mp->mad_key == 'f' &&
2826                     (o->op_type == OP_CONST ||
2827                      o->op_type == OP_GV) )
2828                 {
2829                     op_getmad(from,(OP*)mp->mad_val,slot);
2830                     return;
2831                 }
2832                 if (!mp->mad_next)
2833                     break;
2834                 mp = mp->mad_next;
2835             }
2836             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2837         }
2838         else {
2839             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2840         }
2841     }
2842     else {
2843         PerlIO_printf(PerlIO_stderr(),
2844                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2845         op_free(from);
2846     }
2847 }
2848
2849 void
2850 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2851 {
2852     MADPROP* tm;
2853     if (!mp || !o)
2854         return;
2855     if (slot)
2856         mp->mad_key = slot;
2857     tm = o->op_madprop;
2858     o->op_madprop = mp;
2859     for (;;) {
2860         if (!mp->mad_next)
2861             break;
2862         mp = mp->mad_next;
2863     }
2864     mp->mad_next = tm;
2865 }
2866
2867 void
2868 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2869 {
2870     if (!o)
2871         return;
2872     addmad(tm, &(o->op_madprop), slot);
2873 }
2874
2875 void
2876 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2877 {
2878     MADPROP* mp;
2879     if (!tm || !root)
2880         return;
2881     if (slot)
2882         tm->mad_key = slot;
2883     mp = *root;
2884     if (!mp) {
2885         *root = tm;
2886         return;
2887     }
2888     for (;;) {
2889         if (!mp->mad_next)
2890             break;
2891         mp = mp->mad_next;
2892     }
2893     mp->mad_next = tm;
2894 }
2895
2896 MADPROP *
2897 Perl_newMADsv(pTHX_ char key, SV* sv)
2898 {
2899     PERL_ARGS_ASSERT_NEWMADSV;
2900
2901     return newMADPROP(key, MAD_SV, sv, 0);
2902 }
2903
2904 MADPROP *
2905 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2906 {
2907     MADPROP *mp;
2908     Newxz(mp, 1, MADPROP);
2909     mp->mad_next = 0;
2910     mp->mad_key = key;
2911     mp->mad_vlen = vlen;
2912     mp->mad_type = type;
2913     mp->mad_val = val;
2914 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2915     return mp;
2916 }
2917
2918 void
2919 Perl_mad_free(pTHX_ MADPROP* mp)
2920 {
2921 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2922     if (!mp)
2923         return;
2924     if (mp->mad_next)
2925         mad_free(mp->mad_next);
2926 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2927         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2928     switch (mp->mad_type) {
2929     case MAD_NULL:
2930         break;
2931     case MAD_PV:
2932         Safefree((char*)mp->mad_val);
2933         break;
2934     case MAD_OP:
2935         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2936             op_free((OP*)mp->mad_val);
2937         break;
2938     case MAD_SV:
2939         sv_free((SV*)mp->mad_val);
2940         break;
2941     default:
2942         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2943         break;
2944     }
2945     Safefree(mp);
2946 }
2947
2948 #endif
2949
2950 OP *
2951 Perl_newNULLLIST(pTHX)
2952 {
2953     return newOP(OP_STUB, 0);
2954 }
2955
2956 OP *
2957 Perl_force_list(pTHX_ OP *o)
2958 {
2959     if (!o || o->op_type != OP_LIST)
2960         o = newLISTOP(OP_LIST, 0, o, NULL);
2961     op_null(o);
2962     return o;
2963 }
2964
2965 OP *
2966 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2967 {
2968     dVAR;
2969     LISTOP *listop;
2970
2971     NewOp(1101, listop, 1, LISTOP);
2972
2973     listop->op_type = (OPCODE)type;
2974     listop->op_ppaddr = PL_ppaddr[type];
2975     if (first || last)
2976         flags |= OPf_KIDS;
2977     listop->op_flags = (U8)flags;
2978
2979     if (!last && first)
2980         last = first;
2981     else if (!first && last)
2982         first = last;
2983     else if (first)
2984         first->op_sibling = last;
2985     listop->op_first = first;
2986     listop->op_last = last;
2987     if (type == OP_LIST) {
2988         OP* const pushop = newOP(OP_PUSHMARK, 0);
2989         pushop->op_sibling = first;
2990         listop->op_first = pushop;
2991         listop->op_flags |= OPf_KIDS;
2992         if (!last)
2993             listop->op_last = pushop;
2994     }
2995
2996     return CHECKOP(type, listop);
2997 }
2998
2999 OP *
3000 Perl_newOP(pTHX_ I32 type, I32 flags)
3001 {
3002     dVAR;
3003     OP *o;
3004     NewOp(1101, o, 1, OP);
3005     o->op_type = (OPCODE)type;
3006     o->op_ppaddr = PL_ppaddr[type];
3007     o->op_flags = (U8)flags;
3008     o->op_latefree = 0;
3009     o->op_latefreed = 0;
3010     o->op_attached = 0;
3011
3012     o->op_next = o;
3013     o->op_private = (U8)(0 | (flags >> 8));
3014     if (PL_opargs[type] & OA_RETSCALAR)
3015         scalar(o);
3016     if (PL_opargs[type] & OA_TARGET)
3017         o->op_targ = pad_alloc(type, SVs_PADTMP);
3018     return CHECKOP(type, o);
3019 }
3020
3021 OP *
3022 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3023 {
3024     dVAR;
3025     UNOP *unop;
3026
3027     if (!first)
3028         first = newOP(OP_STUB, 0);
3029     if (PL_opargs[type] & OA_MARK)
3030         first = force_list(first);
3031
3032     NewOp(1101, unop, 1, UNOP);
3033     unop->op_type = (OPCODE)type;
3034     unop->op_ppaddr = PL_ppaddr[type];
3035     unop->op_first = first;
3036     unop->op_flags = (U8)(flags | OPf_KIDS);
3037     unop->op_private = (U8)(1 | (flags >> 8));
3038     unop = (UNOP*) CHECKOP(type, unop);
3039     if (unop->op_next)
3040         return (OP*)unop;
3041
3042     return fold_constants((OP *) unop);
3043 }
3044
3045 OP *
3046 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3047 {
3048     dVAR;
3049     BINOP *binop;
3050     NewOp(1101, binop, 1, BINOP);
3051
3052     if (!first)
3053         first = newOP(OP_NULL, 0);
3054
3055     binop->op_type = (OPCODE)type;
3056     binop->op_ppaddr = PL_ppaddr[type];
3057     binop->op_first = first;
3058     binop->op_flags = (U8)(flags | OPf_KIDS);
3059     if (!last) {
3060         last = first;
3061         binop->op_private = (U8)(1 | (flags >> 8));
3062     }
3063     else {
3064         binop->op_private = (U8)(2 | (flags >> 8));
3065         first->op_sibling = last;
3066     }
3067
3068     binop = (BINOP*)CHECKOP(type, binop);
3069     if (binop->op_next || binop->op_type != (OPCODE)type)
3070         return (OP*)binop;
3071
3072     binop->op_last = binop->op_first->op_sibling;
3073
3074     return fold_constants((OP *)binop);
3075 }
3076
3077 static int uvcompare(const void *a, const void *b)
3078     __attribute__nonnull__(1)
3079     __attribute__nonnull__(2)
3080     __attribute__pure__;
3081 static int uvcompare(const void *a, const void *b)
3082 {
3083     if (*((const UV *)a) < (*(const UV *)b))
3084         return -1;
3085     if (*((const UV *)a) > (*(const UV *)b))
3086         return 1;
3087     if (*((const UV *)a+1) < (*(const UV *)b+1))
3088         return -1;
3089     if (*((const UV *)a+1) > (*(const UV *)b+1))
3090         return 1;
3091     return 0;
3092 }
3093
3094 OP *
3095 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3096 {
3097     dVAR;
3098     SV * const tstr = ((SVOP*)expr)->op_sv;
3099     SV * const rstr =
3100 #ifdef PERL_MAD
3101                         (repl->op_type == OP_NULL)
3102                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3103 #endif
3104                               ((SVOP*)repl)->op_sv;
3105     STRLEN tlen;
3106     STRLEN rlen;
3107     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3108     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3109     register I32 i;
3110     register I32 j;
3111     I32 grows = 0;
3112     register short *tbl;
3113
3114     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3115     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3116     I32 del              = o->op_private & OPpTRANS_DELETE;
3117     SV* swash;
3118
3119     PERL_ARGS_ASSERT_PMTRANS;
3120
3121     PL_hints |= HINT_BLOCK_SCOPE;
3122
3123     if (SvUTF8(tstr))
3124         o->op_private |= OPpTRANS_FROM_UTF;
3125
3126     if (SvUTF8(rstr))
3127         o->op_private |= OPpTRANS_TO_UTF;
3128
3129     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3130         SV* const listsv = newSVpvs("# comment\n");
3131         SV* transv = NULL;
3132         const U8* tend = t + tlen;
3133         const U8* rend = r + rlen;
3134         STRLEN ulen;
3135         UV tfirst = 1;
3136         UV tlast = 0;
3137         IV tdiff;
3138         UV rfirst = 1;
3139         UV rlast = 0;
3140         IV rdiff;
3141         IV diff;
3142         I32 none = 0;
3143         U32 max = 0;
3144         I32 bits;
3145         I32 havefinal = 0;
3146         U32 final = 0;
3147         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3148         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3149         U8* tsave = NULL;
3150         U8* rsave = NULL;
3151         const U32 flags = UTF8_ALLOW_DEFAULT;
3152
3153         if (!from_utf) {
3154             STRLEN len = tlen;
3155             t = tsave = bytes_to_utf8(t, &len);
3156             tend = t + len;
3157         }
3158         if (!to_utf && rlen) {
3159             STRLEN len = rlen;
3160             r = rsave = bytes_to_utf8(r, &len);
3161             rend = r + len;
3162         }
3163
3164 /* There are several snags with this code on EBCDIC:
3165    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3166    2. scan_const() in toke.c has encoded chars in native encoding which makes
3167       ranges at least in EBCDIC 0..255 range the bottom odd.
3168 */
3169
3170         if (complement) {
3171             U8 tmpbuf[UTF8_MAXBYTES+1];
3172             UV *cp;
3173             UV nextmin = 0;
3174             Newx(cp, 2*tlen, UV);
3175             i = 0;
3176             transv = newSVpvs("");
3177             while (t < tend) {
3178                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3179                 t += ulen;
3180                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3181                     t++;
3182                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3183                     t += ulen;
3184                 }
3185                 else {
3186                  cp[2*i+1] = cp[2*i];
3187                 }
3188                 i++;
3189             }
3190             qsort(cp, i, 2*sizeof(UV), uvcompare);
3191             for (j = 0; j < i; j++) {
3192                 UV  val = cp[2*j];
3193                 diff = val - nextmin;
3194                 if (diff > 0) {
3195                     t = uvuni_to_utf8(tmpbuf,nextmin);
3196                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3197                     if (diff > 1) {
3198                         U8  range_mark = UTF_TO_NATIVE(0xff);
3199                         t = uvuni_to_utf8(tmpbuf, val - 1);
3200                         sv_catpvn(transv, (char *)&range_mark, 1);
3201                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3202                     }
3203                 }
3204                 val = cp[2*j+1];
3205                 if (val >= nextmin)
3206                     nextmin = val + 1;
3207             }
3208             t = uvuni_to_utf8(tmpbuf,nextmin);
3209             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3210             {
3211                 U8 range_mark = UTF_TO_NATIVE(0xff);
3212                 sv_catpvn(transv, (char *)&range_mark, 1);
3213             }
3214             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3215                                     UNICODE_ALLOW_SUPER);
3216             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3217             t = (const U8*)SvPVX_const(transv);
3218             tlen = SvCUR(transv);
3219             tend = t + tlen;
3220             Safefree(cp);
3221         }
3222         else if (!rlen && !del) {
3223             r = t; rlen = tlen; rend = tend;
3224         }
3225         if (!squash) {
3226                 if ((!rlen && !del) || t == r ||
3227                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3228                 {
3229                     o->op_private |= OPpTRANS_IDENTICAL;
3230                 }
3231         }
3232
3233         while (t < tend || tfirst <= tlast) {
3234             /* see if we need more "t" chars */
3235             if (tfirst > tlast) {
3236                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3237                 t += ulen;
3238                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3239                     t++;
3240                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3241                     t += ulen;
3242                 }
3243                 else
3244                     tlast = tfirst;
3245             }
3246
3247             /* now see if we need more "r" chars */
3248             if (rfirst > rlast) {
3249                 if (r < rend) {
3250                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3251                     r += ulen;
3252                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3253                         r++;
3254                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3255                         r += ulen;
3256                     }
3257                     else
3258                         rlast = rfirst;
3259                 }
3260                 else {
3261                     if (!havefinal++)
3262                         final = rlast;
3263                     rfirst = rlast = 0xffffffff;
3264                 }
3265             }
3266
3267             /* now see which range will peter our first, if either. */
3268             tdiff = tlast - tfirst;
3269             rdiff = rlast - rfirst;
3270
3271             if (tdiff <= rdiff)
3272                 diff = tdiff;
3273             else
3274                 diff = rdiff;
3275
3276             if (rfirst == 0xffffffff) {
3277                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3278                 if (diff > 0)
3279                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3280                                    (long)tfirst, (long)tlast);
3281                 else
3282                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3283             }
3284             else {
3285                 if (diff > 0)
3286                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3287                                    (long)tfirst, (long)(tfirst + diff),
3288                                    (long)rfirst);
3289                 else
3290                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3291                                    (long)tfirst, (long)rfirst);
3292
3293                 if (rfirst + diff > max)
3294                     max = rfirst + diff;
3295                 if (!grows)
3296                     grows = (tfirst < rfirst &&
3297                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3298                 rfirst += diff + 1;
3299             }
3300             tfirst += diff + 1;
3301         }
3302
3303         none = ++max;
3304         if (del)
3305             del = ++max;
3306
3307         if (max > 0xffff)
3308             bits = 32;
3309         else if (max > 0xff)
3310             bits = 16;
3311         else
3312             bits = 8;
3313
3314         PerlMemShared_free(cPVOPo->op_pv);
3315         cPVOPo->op_pv = NULL;
3316
3317         swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3318 #ifdef USE_ITHREADS
3319         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3320         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3321         PAD_SETSV(cPADOPo->op_padix, swash);
3322         SvPADTMP_on(swash);
3323 #else
3324         cSVOPo->op_sv = swash;
3325 #endif
3326         SvREFCNT_dec(listsv);
3327         SvREFCNT_dec(transv);
3328
3329         if (!del && havefinal && rlen)
3330             (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3331                            newSVuv((UV)final), 0);
3332
3333         if (grows)
3334             o->op_private |= OPpTRANS_GROWS;
3335
3336         Safefree(tsave);
3337         Safefree(rsave);
3338
3339 #ifdef PERL_MAD
3340         op_getmad(expr,o,'e');
3341         op_getmad(repl,o,'r');
3342 #else
3343         op_free(expr);
3344         op_free(repl);
3345 #endif
3346         return o;
3347     }
3348
3349     tbl = (short*)cPVOPo->op_pv;
3350     if (complement) {
3351         Zero(tbl, 256, short);
3352         for (i = 0; i < (I32)tlen; i++)
3353             tbl[t[i]] = -1;
3354         for (i = 0, j = 0; i < 256; i++) {
3355             if (!tbl[i]) {
3356                 if (j >= (I32)rlen) {
3357                     if (del)
3358                         tbl[i] = -2;
3359                     else if (rlen)
3360                         tbl[i] = r[j-1];
3361                     else
3362                         tbl[i] = (short)i;
3363                 }
3364                 else {
3365                     if (i < 128 && r[j] >= 128)
3366                         grows = 1;
3367                     tbl[i] = r[j++];
3368                 }
3369             }
3370         }
3371         if (!del) {
3372             if (!rlen) {
3373                 j = rlen;
3374                 if (!squash)
3375                     o->op_private |= OPpTRANS_IDENTICAL;
3376             }
3377             else if (j >= (I32)rlen)
3378                 j = rlen - 1;
3379             else {
3380                 tbl =
3381                     (short *)
3382                     PerlMemShared_realloc(tbl,
3383                                           (0x101+rlen-j) * sizeof(short));
3384                 cPVOPo->op_pv = (char*)tbl;
3385             }
3386             tbl[0x100] = (short)(rlen - j);
3387             for (i=0; i < (I32)rlen - j; i++)
3388                 tbl[0x101+i] = r[j+i];
3389         }
3390     }
3391     else {
3392         if (!rlen && !del) {
3393             r = t; rlen = tlen;
3394             if (!squash)
3395                 o->op_private |= OPpTRANS_IDENTICAL;
3396         }
3397         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3398             o->op_private |= OPpTRANS_IDENTICAL;
3399         }
3400         for (i = 0; i < 256; i++)
3401             tbl[i] = -1;
3402         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3403             if (j >= (I32)rlen) {
3404                 if (del) {
3405                     if (tbl[t[i]] == -1)
3406                         tbl[t[i]] = -2;
3407                     continue;
3408                 }
3409                 --j;
3410             }
3411             if (tbl[t[i]] == -1) {
3412                 if (t[i] < 128 && r[j] >= 128)
3413                     grows = 1;
3414                 tbl[t[i]] = r[j];
3415             }
3416         }
3417     }
3418     if (grows)
3419         o->op_private |= OPpTRANS_GROWS;
3420 #ifdef PERL_MAD
3421     op_getmad(expr,o,'e');
3422     op_getmad(repl,o,'r');
3423 #else
3424     op_free(expr);
3425     op_free(repl);
3426 #endif
3427
3428     return o;
3429 }
3430
3431 OP *
3432 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3433 {
3434     dVAR;
3435     PMOP *pmop;
3436
3437     NewOp(1101, pmop, 1, PMOP);
3438     pmop->op_type = (OPCODE)type;
3439     pmop->op_ppaddr = PL_ppaddr[type];
3440     pmop->op_flags = (U8)flags;
3441     pmop->op_private = (U8)(0 | (flags >> 8));
3442
3443     if (PL_hints & HINT_RE_TAINT)
3444         pmop->op_pmflags |= PMf_RETAINT;
3445     if (PL_hints & HINT_LOCALE)
3446         pmop->op_pmflags |= PMf_LOCALE;
3447
3448
3449 #ifdef USE_ITHREADS
3450     assert(SvPOK(PL_regex_pad[0]));
3451     if (SvCUR(PL_regex_pad[0])) {
3452         /* Pop off the "packed" IV from the end.  */
3453         SV *const repointer_list = PL_regex_pad[0];
3454         const char *p = SvEND(repointer_list) - sizeof(IV);
3455         const IV offset = *((IV*)p);
3456
3457         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3458
3459         SvEND_set(repointer_list, p);
3460
3461         pmop->op_pmoffset = offset;
3462         /* This slot should be free, so assert this:  */
3463         assert(PL_regex_pad[offset] == &PL_sv_undef);
3464     } else {
3465         SV * const repointer = &PL_sv_undef;
3466         av_push(PL_regex_padav, repointer);
3467         pmop->op_pmoffset = av_len(PL_regex_padav);
3468         PL_regex_pad = AvARRAY(PL_regex_padav);
3469     }
3470 #endif
3471
3472     return CHECKOP(type, pmop);
3473 }
3474
3475 /* Given some sort of match op o, and an expression expr containing a
3476  * pattern, either compile expr into a regex and attach it to o (if it's
3477  * constant), or convert expr into a runtime regcomp op sequence (if it's
3478  * not)
3479  *
3480  * isreg indicates that the pattern is part of a regex construct, eg
3481  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3482  * split "pattern", which aren't. In the former case, expr will be a list
3483  * if the pattern contains more than one term (eg /a$b/) or if it contains
3484  * a replacement, ie s/// or tr///.
3485  */
3486
3487 OP *
3488 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3489 {
3490     dVAR;
3491     PMOP *pm;
3492     LOGOP *rcop;
3493     I32 repl_has_vars = 0;
3494     OP* repl = NULL;
3495     bool reglist;
3496
3497     PERL_ARGS_ASSERT_PMRUNTIME;
3498
3499     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3500         /* last element in list is the replacement; pop it */
3501         OP* kid;
3502         repl = cLISTOPx(expr)->op_last;
3503         kid = cLISTOPx(expr)->op_first;
3504         while (kid->op_sibling != repl)
3505             kid = kid->op_sibling;
3506         kid->op_sibling = NULL;
3507         cLISTOPx(expr)->op_last = kid;
3508     }
3509
3510     if (isreg && expr->op_type == OP_LIST &&
3511         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3512     {
3513         /* convert single element list to element */
3514         OP* const oe = expr;
3515         expr = cLISTOPx(oe)->op_first->op_sibling;
3516         cLISTOPx(oe)->op_first->op_sibling = NULL;
3517         cLISTOPx(oe)->op_last = NULL;
3518         op_free(oe);
3519     }
3520
3521     if (o->op_type == OP_TRANS) {
3522         return pmtrans(o, expr, repl);
3523     }
3524
3525     reglist = isreg && expr->op_type == OP_LIST;
3526     if (reglist)
3527         op_null(expr);
3528
3529     PL_hints |= HINT_BLOCK_SCOPE;
3530     pm = (PMOP*)o;
3531
3532     if (expr->op_type == OP_CONST) {
3533         SV *pat = ((SVOP*)expr)->op_sv;
3534         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3535
3536         if (o->op_flags & OPf_SPECIAL)
3537             pm_flags |= RXf_SPLIT;
3538
3539         if (DO_UTF8(pat)) {
3540             assert (SvUTF8(pat));
3541         } else if (SvUTF8(pat)) {
3542             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3543                trapped in use 'bytes'?  */
3544             /* Make a copy of the octet sequence, but without the flag on, as
3545                the compiler now honours the SvUTF8 flag on pat.  */
3546             STRLEN len;
3547             const char *const p = SvPV(pat, len);
3548             pat = newSVpvn_flags(p, len, SVs_TEMP);
3549         }
3550
3551         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3552
3553 #ifdef PERL_MAD
3554         op_getmad(expr,(OP*)pm,'e');
3555 #else
3556         op_free(expr);
3557 #endif
3558     }
3559     else {
3560         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3561             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3562                             ? OP_REGCRESET
3563                             : OP_REGCMAYBE),0,expr);
3564
3565         NewOp(1101, rcop, 1, LOGOP);
3566         rcop->op_type = OP_REGCOMP;
3567         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3568         rcop->op_first = scalar(expr);
3569         rcop->op_flags |= OPf_KIDS
3570                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3571                             | (reglist ? OPf_STACKED : 0);
3572         rcop->op_private = 1;
3573         rcop->op_other = o;
3574         if (reglist)
3575             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3576
3577         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3578         PL_cv_has_eval = 1;
3579
3580         /* establish postfix order */
3581         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3582             LINKLIST(expr);
3583             rcop->op_next = expr;
3584             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3585         }
3586         else {
3587             rcop->op_next = LINKLIST(expr);
3588             expr->op_next = (OP*)rcop;
3589         }
3590
3591         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3592     }
3593
3594     if (repl) {
3595         OP *curop;
3596         if (pm->op_pmflags & PMf_EVAL) {
3597             curop = NULL;
3598             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3599                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3600         }
3601         else if (repl->op_type == OP_CONST)
3602             curop = repl;
3603         else {
3604             OP *lastop = NULL;
3605             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3606                 if (curop->op_type == OP_SCOPE
3607                         || curop->op_type == OP_LEAVE
3608                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3609                     if (curop->op_type == OP_GV) {
3610                         GV * const gv = cGVOPx_gv(curop);
3611                         repl_has_vars = 1;
3612                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3613                             break;
3614                     }
3615                     else if (curop->op_type == OP_RV2CV)
3616                         break;
3617                     else if (curop->op_type == OP_RV2SV ||
3618                              curop->op_type == OP_RV2AV ||
3619                              curop->op_type == OP_RV2HV ||
3620                              curop->op_type == OP_RV2GV) {
3621                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3622                             break;
3623                     }
3624                     else if (curop->op_type == OP_PADSV ||
3625                              curop->op_type == OP_PADAV ||
3626                              curop->op_type == OP_PADHV ||
3627                              curop->op_type == OP_PADANY)
3628                     {
3629                         repl_has_vars = 1;
3630                     }
3631                     else if (curop->op_type == OP_PUSHRE)
3632                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3633                     else
3634                         break;
3635                 }
3636                 lastop = curop;
3637             }
3638         }
3639         if (curop == repl
3640             && !(repl_has_vars
3641                  && (!PM_GETRE(pm)
3642                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3643         {
3644             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3645             prepend_elem(o->op_type, scalar(repl), o);
3646         }
3647         else {
3648             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3649                 pm->op_pmflags |= PMf_MAYBE_CONST;
3650             }
3651             NewOp(1101, rcop, 1, LOGOP);
3652             rcop->op_type = OP_SUBSTCONT;
3653             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3654             rcop->op_first = scalar(repl);
3655             rcop->op_flags |= OPf_KIDS;
3656             rcop->op_private = 1;
3657             rcop->op_other = o;
3658
3659             /* establish postfix order */
3660             rcop->op_next = LINKLIST(repl);
3661             repl->op_next = (OP*)rcop;
3662
3663             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3664             assert(!(pm->op_pmflags & PMf_ONCE));
3665             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3666             rcop->op_next = 0;
3667         }
3668     }
3669
3670     return (OP*)pm;
3671 }
3672
3673 OP *
3674 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3675 {
3676     dVAR;
3677     SVOP *svop;
3678
3679     PERL_ARGS_ASSERT_NEWSVOP;
3680
3681     NewOp(1101, svop, 1, SVOP);
3682     svop->op_type = (OPCODE)type;
3683     svop->op_ppaddr = PL_ppaddr[type];
3684     svop->op_sv = sv;
3685     svop->op_next = (OP*)svop;
3686     svop->op_flags = (U8)flags;
3687     if (PL_opargs[type] & OA_RETSCALAR)
3688         scalar((OP*)svop);
3689     if (PL_opargs[type] & OA_TARGET)
3690         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3691     return CHECKOP(type, svop);
3692 }
3693
3694 #ifdef USE_ITHREADS
3695 OP *
3696 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3697 {
3698     dVAR;
3699     PADOP *padop;
3700
3701     PERL_ARGS_ASSERT_NEWPADOP;
3702
3703     NewOp(1101, padop, 1, PADOP);
3704     padop->op_type = (OPCODE)type;
3705     padop->op_ppaddr = PL_ppaddr[type];
3706     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3707     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3708     PAD_SETSV(padop->op_padix, sv);
3709     assert(sv);
3710     SvPADTMP_on(sv);
3711     padop->op_next = (OP*)padop;
3712     padop->op_flags = (U8)flags;
3713     if (PL_opargs[type] & OA_RETSCALAR)
3714         scalar((OP*)padop);
3715     if (PL_opargs[type] & OA_TARGET)
3716         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3717     return CHECKOP(type, padop);
3718 }
3719 #endif
3720
3721 OP *
3722 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3723 {
3724     dVAR;
3725
3726     PERL_ARGS_ASSERT_NEWGVOP;
3727
3728 #ifdef USE_ITHREADS
3729     GvIN_PAD_on(gv);
3730     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3731 #else
3732     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3733 #endif
3734 }
3735
3736 OP *
3737 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3738 {
3739     dVAR;
3740     PVOP *pvop;
3741     NewOp(1101, pvop, 1, PVOP);
3742     pvop->op_type = (OPCODE)type;
3743     pvop->op_ppaddr = PL_ppaddr[type];
3744     pvop->op_pv = pv;
3745     pvop->op_next = (OP*)pvop;
3746     pvop->op_flags = (U8)flags;
3747     if (PL_opargs[type] & OA_RETSCALAR)
3748         scalar((OP*)pvop);
3749     if (PL_opargs[type] & OA_TARGET)
3750         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3751     return CHECKOP(type, pvop);
3752 }
3753
3754 #ifdef PERL_MAD
3755 OP*
3756 #else
3757 void
3758 #endif
3759 Perl_package(pTHX_ OP *o)
3760 {
3761     dVAR;
3762     SV *const sv = cSVOPo->op_sv;
3763 #ifdef PERL_MAD
3764     OP *pegop;
3765 #endif
3766
3767     PERL_ARGS_ASSERT_PACKAGE;
3768
3769     save_hptr(&PL_curstash);
3770     save_item(PL_curstname);
3771
3772     PL_curstash = gv_stashsv(sv, GV_ADD);
3773
3774     sv_setsv(PL_curstname, sv);
3775
3776     PL_hints |= HINT_BLOCK_SCOPE;
3777     PL_parser->copline = NOLINE;
3778     PL_parser->expect = XSTATE;
3779
3780 #ifndef PERL_MAD
3781     op_free(o);
3782 #else
3783     if (!PL_madskills) {
3784         op_free(o);
3785         return NULL;
3786     }
3787
3788     pegop = newOP(OP_NULL,0);
3789     op_getmad(o,pegop,'P');
3790     return pegop;
3791 #endif
3792 }
3793
3794 #ifdef PERL_MAD
3795 OP*
3796 #else
3797 void
3798 #endif
3799 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3800 {
3801     dVAR;
3802     OP *pack;
3803     OP *imop;
3804     OP *veop;
3805 #ifdef PERL_MAD
3806     OP *pegop = newOP(OP_NULL,0);
3807 #endif
3808
3809     PERL_ARGS_ASSERT_UTILIZE;
3810
3811     if (idop->op_type != OP_CONST)
3812         Perl_croak(aTHX_ "Module name must be constant");
3813
3814     if (PL_madskills)
3815         op_getmad(idop,pegop,'U');
3816
3817     veop = NULL;
3818
3819     if (version) {
3820         SV * const vesv = ((SVOP*)version)->op_sv;
3821
3822         if (PL_madskills)
3823             op_getmad(version,pegop,'V');
3824         if (!arg && !SvNIOKp(vesv)) {
3825             arg = version;
3826         }
3827         else {
3828             OP *pack;
3829             SV *meth;
3830
3831             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3832                 Perl_croak(aTHX_ "Version number must be constant number");
3833
3834             /* Make copy of idop so we don't free it twice */
3835             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3836
3837             /* Fake up a method call to VERSION */
3838             meth = newSVpvs_share("VERSION");
3839             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3840                             append_elem(OP_LIST,
3841                                         prepend_elem(OP_LIST, pack, list(version)),
3842                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3843         }
3844     }
3845
3846     /* Fake up an import/unimport */
3847     if (arg && arg->op_type == OP_STUB) {
3848         if (PL_madskills)
3849             op_getmad(arg,pegop,'S');
3850         imop = arg;             /* no import on explicit () */
3851     }
3852     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3853         imop = NULL;            /* use 5.0; */
3854         if (!aver)
3855             idop->op_private |= OPpCONST_NOVER;
3856     }
3857     else {
3858         SV *meth;
3859
3860         if (PL_madskills)
3861             op_getmad(arg,pegop,'A');
3862
3863         /* Make copy of idop so we don't free it twice */
3864         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3865
3866         /* Fake up a method call to import/unimport */
3867         meth = aver
3868             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3869         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3870                        append_elem(OP_LIST,
3871                                    prepend_elem(OP_LIST, pack, list(arg)),
3872                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3873     }
3874
3875     /* Fake up the BEGIN {}, which does its thing immediately. */
3876     newATTRSUB(floor,
3877         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3878         NULL,
3879         NULL,
3880         append_elem(OP_LINESEQ,
3881             append_elem(OP_LINESEQ,
3882                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3883                 newSTATEOP(0, NULL, veop)),
3884             newSTATEOP(0, NULL, imop) ));
3885
3886     /* The "did you use incorrect case?" warning used to be here.
3887      * The problem is that on case-insensitive filesystems one
3888      * might get false positives for "use" (and "require"):
3889      * "use Strict" or "require CARP" will work.  This causes
3890      * portability problems for the script: in case-strict
3891      * filesystems the script will stop working.
3892      *
3893      * The "incorrect case" warning checked whether "use Foo"
3894      * imported "Foo" to your namespace, but that is wrong, too:
3895      * there is no requirement nor promise in the language that
3896      * a Foo.pm should or would contain anything in package "Foo".
3897      *
3898      * There is very little Configure-wise that can be done, either:
3899      * the case-sensitivity of the build filesystem of Perl does not
3900      * help in guessing the case-sensitivity of the runtime environment.
3901      */
3902
3903     PL_hints |= HINT_BLOCK_SCOPE;
3904     PL_parser->copline = NOLINE;
3905     PL_parser->expect = XSTATE;
3906     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3907
3908 #ifdef PERL_MAD
3909     if (!PL_madskills) {
3910         /* FIXME - don't allocate pegop if !PL_madskills */
3911         op_free(pegop);
3912         return NULL;
3913     }
3914     return pegop;
3915 #endif
3916 }
3917
3918 /*
3919 =head1 Embedding Functions
3920
3921 =for apidoc load_module
3922
3923 Loads the module whose name is pointed to by the string part of name.
3924 Note that the actual module name, not its filename, should be given.
3925 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3926 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3927 (or 0 for no flags). ver, if specified, provides version semantics
3928 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3929 arguments can be used to specify arguments to the module's import()
3930 method, similar to C<use Foo::Bar VERSION LIST>.
3931
3932 =cut */
3933
3934 void
3935 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3936 {
3937     va_list args;
3938
3939     PERL_ARGS_ASSERT_LOAD_MODULE;
3940
3941     va_start(args, ver);
3942     vload_module(flags, name, ver, &args);
3943     va_end(args);
3944 }
3945
3946 #ifdef PERL_IMPLICIT_CONTEXT
3947 void
3948 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3949 {
3950     dTHX;
3951     va_list args;
3952     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3953     va_start(args, ver);
3954     vload_module(flags, name, ver, &args);
3955     va_end(args);
3956 }
3957 #endif
3958
3959 void
3960 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3961 {
3962     dVAR;
3963     OP *veop, *imop;
3964     OP * const modname = newSVOP(OP_CONST, 0, name);
3965
3966     PERL_ARGS_ASSERT_VLOAD_MODULE;
3967
3968     modname->op_private |= OPpCONST_BARE;
3969     if (ver) {
3970         veop = newSVOP(OP_CONST, 0, ver);
3971     }
3972     else
3973         veop = NULL;
3974     if (flags & PERL_LOADMOD_NOIMPORT) {
3975         imop = sawparens(newNULLLIST());
3976     }
3977     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3978         imop = va_arg(*args, OP*);
3979     }
3980     else {
3981         SV *sv;
3982         imop = NULL;
3983         sv = va_arg(*args, SV*);
3984         while (sv) {
3985             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3986             sv = va_arg(*args, SV*);
3987         }
3988     }
3989
3990     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3991      * that it has a PL_parser to play with while doing that, and also
3992      * that it doesn't mess with any existing parser, by creating a tmp
3993      * new parser with lex_start(). This won't actually be used for much,
3994      * since pp_require() will create another parser for the real work. */
3995
3996     ENTER;
3997     SAVEVPTR(PL_curcop);
3998     lex_start(NULL, NULL, FALSE);
3999     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4000             veop, modname, imop);
4001     LEAVE;
4002 }
4003
4004 OP *
4005 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4006 {
4007     dVAR;
4008     OP *doop;
4009     GV *gv = NULL;
4010
4011     PERL_ARGS_ASSERT_DOFILE;
4012
4013     if (!force_builtin) {
4014         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4015         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4016             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4017             gv = gvp ? *gvp : NULL;
4018         }
4019     }
4020
4021     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4022         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4023                                append_elem(OP_LIST, term,
4024                                            scalar(newUNOP(OP_RV2CV, 0,
4025                                                           newGVOP(OP_GV, 0, gv))))));
4026     }
4027     else {
4028         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4029     }
4030     return doop;
4031 }
4032
4033 OP *
4034 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4035 {
4036     return newBINOP(OP_LSLICE, flags,
4037             list(force_list(subscript)),
4038             list(force_list(listval)) );
4039 }
4040
4041 STATIC I32
4042 S_is_list_assignment(pTHX_ register const OP *o)
4043 {
4044     unsigned type;
4045     U8 flags;
4046
4047     if (!o)
4048         return TRUE;
4049
4050     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4051         o = cUNOPo->op_first;
4052
4053     flags = o->op_flags;
4054     type = o->op_type;
4055     if (type == OP_COND_EXPR) {
4056         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4057         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4058
4059         if (t && f)
4060             return TRUE;
4061         if (t || f)
4062             yyerror("Assignment to both a list and a scalar");
4063         return FALSE;
4064     }
4065
4066     if (type == OP_LIST &&
4067         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4068         o->op_private & OPpLVAL_INTRO)
4069         return FALSE;
4070
4071     if (type == OP_LIST || flags & OPf_PARENS ||
4072         type == OP_RV2AV || type == OP_RV2HV ||
4073         type == OP_ASLICE || type == OP_HSLICE)
4074         return TRUE;
4075
4076     if (type == OP_PADAV || type == OP_PADHV)
4077         return TRUE;
4078
4079     if (type == OP_RV2SV)
4080         return FALSE;
4081
4082     return FALSE;
4083 }
4084
4085 OP *
4086 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4087 {
4088     dVAR;
4089     OP *o;
4090
4091     if (optype) {
4092         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4093             return newLOGOP(optype, 0,
4094                 mod(scalar(left), optype),
4095                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4096         }
4097         else {
4098             return newBINOP(optype, OPf_STACKED,
4099                 mod(scalar(left), optype), scalar(right));
4100         }
4101     }
4102
4103     if (is_list_assignment(left)) {
4104         static const char no_list_state[] = "Initialization of state variables"
4105             " in list context currently forbidden";
4106         OP *curop;
4107         bool maybe_common_vars = TRUE;
4108
4109         PL_modcount = 0;
4110         /* Grandfathering $[ assignment here.  Bletch.*/
4111         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4112         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4113         left = mod(left, OP_AASSIGN);
4114         if (PL_eval_start)
4115             PL_eval_start = 0;
4116         else if (left->op_type == OP_CONST) {
4117             /* FIXME for MAD */
4118             /* Result of assignment is always 1 (or we'd be dead already) */
4119             return newSVOP(OP_CONST, 0, newSViv(1));
4120         }
4121         curop = list(force_list(left));
4122         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4123         o->op_private = (U8)(0 | (flags >> 8));
4124
4125         if ((left->op_type == OP_LIST
4126              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4127         {
4128             OP* lop = ((LISTOP*)left)->op_first;
4129             maybe_common_vars = FALSE;
4130             while (lop) {
4131                 if (lop->op_type == OP_PADSV ||
4132                     lop->op_type == OP_PADAV ||
4133                     lop->op_type == OP_PADHV ||
4134                     lop->op_type == OP_PADANY) {
4135                     if (!(lop->op_private & OPpLVAL_INTRO))
4136                         maybe_common_vars = TRUE;
4137
4138                     if (lop->op_private & OPpPAD_STATE) {
4139                         if (left->op_private & OPpLVAL_INTRO) {
4140                             /* Each variable in state($a, $b, $c) = ... */
4141                         }
4142                         else {
4143                             /* Each state variable in
4144                                (state $a, my $b, our $c, $d, undef) = ... */
4145                         }
4146                         yyerror(no_list_state);
4147                     } else {
4148                         /* Each my variable in
4149                            (state $a, my $b, our $c, $d, undef) = ... */
4150                     }
4151                 } else if (lop->op_type == OP_UNDEF ||
4152                            lop->op_type == OP_PUSHMARK) {
4153                     /* undef may be interesting in
4154                        (state $a, undef, state $c) */
4155                 } else {
4156                     /* Other ops in the list. */
4157                     maybe_common_vars = TRUE;
4158                 }
4159                 lop = lop->op_sibling;
4160             }
4161         }
4162         else if ((left->op_private & OPpLVAL_INTRO)
4163                 && (   left->op_type == OP_PADSV
4164                     || left->op_type == OP_PADAV
4165                     || left->op_type == OP_PADHV
4166                     || left->op_type == OP_PADANY))
4167         {
4168             maybe_common_vars = FALSE;
4169             if (left->op_private & OPpPAD_STATE) {
4170                 /* All single variable list context state assignments, hence
4171                    state ($a) = ...
4172                    (state $a) = ...
4173                    state @a = ...
4174                    state (@a) = ...
4175                    (state @a) = ...
4176                    state %a = ...
4177                    state (%a) = ...
4178                    (state %a) = ...
4179                 */
4180                 yyerror(no_list_state);
4181             }
4182         }
4183
4184         /* PL_generation sorcery:
4185          * an assignment like ($a,$b) = ($c,$d) is easier than
4186          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4187          * To detect whether there are common vars, the global var
4188          * PL_generation is incremented for each assign op we compile.
4189          * Then, while compiling the assign op, we run through all the
4190          * variables on both sides of the assignment, setting a spare slot
4191          * in each of them to PL_generation. If any of them already have
4192          * that value, we know we've got commonality.  We could use a
4193          * single bit marker, but then we'd have to make 2 passes, first
4194          * to clear the flag, then to test and set it.  To find somewhere
4195          * to store these values, evil chicanery is done with SvUVX().
4196          */
4197
4198         if (maybe_common_vars) {
4199             OP *lastop = o;
4200             PL_generation++;
4201             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4202                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4203                     if (curop->op_type == OP_GV) {
4204                         GV *gv = cGVOPx_gv(curop);
4205                         if (gv == PL_defgv
4206                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4207                             break;
4208                         GvASSIGN_GENERATION_set(gv, PL_generation);
4209                     }
4210                     else if (curop->op_type == OP_PADSV ||
4211                              curop->op_type == OP_PADAV ||
4212                              curop->op_type == OP_PADHV ||
4213                              curop->op_type == OP_PADANY)
4214                     {
4215                         if (PAD_COMPNAME_GEN(curop->op_targ)
4216                                                     == (STRLEN)PL_generation)
4217                             break;
4218                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4219
4220                     }
4221                     else if (curop->op_type == OP_RV2CV)
4222                         break;
4223                     else if (curop->op_type == OP_RV2SV ||
4224                              curop->op_type == OP_RV2AV ||
4225                              curop->op_type == OP_RV2HV ||
4226                              curop->op_type == OP_RV2GV) {
4227                         if (lastop->op_type != OP_GV)   /* funny deref? */
4228                             break;
4229                     }
4230                     else if (curop->op_type == OP_PUSHRE) {
4231 #ifdef USE_ITHREADS
4232                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4233                             GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4234                             if (gv == PL_defgv
4235                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4236                                 break;
4237                             GvASSIGN_GENERATION_set(gv, PL_generation);
4238                         }
4239 #else
4240                         GV *const gv
4241                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4242                         if (gv) {
4243                             if (gv == PL_defgv
4244                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4245                                 break;
4246                             GvASSIGN_GENERATION_set(gv, PL_generation);
4247                         }
4248 #endif
4249                     }
4250                     else
4251                         break;
4252                 }
4253                 lastop = curop;
4254             }
4255             if (curop != o)
4256                 o->op_private |= OPpASSIGN_COMMON;
4257         }
4258
4259         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4260             OP* tmpop = ((LISTOP*)right)->op_first;
4261             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4262                 PMOP * const pm = (PMOP*)tmpop;
4263                 if (left->op_type == OP_RV2AV &&
4264                     !(left->op_private & OPpLVAL_INTRO) &&
4265                     !(o->op_private & OPpASSIGN_COMMON) )
4266                 {
4267                     tmpop = ((UNOP*)left)->op_first;
4268                     if (tmpop->op_type == OP_GV
4269 #ifdef USE_ITHREADS
4270                         && !pm->op_pmreplrootu.op_pmtargetoff
4271 #else
4272                         && !pm->op_pmreplrootu.op_pmtargetgv
4273 #endif
4274                         ) {
4275 #ifdef USE_ITHREADS
4276                         pm->op_pmreplrootu.op_pmtargetoff
4277                             = cPADOPx(tmpop)->op_padix;
4278                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4279 #else
4280                         pm->op_pmreplrootu.op_pmtargetgv
4281                             = (GV*)cSVOPx(tmpop)->op_sv;
4282                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4283 #endif
4284                         pm->op_pmflags |= PMf_ONCE;
4285                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4286                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4287                         tmpop->op_sibling = NULL;       /* don't free split */
4288                         right->op_next = tmpop->op_next;  /* fix starting loc */
4289                         op_free(o);                     /* blow off assign */
4290                         right->op_flags &= ~OPf_WANT;
4291                                 /* "I don't know and I don't care." */
4292                         return right;
4293                     }
4294                 }
4295                 else {
4296                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4297                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4298                     {
4299                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4300                         if (SvIVX(sv) == 0)
4301                             sv_setiv(sv, PL_modcount+1);
4302                     }
4303                 }
4304             }
4305         }
4306         return o;
4307     }
4308     if (!right)
4309         right = newOP(OP_UNDEF, 0);
4310     if (right->op_type == OP_READLINE) {
4311         right->op_flags |= OPf_STACKED;
4312         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4313     }
4314     else {
4315         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4316         o = newBINOP(OP_SASSIGN, flags,
4317             scalar(right), mod(scalar(left), OP_SASSIGN) );
4318         if (PL_eval_start)
4319             PL_eval_start = 0;
4320         else {
4321             /* FIXME for MAD */
4322             op_free(o);
4323             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4324             o->op_private |= OPpCONST_ARYBASE;
4325         }
4326     }
4327     return o;
4328 }
4329
4330 OP *
4331 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4332 {
4333     dVAR;
4334     const U32 seq = intro_my();
4335     register COP *cop;
4336
4337     NewOp(1101, cop, 1, COP);
4338     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4339         cop->op_type = OP_DBSTATE;
4340         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4341     }
4342     else {
4343         cop->op_type = OP_NEXTSTATE;
4344         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4345     }
4346     cop->op_flags = (U8)flags;
4347     CopHINTS_set(cop, PL_hints);
4348 #ifdef NATIVE_HINTS
4349     cop->op_private |= NATIVE_HINTS;
4350 #endif
4351     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4352     cop->op_next = (OP*)cop;
4353
4354     if (label) {
4355         CopLABEL_set(cop, label);
4356         PL_hints |= HINT_BLOCK_SCOPE;
4357     }
4358     cop->cop_seq = seq;
4359     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4360        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4361     */
4362     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4363     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4364     if (cop->cop_hints_hash) {
4365         HINTS_REFCNT_LOCK;
4366         cop->cop_hints_hash->refcounted_he_refcnt++;
4367         HINTS_REFCNT_UNLOCK;
4368     }
4369
4370     if (PL_parser && PL_parser->copline == NOLINE)
4371         CopLINE_set(cop, CopLINE(PL_curcop));
4372     else {
4373         CopLINE_set(cop, PL_parser->copline);
4374         if (PL_parser)
4375             PL_parser->copline = NOLINE;
4376     }
4377 #ifdef USE_ITHREADS
4378     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4379 #else
4380     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4381 #endif
4382     CopSTASH_set(cop, PL_curstash);
4383
4384     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4385         AV *av = CopFILEAVx(PL_curcop);
4386         if (av) {
4387             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4388             if (svp && *svp != &PL_sv_undef ) {
4389                 (void)SvIOK_on(*svp);
4390                 SvIV_set(*svp, PTR2IV(cop));
4391             }
4392         }
4393     }
4394
4395     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4396 }
4397
4398
4399 OP *
4400 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4401 {
4402     dVAR;
4403
4404     PERL_ARGS_ASSERT_NEWLOGOP;
4405
4406     return new_logop(type, flags, &first, &other);
4407 }
4408
4409 STATIC OP *
4410 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4411 {
4412     dVAR;
4413     LOGOP *logop;
4414     OP *o;
4415     OP *first = *firstp;
4416     OP * const other = *otherp;
4417
4418     PERL_ARGS_ASSERT_NEW_LOGOP;
4419
4420     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4421         return newBINOP(type, flags, scalar(first), scalar(other));
4422
4423     scalarboolean(first);
4424     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4425     if (first->op_type == OP_NOT
4426         && (first->op_flags & OPf_SPECIAL)
4427         && (first->op_flags & OPf_KIDS)
4428         && !PL_madskills) {
4429         if (type == OP_AND || type == OP_OR) {
4430             if (type == OP_AND)
4431                 type = OP_OR;
4432             else
4433                 type = OP_AND;
4434             o = first;
4435             first = *firstp = cUNOPo->op_first;
4436             if (o->op_next)
4437                 first->op_next = o->op_next;
4438             cUNOPo->op_first = NULL;
4439             op_free(o);
4440         }
4441     }
4442     if (first->op_type == OP_CONST) {
4443         if (first->op_private & OPpCONST_STRICT)
4444             no_bareword_allowed(first);
4445         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4446                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4447         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4448             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4449             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4450             *firstp = NULL;
4451             if (other->op_type == OP_CONST)
4452                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4453             if (PL_madskills) {
4454                 OP *newop = newUNOP(OP_NULL, 0, other);
4455                 op_getmad(first, newop, '1');
4456                 newop->op_targ = type;  /* set "was" field */
4457                 return newop;
4458             }
4459             op_free(first);
4460             return other;
4461         }
4462         else {
4463             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4464             const OP *o2 = other;
4465             if ( ! (o2->op_type == OP_LIST
4466                     && (( o2 = cUNOPx(o2)->op_first))
4467                     && o2->op_type == OP_PUSHMARK
4468                     && (( o2 = o2->op_sibling)) )
4469             )
4470                 o2 = other;
4471             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4472                         || o2->op_type == OP_PADHV)
4473                 && o2->op_private & OPpLVAL_INTRO
4474                 && !(o2->op_private & OPpPAD_STATE)
4475                 && ckWARN(WARN_DEPRECATED))
4476             {
4477                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4478                             "Deprecated use of my() in false conditional");
4479             }
4480
4481             *otherp = NULL;
4482             if (first->op_type == OP_CONST)
4483                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4484             if (PL_madskills) {
4485                 first = newUNOP(OP_NULL, 0, first);
4486                 op_getmad(other, first, '2');
4487                 first->op_targ = type;  /* set "was" field */
4488             }
4489             else
4490                 op_free(other);
4491             return first;
4492         }
4493     }
4494     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4495         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4496     {
4497         const OP * const k1 = ((UNOP*)first)->op_first;
4498         const OP * const k2 = k1->op_sibling;
4499         OPCODE warnop = 0;
4500         switch (first->op_type)
4501         {
4502         case OP_NULL:
4503             if (k2 && k2->op_type == OP_READLINE
4504                   && (k2->op_flags & OPf_STACKED)
4505                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4506             {
4507                 warnop = k2->op_type;
4508             }
4509             break;
4510
4511         case OP_SASSIGN:
4512             if (k1->op_type == OP_READDIR
4513                   || k1->op_type == OP_GLOB
4514                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4515                   || k1->op_type == OP_EACH)
4516             {
4517                 warnop = ((k1->op_type == OP_NULL)
4518                           ? (OPCODE)k1->op_targ : k1->op_type);
4519             }
4520             break;
4521         }
4522         if (warnop) {
4523             const line_t oldline = CopLINE(PL_curcop);
4524             CopLINE_set(PL_curcop, PL_parser->copline);
4525             Perl_warner(aTHX_ packWARN(WARN_MISC),
4526                  "Value of %s%s can be \"0\"; test with defined()",
4527                  PL_op_desc[warnop],
4528                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4529                   ? " construct" : "() operator"));
4530             CopLINE_set(PL_curcop, oldline);
4531         }
4532     }
4533
4534     if (!other)
4535         return first;
4536
4537     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4538         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4539
4540     NewOp(1101, logop, 1, LOGOP);
4541
4542     logop->op_type = (OPCODE)type;
4543     logop->op_ppaddr = PL_ppaddr[type];
4544     logop->op_first = first;
4545     logop->op_flags = (U8)(flags | OPf_KIDS);
4546     logop->op_other = LINKLIST(other);
4547     logop->op_private = (U8)(1 | (flags >> 8));
4548
4549     /* establish postfix order */
4550     logop->op_next = LINKLIST(first);
4551     first->op_next = (OP*)logop;
4552     first->op_sibling = other;
4553
4554     CHECKOP(type,logop);
4555
4556     o = newUNOP(OP_NULL, 0, (OP*)logop);
4557     other->op_next = o;
4558
4559     return o;
4560 }
4561
4562 OP *
4563 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4564 {
4565     dVAR;
4566     LOGOP *logop;
4567     OP *start;
4568     OP *o;
4569
4570     PERL_ARGS_ASSERT_NEWCONDOP;
4571
4572     if (!falseop)
4573         return newLOGOP(OP_AND, 0, first, trueop);
4574     if (!trueop)
4575         return newLOGOP(OP_OR, 0, first, falseop);
4576
4577     scalarboolean(first);
4578     if (first->op_type == OP_CONST) {
4579         /* Left or right arm of the conditional?  */
4580         const bool left = SvTRUE(((SVOP*)first)->op_sv);
4581         OP *live = left ? trueop : falseop;
4582         OP *const dead = left ? falseop : trueop;
4583         if (first->op_private & OPpCONST_BARE &&
4584             first->op_private & OPpCONST_STRICT) {
4585             no_bareword_allowed(first);
4586         }
4587         if (PL_madskills) {
4588             /* This is all dead code when PERL_MAD is not defined.  */
4589             live = newUNOP(OP_NULL, 0, live);
4590             op_getmad(first, live, 'C');
4591             op_getmad(dead, live, left ? 'e' : 't');
4592         } else {
4593             op_free(first);
4594             op_free(dead);
4595         }
4596         return live;
4597     }
4598     NewOp(1101, logop, 1, LOGOP);
4599     logop->op_type = OP_COND_EXPR;
4600     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4601     logop->op_first = first;
4602     logop->op_flags = (U8)(flags | OPf_KIDS);
4603     logop->op_private = (U8)(1 | (flags >> 8));
4604     logop->op_other = LINKLIST(trueop);
4605     logop->op_next = LINKLIST(falseop);
4606
4607     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4608             logop);
4609
4610     /* establish postfix order */
4611     start = LINKLIST(first);
4612     first->op_next = (OP*)logop;
4613
4614     first->op_sibling = trueop;
4615     trueop->op_sibling = falseop;
4616     o = newUNOP(OP_NULL, 0, (OP*)logop);
4617
4618     trueop->op_next = falseop->op_next = o;
4619
4620     o->op_next = start;
4621     return o;
4622 }
4623
4624 OP *
4625 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4626 {
4627     dVAR;
4628     LOGOP *range;
4629     OP *flip;
4630     OP *flop;
4631     OP *leftstart;
4632     OP *o;
4633
4634     PERL_ARGS_ASSERT_NEWRANGE;
4635
4636     NewOp(1101, range, 1, LOGOP);
4637
4638     range->op_type = OP_RANGE;
4639     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4640     range->op_first = left;
4641     range->op_flags = OPf_KIDS;
4642     leftstart = LINKLIST(left);
4643     range->op_other = LINKLIST(right);
4644     range->op_private = (U8)(1 | (flags >> 8));
4645
4646     left->op_sibling = right;
4647
4648     range->op_next = (OP*)range;
4649     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4650     flop = newUNOP(OP_FLOP, 0, flip);
4651     o = newUNOP(OP_NULL, 0, flop);
4652     linklist(flop);
4653     range->op_next = leftstart;
4654
4655     left->op_next = flip;
4656     right->op_next = flop;
4657
4658     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4659     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4660     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4661     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4662
4663     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4664     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4665
4666     flip->op_next = o;
4667     if (!flip->op_private || !flop->op_private)
4668         linklist(o);            /* blow off optimizer unless constant */
4669
4670     return o;
4671 }
4672
4673 OP *
4674 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4675 {
4676     dVAR;
4677     OP* listop;
4678     OP* o;
4679     const bool once = block && block->op_flags & OPf_SPECIAL &&
4680       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4681
4682     PERL_UNUSED_ARG(debuggable);
4683
4684     if (expr) {
4685         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4686             return block;       /* do {} while 0 does once */
4687         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4688             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4689             expr = newUNOP(OP_DEFINED, 0,
4690                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4691         } else if (expr->op_flags & OPf_KIDS) {
4692             const OP * const k1 = ((UNOP*)expr)->op_first;
4693             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4694             switch (expr->op_type) {
4695               case OP_NULL:
4696                 if (k2 && k2->op_type == OP_READLINE
4697                       && (k2->op_flags & OPf_STACKED)
4698                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4699                     expr = newUNOP(OP_DEFINED, 0, expr);
4700                 break;
4701
4702               case OP_SASSIGN:
4703                 if (k1 && (k1->op_type == OP_READDIR
4704                       || k1->op_type == OP_GLOB
4705                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4706                       || k1->op_type == OP_EACH))
4707                     expr = newUNOP(OP_DEFINED, 0, expr);
4708                 break;
4709             }
4710         }
4711     }
4712
4713     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4714      * op, in listop. This is wrong. [perl #27024] */
4715     if (!block)
4716         block = newOP(OP_NULL, 0);
4717     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4718     o = new_logop(OP_AND, 0, &expr, &listop);
4719
4720     if (listop)
4721         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4722
4723     if (once && o != listop)
4724         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4725
4726     if (o == listop)
4727         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4728
4729     o->op_flags |= flags;
4730     o = scope(o);
4731     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4732     return o;
4733 }
4734
4735 OP *
4736 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4737 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4738 {
4739     dVAR;
4740     OP *redo;
4741     OP *next = NULL;
4742     OP *listop;
4743     OP *o;
4744     U8 loopflags = 0;
4745
4746     PERL_UNUSED_ARG(debuggable);
4747
4748     if (expr) {
4749         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4750                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4751             expr = newUNOP(OP_DEFINED, 0,
4752                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4753         } else if (expr->op_flags & OPf_KIDS) {
4754             const OP * const k1 = ((UNOP*)expr)->op_first;
4755             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4756             switch (expr->op_type) {
4757               case OP_NULL:
4758                 if (k2 && k2->op_type == OP_READLINE
4759                       && (k2->op_flags & OPf_STACKED)
4760                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4761                     expr = newUNOP(OP_DEFINED, 0, expr);
4762                 break;
4763
4764               case OP_SASSIGN:
4765                 if (k1 && (k1->op_type == OP_READDIR
4766                       || k1->op_type == OP_GLOB
4767                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4768                       || k1->op_type == OP_EACH))
4769                     expr = newUNOP(OP_DEFINED, 0, expr);
4770                 break;
4771             }
4772         }
4773     }
4774
4775     if (!block)
4776         block = newOP(OP_NULL, 0);
4777     else if (cont || has_my) {
4778         block = scope(block);
4779     }
4780
4781     if (cont) {
4782         next = LINKLIST(cont);
4783     }
4784     if (expr) {
4785         OP * const unstack = newOP(OP_UNSTACK, 0);
4786         if (!next)
4787             next = unstack;
4788         cont = append_elem(OP_LINESEQ, cont, unstack);
4789     }
4790
4791     assert(block);
4792     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4793     assert(listop);
4794     redo = LINKLIST(listop);
4795
4796     if (expr) {
4797         PL_parser->copline = (line_t)whileline;
4798         scalar(listop);
4799         o = new_logop(OP_AND, 0, &expr, &listop);
4800         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4801             op_free(expr);              /* oops, it's a while (0) */
4802             op_free((OP*)loop);
4803             return NULL;                /* listop already freed by new_logop */
4804         }
4805         if (listop)
4806             ((LISTOP*)listop)->op_last->op_next =
4807                 (o == listop ? redo : LINKLIST(o));
4808     }
4809     else
4810         o = listop;
4811
4812     if (!loop) {
4813         NewOp(1101,loop,1,LOOP);
4814         loop->op_type = OP_ENTERLOOP;
4815         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4816         loop->op_private = 0;
4817         loop->op_next = (OP*)loop;
4818     }
4819
4820     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4821
4822     loop->op_redoop = redo;
4823     loop->op_lastop = o;
4824     o->op_private |= loopflags;
4825
4826     if (next)
4827         loop->op_nextop = next;
4828     else
4829         loop->op_nextop = o;
4830
4831     o->op_flags |= flags;
4832     o->op_private |= (flags >> 8);
4833     return o;
4834 }
4835
4836 OP *
4837 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4838 {
4839     dVAR;
4840     LOOP *loop;
4841     OP *wop;
4842     PADOFFSET padoff = 0;
4843     I32 iterflags = 0;
4844     I32 iterpflags = 0;
4845     OP *madsv = NULL;
4846
4847     PERL_ARGS_ASSERT_NEWFOROP;
4848
4849     if (sv) {
4850         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4851             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4852             sv->op_type = OP_RV2GV;
4853             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4854
4855             /* The op_type check is needed to prevent a possible segfault
4856              * if the loop variable is undeclared and 'strict vars' is in
4857              * effect. This is illegal but is nonetheless parsed, so we
4858              * may reach this point with an OP_CONST where we're expecting
4859              * an OP_GV.
4860              */
4861             if (cUNOPx(sv)->op_first->op_type == OP_GV
4862              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4863                 iterpflags |= OPpITER_DEF;
4864         }
4865         else if (sv->op_type == OP_PADSV) { /* private variable */
4866             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4867             padoff = sv->op_targ;
4868             if (PL_madskills)
4869                 madsv = sv;
4870             else {
4871                 sv->op_targ = 0;
4872                 op_free(sv);
4873             }
4874             sv = NULL;
4875         }
4876         else
4877             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4878         if (padoff) {
4879             SV *const namesv = PAD_COMPNAME_SV(padoff);
4880             STRLEN len;
4881             const char *const name = SvPV_const(namesv, len);
4882
4883             if (len == 2 && name[0] == '$' && name[1] == '_')
4884                 iterpflags |= OPpITER_DEF;
4885         }
4886     }
4887     else {
4888         const PADOFFSET offset = pad_findmy("$_");
4889         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4890             sv = newGVOP(OP_GV, 0, PL_defgv);
4891         }
4892         else {
4893             padoff = offset;
4894         }
4895         iterpflags |= OPpITER_DEF;
4896     }
4897     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4898         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4899         iterflags |= OPf_STACKED;
4900     }
4901     else if (expr->op_type == OP_NULL &&
4902              (expr->op_flags & OPf_KIDS) &&
4903              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4904     {
4905         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4906          * set the STACKED flag to indicate that these values are to be
4907          * treated as min/max values by 'pp_iterinit'.
4908          */
4909         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4910         LOGOP* const range = (LOGOP*) flip->op_first;
4911         OP* const left  = range->op_first;
4912         OP* const right = left->op_sibling;
4913         LISTOP* listop;
4914
4915         range->op_flags &= ~OPf_KIDS;
4916         range->op_first = NULL;
4917
4918         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4919         listop->op_first->op_next = range->op_next;
4920         left->op_next = range->op_other;
4921         right->op_next = (OP*)listop;
4922         listop->op_next = listop->op_first;
4923
4924 #ifdef PERL_MAD
4925         op_getmad(expr,(OP*)listop,'O');
4926 #else
4927         op_free(expr);
4928 #endif
4929         expr = (OP*)(listop);
4930         op_null(expr);
4931         iterflags |= OPf_STACKED;
4932     }
4933     else {
4934         expr = mod(force_list(expr), OP_GREPSTART);
4935     }
4936
4937     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4938                                append_elem(OP_LIST, expr, scalar(sv))));
4939     assert(!loop->op_next);
4940     /* for my  $x () sets OPpLVAL_INTRO;
4941      * for our $x () sets OPpOUR_INTRO */
4942     loop->op_private = (U8)iterpflags;
4943 #ifdef PL_OP_SLAB_ALLOC
4944     {
4945         LOOP *tmp;
4946         NewOp(1234,tmp,1,LOOP);
4947         Copy(loop,tmp,1,LISTOP);
4948         S_op_destroy(aTHX_ (OP*)loop);
4949         loop = tmp;
4950     }
4951 #else
4952     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4953 #endif
4954     loop->op_targ = padoff;
4955     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4956     if (madsv)
4957         op_getmad(madsv, (OP*)loop, 'v');
4958     PL_parser->copline = forline;
4959     return newSTATEOP(0, label, wop);
4960 }
4961
4962 OP*
4963 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4964 {
4965     dVAR;
4966     OP *o;
4967
4968     PERL_ARGS_ASSERT_NEWLOOPEX;
4969
4970     if (type != OP_GOTO || label->op_type == OP_CONST) {
4971         /* "last()" means "last" */
4972         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4973             o = newOP(type, OPf_SPECIAL);
4974         else {
4975             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4976                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4977                                         : ""));
4978         }
4979 #ifdef PERL_MAD
4980         op_getmad(label,o,'L');
4981 #else
4982         op_free(label);
4983 #endif
4984     }
4985     else {
4986         /* Check whether it's going to be a goto &function */
4987         if (label->op_type == OP_ENTERSUB
4988                 && !(label->op_flags & OPf_STACKED))
4989             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4990         o = newUNOP(type, OPf_STACKED, label);
4991     }
4992     PL_hints |= HINT_BLOCK_SCOPE;
4993     return o;
4994 }
4995
4996 /* if the condition is a literal array or hash
4997    (or @{ ... } etc), make a reference to it.
4998  */
4999 STATIC OP *
5000 S_ref_array_or_hash(pTHX_ OP *cond)
5001 {
5002     if (cond
5003     && (cond->op_type == OP_RV2AV
5004     ||  cond->op_type == OP_PADAV
5005     ||  cond->op_type == OP_RV2HV
5006     ||  cond->op_type == OP_PADHV))
5007
5008         return newUNOP(OP_REFGEN,
5009             0, mod(cond, OP_REFGEN));
5010
5011     else
5012         return cond;
5013 }
5014
5015 /* These construct the optree fragments representing given()
5016    and when() blocks.
5017
5018    entergiven and enterwhen are LOGOPs; the op_other pointer
5019    points up to the associated leave op. We need this so we
5020    can put it in the context and make break/continue work.
5021    (Also, of course, pp_enterwhen will jump straight to
5022    op_other if the match fails.)
5023  */
5024
5025 STATIC OP *
5026 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5027                    I32 enter_opcode, I32 leave_opcode,
5028                    PADOFFSET entertarg)
5029 {
5030     dVAR;
5031     LOGOP *enterop;
5032     OP *o;
5033
5034     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5035
5036     NewOp(1101, enterop, 1, LOGOP);
5037     enterop->op_type = enter_opcode;
5038     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5039     enterop->op_flags =  (U8) OPf_KIDS;
5040     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5041     enterop->op_private = 0;
5042
5043     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5044
5045     if (cond) {
5046         enterop->op_first = scalar(cond);
5047         cond->op_sibling = block;
5048
5049         o->op_next = LINKLIST(cond);
5050         cond->op_next = (OP *) enterop;
5051     }
5052     else {
5053         /* This is a default {} block */
5054         enterop->op_first = block;
5055         enterop->op_flags |= OPf_SPECIAL;
5056
5057         o->op_next = (OP *) enterop;
5058     }
5059
5060     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5061                                        entergiven and enterwhen both
5062                                        use ck_null() */
5063
5064     enterop->op_next = LINKLIST(block);
5065     block->op_next = enterop->op_other = o;
5066
5067     return o;
5068 }
5069
5070 /* Does this look like a boolean operation? For these purposes
5071    a boolean operation is:
5072      - a subroutine call [*]
5073      - a logical connective
5074      - a comparison operator
5075      - a filetest operator, with the exception of -s -M -A -C
5076      - defined(), exists() or eof()
5077      - /$re/ or $foo =~ /$re/
5078
5079    [*] possibly surprising
5080  */
5081 STATIC bool
5082 S_looks_like_bool(pTHX_ const OP *o)
5083 {
5084     dVAR;
5085
5086     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5087
5088     switch(o->op_type) {
5089         case OP_OR:
5090             return looks_like_bool(cLOGOPo->op_first);
5091
5092         case OP_AND:
5093             return (
5094                 looks_like_bool(cLOGOPo->op_first)
5095              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5096
5097         case OP_NULL:
5098             return (
5099                 o->op_flags & OPf_KIDS
5100             && looks_like_bool(cUNOPo->op_first));
5101
5102         case OP_ENTERSUB:
5103
5104         case OP_NOT:    case OP_XOR:
5105         /* Note that OP_DOR is not here */
5106
5107         case OP_EQ:     case OP_NE:     case OP_LT:
5108         case OP_GT:     case OP_LE:     case OP_GE:
5109
5110         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5111         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5112
5113         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5114         case OP_SGT:    case OP_SLE:    case OP_SGE:
5115
5116         case OP_SMARTMATCH:
5117
5118         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5119         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5120         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5121         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5122         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5123         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5124         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5125         case OP_FTTEXT:   case OP_FTBINARY:
5126
5127         case OP_DEFINED: case OP_EXISTS:
5128         case OP_MATCH:   case OP_EOF:
5129
5130             return TRUE;
5131
5132         case OP_CONST:
5133             /* Detect comparisons that have been optimized away */
5134             if (cSVOPo->op_sv == &PL_sv_yes
5135             ||  cSVOPo->op_sv == &PL_sv_no)
5136
5137                 return TRUE;
5138
5139         /* FALL THROUGH */
5140         default:
5141             return FALSE;
5142     }
5143 }
5144
5145 OP *
5146 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5147 {
5148     dVAR;
5149     PERL_ARGS_ASSERT_NEWGIVENOP;
5150     return newGIVWHENOP(
5151         ref_array_or_hash(cond),
5152         block,
5153         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5154         defsv_off);
5155 }
5156
5157 /* If cond is null, this is a default {} block */
5158 OP *
5159 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5160 {
5161     const bool cond_llb = (!cond || looks_like_bool(cond));
5162     OP *cond_op;
5163
5164     PERL_ARGS_ASSERT_NEWWHENOP;
5165
5166     if (cond_llb)
5167         cond_op = cond;
5168     else {
5169         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5170                 newDEFSVOP(),
5171                 scalar(ref_array_or_hash(cond)));
5172     }
5173
5174     return newGIVWHENOP(
5175         cond_op,
5176         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5177         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5178 }
5179
5180 /*
5181 =for apidoc cv_undef
5182
5183 Clear out all the active components of a CV. This can happen either
5184 by an explicit C<undef &foo>, or by the reference count going to zero.
5185 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5186 children can still follow the full lexical scope chain.
5187
5188 =cut
5189 */
5190
5191 void
5192 Perl_cv_undef(pTHX_ CV *cv)
5193 {
5194     dVAR;
5195
5196     PERL_ARGS_ASSERT_CV_UNDEF;
5197
5198     DEBUG_X(PerlIO_printf(Perl_debug_log,
5199           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5200             PTR2UV(cv), PTR2UV(PL_comppad))
5201     );
5202
5203 #ifdef USE_ITHREADS
5204     if (CvFILE(cv) && !CvISXSUB(cv)) {
5205         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5206         Safefree(CvFILE(cv));
5207     }
5208     CvFILE(cv) = NULL;
5209 #endif
5210
5211     if (!CvISXSUB(cv) && CvROOT(cv)) {
5212         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5213             Perl_croak(aTHX_ "Can't undef active subroutine");
5214         ENTER;
5215
5216         PAD_SAVE_SETNULLPAD();
5217
5218         op_free(CvROOT(cv));
5219         CvROOT(cv) = NULL;
5220         CvSTART(cv) = NULL;
5221         LEAVE;
5222     }
5223     SvPOK_off((SV*)cv);         /* forget prototype */
5224     CvGV(cv) = NULL;
5225
5226     pad_undef(cv);
5227
5228     /* remove CvOUTSIDE unless this is an undef rather than a free */
5229     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5230         if (!CvWEAKOUTSIDE(cv))
5231             SvREFCNT_dec(CvOUTSIDE(cv));
5232         CvOUTSIDE(cv) = NULL;
5233     }
5234     if (CvCONST(cv)) {
5235         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5236         CvCONST_off(cv);
5237     }
5238     if (CvISXSUB(cv) && CvXSUB(cv)) {
5239         CvXSUB(cv) = NULL;
5240     }
5241     /* delete all flags except WEAKOUTSIDE */
5242     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5243 }
5244
5245 void
5246 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5247                     const STRLEN len)
5248 {
5249     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5250
5251     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5252        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5253     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5254          || (p && (len != SvCUR(cv) /* Not the same length.  */
5255                    || memNE(p, SvPVX_const(cv), len))))
5256          && ckWARN_d(WARN_PROTOTYPE)) {
5257         SV* const msg = sv_newmortal();
5258         SV* name = NULL;
5259
5260         if (gv)
5261             gv_efullname3(name = sv_newmortal(), gv, NULL);
5262         sv_setpvs(msg, "Prototype mismatch:");
5263         if (name)
5264             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5265         if (SvPOK(cv))
5266             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5267         else
5268             sv_catpvs(msg, ": none");
5269         sv_catpvs(msg, " vs ");
5270         if (p)
5271             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5272         else
5273             sv_catpvs(msg, "none");
5274         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5275     }
5276 }
5277
5278 static void const_sv_xsub(pTHX_ CV* cv);
5279
5280 /*
5281
5282 =head1 Optree Manipulation Functions
5283
5284 =for apidoc cv_const_sv
5285
5286 If C<cv> is a constant sub eligible for inlining. returns the constant
5287 value returned by the sub.  Otherwise, returns NULL.
5288
5289 Constant subs can be created with C<newCONSTSUB> or as described in
5290 L<perlsub/"Constant Functions">.
5291
5292 =cut
5293 */
5294 SV *
5295 Perl_cv_const_sv(pTHX_ CV *cv)
5296 {
5297     PERL_UNUSED_CONTEXT;
5298     if (!cv)
5299         return NULL;
5300     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5301         return NULL;
5302     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5303 }
5304
5305 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5306  * Can be called in 3 ways:
5307  *
5308  * !cv
5309  *      look for a single OP_CONST with attached value: return the value
5310  *
5311  * cv && CvCLONE(cv) && !CvCONST(cv)
5312  *
5313  *      examine the clone prototype, and if contains only a single
5314  *      OP_CONST referencing a pad const, or a single PADSV referencing
5315  *      an outer lexical, return a non-zero value to indicate the CV is
5316  *      a candidate for "constizing" at clone time
5317  *
5318  * cv && CvCONST(cv)
5319  *
5320  *      We have just cloned an anon prototype that was marked as a const
5321  *      candidiate. Try to grab the current value, and in the case of
5322  *      PADSV, ignore it if it has multiple references. Return the value.
5323  */
5324
5325 SV *
5326 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5327 {
5328     dVAR;
5329     SV *sv = NULL;
5330
5331     if (PL_madskills)
5332         return NULL;
5333
5334     if (!o)
5335         return NULL;
5336
5337     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5338         o = cLISTOPo->op_first->op_sibling;
5339
5340     for (; o; o = o->op_next) {
5341         const OPCODE type = o->op_type;
5342
5343         if (sv && o->op_next == o)
5344             return sv;
5345         if (o->op_next != o) {
5346             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5347                 continue;
5348             if (type == OP_DBSTATE)
5349                 continue;
5350         }
5351         if (type == OP_LEAVESUB || type == OP_RETURN)
5352             break;
5353         if (sv)
5354             return NULL;
5355         if (type == OP_CONST && cSVOPo->op_sv)
5356             sv = cSVOPo->op_sv;
5357         else if (cv && type == OP_CONST) {
5358             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5359             if (!sv)
5360                 return NULL;
5361         }
5362         else if (cv && type == OP_PADSV) {
5363             if (CvCONST(cv)) { /* newly cloned anon */
5364                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5365                 /* the candidate should have 1 ref from this pad and 1 ref
5366                  * from the parent */
5367                 if (!sv || SvREFCNT(sv) != 2)
5368                     return NULL;
5369                 sv = newSVsv(sv);
5370                 SvREADONLY_on(sv);
5371                 return sv;
5372             }
5373             else {
5374                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5375                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5376             }
5377         }
5378         else {
5379             return NULL;
5380         }
5381     }
5382     return sv;
5383 }
5384
5385 #ifdef PERL_MAD
5386 OP *
5387 #else
5388 void
5389 #endif
5390 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5391 {
5392 #if 0
5393     /* This would be the return value, but the return cannot be reached.  */
5394     OP* pegop = newOP(OP_NULL, 0);
5395 #endif
5396
5397     PERL_UNUSED_ARG(floor);
5398
5399     if (o)
5400         SAVEFREEOP(o);
5401     if (proto)
5402         SAVEFREEOP(proto);
5403     if (attrs)
5404         SAVEFREEOP(attrs);
5405     if (block)
5406         SAVEFREEOP(block);
5407     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5408 #ifdef PERL_MAD
5409     NORETURN_FUNCTION_END;
5410 #endif
5411 }
5412
5413 CV *
5414 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5415 {
5416     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5417 }
5418
5419 CV *
5420 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5421 {
5422     dVAR;
5423     const char *aname;
5424     GV *gv;
5425     const char *ps;
5426     STRLEN ps_len;
5427     register CV *cv = NULL;
5428     SV *const_sv;
5429     /* If the subroutine has no body, no attributes, and no builtin attributes
5430        then it's just a sub declaration, and we may be able to get away with
5431        storing with a placeholder scalar in the symbol table, rather than a
5432        full GV and CV.  If anything is present then it will take a full CV to
5433        store it.  */
5434     const I32 gv_fetch_flags
5435         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5436            || PL_madskills)
5437         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5438     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5439
5440     if (proto) {
5441         assert(proto->op_type == OP_CONST);
5442         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5443     }
5444     else
5445         ps = NULL;
5446
5447     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5448         SV * const sv = sv_newmortal();
5449         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5450                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5451                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5452         aname = SvPVX_const(sv);
5453     }
5454     else
5455         aname = NULL;
5456
5457     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5458         : gv_fetchpv(aname ? aname
5459                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5460                      gv_fetch_flags, SVt_PVCV);
5461
5462     if (!PL_madskills) {
5463         if (o)
5464             SAVEFREEOP(o);
5465         if (proto)
5466             SAVEFREEOP(proto);
5467         if (attrs)
5468             SAVEFREEOP(attrs);
5469     }
5470
5471     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5472                                            maximum a prototype before. */
5473         if (SvTYPE(gv) > SVt_NULL) {
5474             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5475                 && ckWARN_d(WARN_PROTOTYPE))
5476             {
5477                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5478             }
5479             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5480         }
5481         if (ps)
5482             sv_setpvn((SV*)gv, ps, ps_len);
5483         else
5484             sv_setiv((SV*)gv, -1);
5485
5486         SvREFCNT_dec(PL_compcv);
5487         cv = PL_compcv = NULL;
5488         goto done;
5489     }
5490
5491     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5492
5493 #ifdef GV_UNIQUE_CHECK
5494     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5495         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5496     }
5497 #endif
5498
5499     if (!block || !ps || *ps || attrs
5500         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5501 #ifdef PERL_MAD
5502         || block->op_type == OP_NULL
5503 #endif
5504         )
5505         const_sv = NULL;
5506     else
5507         const_sv = op_const_sv(block, NULL);
5508
5509     if (cv) {
5510         const bool exists = CvROOT(cv) || CvXSUB(cv);
5511
5512 #ifdef GV_UNIQUE_CHECK
5513         if (exists && GvUNIQUE(gv)) {
5514             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5515         }
5516 #endif
5517
5518         /* if the subroutine doesn't exist and wasn't pre-declared
5519          * with a prototype, assume it will be AUTOLOADed,
5520          * skipping the prototype check
5521          */
5522         if (exists || SvPOK(cv))
5523             cv_ckproto_len(cv, gv, ps, ps_len);
5524         /* already defined (or promised)? */
5525         if (exists || GvASSUMECV(gv)) {
5526             if ((!block
5527 #ifdef PERL_MAD
5528                  || block->op_type == OP_NULL
5529 #endif
5530                  )&& !attrs) {
5531                 if (CvFLAGS(PL_compcv)) {
5532                     /* might have had built-in attrs applied */
5533                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5534                 }
5535                 /* just a "sub foo;" when &foo is already defined */
5536                 SAVEFREESV(PL_compcv);
5537                 goto done;
5538             }
5539             if (block
5540 #ifdef PERL_MAD
5541                 && block->op_type != OP_NULL
5542 #endif
5543                 ) {
5544                 if (ckWARN(WARN_REDEFINE)
5545                     || (CvCONST(cv)
5546                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5547                 {
5548                     const line_t oldline = CopLINE(PL_curcop);
5549                     if (PL_parser && PL_parser->copline != NOLINE)
5550                         CopLINE_set(PL_curcop, PL_parser->copline);
5551                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5552                         CvCONST(cv) ? "Constant subroutine %s redefined"
5553                                     : "Subroutine %s redefined", name);
5554                     CopLINE_set(PL_curcop, oldline);
5555                 }
5556 #ifdef PERL_MAD
5557                 if (!PL_minus_c)        /* keep old one around for madskills */
5558 #endif
5559                     {
5560                         /* (PL_madskills unset in used file.) */
5561                         SvREFCNT_dec(cv);
5562                     }
5563                 cv = NULL;
5564             }
5565         }
5566     }
5567     if (const_sv) {
5568         SvREFCNT_inc_simple_void_NN(const_sv);
5569         if (cv) {
5570             assert(!CvROOT(cv) && !CvCONST(cv));
5571             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5572             CvXSUBANY(cv).any_ptr = const_sv;
5573             CvXSUB(cv) = const_sv_xsub;
5574             CvCONST_on(cv);
5575             CvISXSUB_on(cv);
5576         }
5577         else {
5578             GvCV(gv) = NULL;
5579             cv = newCONSTSUB(NULL, name, const_sv);
5580         }
5581         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5582             (CvGV(cv) && GvSTASH(CvGV(cv)))
5583                 ? GvSTASH(CvGV(cv))
5584                 : CvSTASH(cv)
5585                     ? CvSTASH(cv)
5586                     : PL_curstash
5587         );
5588         if (PL_madskills)
5589             goto install_block;
5590         op_free(block);
5591         SvREFCNT_dec(PL_compcv);
5592         PL_compcv = NULL;
5593         goto done;
5594     }
5595     if (attrs) {
5596         HV *stash;
5597         SV *rcv;
5598
5599         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5600          * before we clobber PL_compcv.
5601          */
5602         if (cv && (!block
5603 #ifdef PERL_MAD
5604                     || block->op_type == OP_NULL
5605 #endif
5606                     )) {
5607             rcv = (SV*)cv;
5608             /* Might have had built-in attributes applied -- propagate them. */
5609             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5610             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5611                 stash = GvSTASH(CvGV(cv));
5612             else if (CvSTASH(cv))
5613                 stash = CvSTASH(cv);
5614             else
5615                 stash = PL_curstash;
5616         }
5617         else {
5618             /* possibly about to re-define existing subr -- ignore old cv */
5619             rcv = (SV*)PL_compcv;
5620             if (name && GvSTASH(gv))
5621                 stash = GvSTASH(gv);
5622             else
5623                 stash = PL_curstash;
5624         }
5625         apply_attrs(stash, rcv, attrs, FALSE);
5626     }
5627     if (cv) {                           /* must reuse cv if autoloaded */
5628         if (
5629 #ifdef PERL_MAD
5630             (
5631 #endif
5632              !block
5633 #ifdef PERL_MAD
5634              || block->op_type == OP_NULL) && !PL_madskills
5635 #endif
5636              ) {
5637             /* got here with just attrs -- work done, so bug out */
5638             SAVEFREESV(PL_compcv);
5639             goto done;
5640         }
5641         /* transfer PL_compcv to cv */
5642         cv_undef(cv);
5643         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5644         if (!CvWEAKOUTSIDE(cv))
5645             SvREFCNT_dec(CvOUTSIDE(cv));
5646         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5647         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5648         CvOUTSIDE(PL_compcv) = 0;
5649         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5650         CvPADLIST(PL_compcv) = 0;
5651         /* inner references to PL_compcv must be fixed up ... */
5652         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5653         /* ... before we throw it away */
5654         SvREFCNT_dec(PL_compcv);
5655         PL_compcv = cv;
5656         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5657           ++PL_sub_generation;
5658     }
5659     else {
5660         cv = PL_compcv;
5661         if (name) {
5662             GvCV(gv) = cv;
5663             if (PL_madskills) {
5664                 if (strEQ(name, "import")) {
5665                     PL_formfeed = (SV*)cv;
5666                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5667                 }
5668             }
5669             GvCVGEN(gv) = 0;
5670             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5671         }
5672     }
5673     CvGV(cv) = gv;
5674     CvFILE_set_from_cop(cv, PL_curcop);
5675     CvSTASH(cv) = PL_curstash;
5676
5677     if (ps)
5678         sv_setpvn((SV*)cv, ps, ps_len);
5679
5680     if (PL_parser && PL_parser->error_count) {
5681         op_free(block);
5682         block = NULL;
5683         if (name) {
5684             const char *s = strrchr(name, ':');
5685             s = s ? s+1 : name;
5686             if (strEQ(s, "BEGIN")) {
5687                 const char not_safe[] =
5688                     "BEGIN not safe after errors--compilation aborted";
5689                 if (PL_in_eval & EVAL_KEEPERR)
5690                     Perl_croak(aTHX_ not_safe);
5691                 else {
5692                     /* force display of errors found but not reported */
5693                     sv_catpv(ERRSV, not_safe);
5694                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5695                 }
5696             }
5697         }
5698     }
5699  install_block:
5700     if (!block)
5701         goto done;
5702
5703     if (CvLVALUE(cv)) {
5704         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5705                              mod(scalarseq(block), OP_LEAVESUBLV));
5706         block->op_attached = 1;
5707     }
5708     else {
5709         /* This makes sub {}; work as expected.  */
5710         if (block->op_type == OP_STUB) {
5711             OP* const newblock = newSTATEOP(0, NULL, 0);
5712 #ifdef PERL_MAD
5713             op_getmad(block,newblock,'B');
5714 #else
5715             op_free(block);
5716 #endif
5717             block = newblock;
5718         }
5719         else
5720             block->op_attached = 1;
5721         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5722     }
5723     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5724     OpREFCNT_set(CvROOT(cv), 1);
5725     CvSTART(cv) = LINKLIST(CvROOT(cv));
5726     CvROOT(cv)->op_next = 0;
5727     CALL_PEEP(CvSTART(cv));
5728
5729     /* now that optimizer has done its work, adjust pad values */
5730
5731     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5732
5733     if (CvCLONE(cv)) {
5734         assert(!CvCONST(cv));
5735         if (ps && !*ps && op_const_sv(block, cv))
5736             CvCONST_on(cv);
5737     }
5738
5739     if (name || aname) {
5740         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5741             SV * const sv = newSV(0);
5742             SV * const tmpstr = sv_newmortal();
5743             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5744                                                   GV_ADDMULTI, SVt_PVHV);
5745             HV *hv;
5746
5747             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5748                            CopFILE(PL_curcop),
5749                            (long)PL_subline, (long)CopLINE(PL_curcop));
5750             gv_efullname3(tmpstr, gv, NULL);
5751             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5752                     SvCUR(tmpstr), sv, 0);
5753             hv = GvHVn(db_postponed);
5754             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5755                 CV * const pcv = GvCV(db_postponed);
5756                 if (pcv) {
5757                     dSP;
5758                     PUSHMARK(SP);
5759                     XPUSHs(tmpstr);
5760                     PUTBACK;
5761                     call_sv((SV*)pcv, G_DISCARD);
5762                 }
5763             }
5764         }
5765
5766         if (name && ! (PL_parser && PL_parser->error_count))
5767             process_special_blocks(name, gv, cv);
5768     }
5769
5770   done:
5771     if (PL_parser)
5772         PL_parser->copline = NOLINE;
5773     LEAVE_SCOPE(floor);
5774     return cv;
5775 }
5776
5777 STATIC void
5778 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5779                          CV *const cv)
5780 {
5781     const char *const colon = strrchr(fullname,':');
5782     const char *const name = colon ? colon + 1 : fullname;
5783
5784     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5785
5786     if (*name == 'B') {
5787         if (strEQ(name, "BEGIN")) {
5788             const I32 oldscope = PL_scopestack_ix;
5789             ENTER;
5790             SAVECOPFILE(&PL_compiling);
5791             SAVECOPLINE(&PL_compiling);
5792
5793             DEBUG_x( dump_sub(gv) );
5794             Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5795             GvCV(gv) = 0;               /* cv has been hijacked */
5796             call_list(oldscope, PL_beginav);
5797
5798             PL_curcop = &PL_compiling;
5799             CopHINTS_set(&PL_compiling, PL_hints);
5800             LEAVE;
5801         }
5802         else
5803             return;
5804     } else {
5805         if (*name == 'E') {
5806             if strEQ(name, "END") {
5807                 DEBUG_x( dump_sub(gv) );
5808                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5809             } else
5810                 return;
5811         } else if (*name == 'U') {
5812             if (strEQ(name, "UNITCHECK")) {
5813                 /* It's never too late to run a unitcheck block */
5814                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5815             }
5816             else
5817                 return;
5818         } else if (*name == 'C') {
5819             if (strEQ(name, "CHECK")) {
5820                 if (PL_main_start && ckWARN(WARN_VOID))
5821                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5822                                 "Too late to run CHECK block");
5823                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5824             }
5825             else
5826                 return;
5827         } else if (*name == 'I') {
5828             if (strEQ(name, "INIT")) {
5829                 if (PL_main_start && ckWARN(WARN_VOID))
5830                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5831                                 "Too late to run INIT block");
5832                 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5833             }
5834             else
5835                 return;
5836         } else
5837             return;
5838         DEBUG_x( dump_sub(gv) );
5839         GvCV(gv) = 0;           /* cv has been hijacked */
5840     }
5841 }
5842
5843 /*
5844 =for apidoc newCONSTSUB
5845
5846 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5847 eligible for inlining at compile-time.
5848
5849 =cut
5850 */
5851
5852 CV *
5853 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5854 {
5855     dVAR;
5856     CV* cv;
5857 #ifdef USE_ITHREADS
5858     const char *const temp_p = CopFILE(PL_curcop);
5859     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5860 #else
5861     SV *const temp_sv = CopFILESV(PL_curcop);
5862     STRLEN len;
5863     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5864 #endif
5865     char *const file = savepvn(temp_p, temp_p ? len : 0);
5866
5867     ENTER;
5868
5869     if (IN_PERL_RUNTIME) {
5870         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5871          * an op shared between threads. Use a non-shared COP for our
5872          * dirty work */
5873          SAVEVPTR(PL_curcop);
5874          PL_curcop = &PL_compiling;
5875     }
5876     SAVECOPLINE(PL_curcop);
5877     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5878
5879     SAVEHINTS();
5880     PL_hints &= ~HINT_BLOCK_SCOPE;
5881
5882     if (stash) {
5883         SAVESPTR(PL_curstash);
5884         SAVECOPSTASH(PL_curcop);
5885         PL_curstash = stash;
5886         CopSTASH_set(PL_curcop,stash);
5887     }
5888
5889     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5890        and so doesn't get free()d.  (It's expected to be from the C pre-
5891        processor __FILE__ directive). But we need a dynamically allocated one,
5892        and we need it to get freed.  */
5893     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5894     CvXSUBANY(cv).any_ptr = sv;
5895     CvCONST_on(cv);
5896     Safefree(file);
5897
5898 #ifdef USE_ITHREADS
5899     if (stash)
5900         CopSTASH_free(PL_curcop);
5901 #endif
5902     LEAVE;
5903
5904     return cv;
5905 }
5906
5907 CV *
5908 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5909                  const char *const filename, const char *const proto,
5910                  U32 flags)
5911 {
5912     CV *cv = newXS(name, subaddr, filename);
5913
5914     PERL_ARGS_ASSERT_NEWXS_FLAGS;
5915
5916     if (flags & XS_DYNAMIC_FILENAME) {
5917         /* We need to "make arrangements" (ie cheat) to ensure that the
5918            filename lasts as long as the PVCV we just created, but also doesn't
5919            leak  */
5920         STRLEN filename_len = strlen(filename);
5921         STRLEN proto_and_file_len = filename_len;
5922         char *proto_and_file;
5923         STRLEN proto_len;
5924
5925         if (proto) {
5926             proto_len = strlen(proto);
5927             proto_and_file_len += proto_len;
5928
5929             Newx(proto_and_file, proto_and_file_len + 1, char);
5930             Copy(proto, proto_and_file, proto_len, char);
5931             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5932         } else {
5933             proto_len = 0;
5934             proto_and_file = savepvn(filename, filename_len);
5935         }
5936
5937         /* This gets free()d.  :-)  */
5938         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5939                         SV_HAS_TRAILING_NUL);
5940         if (proto) {
5941             /* This gives us the correct prototype, rather than one with the
5942                file name appended.  */
5943             SvCUR_set(cv, proto_len);
5944         } else {
5945             SvPOK_off(cv);
5946         }
5947         CvFILE(cv) = proto_and_file + proto_len;
5948     } else {
5949         sv_setpv((SV *)cv, proto);
5950     }
5951     return cv;
5952 }
5953
5954 /*
5955 =for apidoc U||newXS
5956
5957 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5958 static storage, as it is used directly as CvFILE(), without a copy being made.
5959
5960 =cut
5961 */
5962
5963 CV *
5964 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5965 {
5966     dVAR;
5967     GV * const gv = gv_fetchpv(name ? name :
5968                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5969                         GV_ADDMULTI, SVt_PVCV);
5970     register CV *cv;
5971
5972     PERL_ARGS_ASSERT_NEWXS;
5973
5974     if (!subaddr)
5975         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5976
5977     if ((cv = (name ? GvCV(gv) : NULL))) {
5978         if (GvCVGEN(gv)) {
5979             /* just a cached method */
5980             SvREFCNT_dec(cv);
5981             cv = NULL;
5982         }
5983         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5984             /* already defined (or promised) */
5985             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5986             if (ckWARN(WARN_REDEFINE)) {
5987                 GV * const gvcv = CvGV(cv);
5988                 if (gvcv) {
5989                     HV * const stash = GvSTASH(gvcv);
5990                     if (stash) {
5991                         const char *redefined_name = HvNAME_get(stash);
5992                         if ( strEQ(redefined_name,"autouse") ) {
5993                             const line_t oldline = CopLINE(PL_curcop);
5994                             if (PL_parser && PL_parser->copline != NOLINE)
5995                                 CopLINE_set(PL_curcop, PL_parser->copline);
5996                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5997                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5998                                                     : "Subroutine %s redefined"
5999                                         ,name);
6000                             CopLINE_set(PL_curcop, oldline);
6001                         }
6002                     }
6003                 }
6004             }
6005             SvREFCNT_dec(cv);
6006             cv = NULL;
6007         }
6008     }
6009
6010     if (cv)                             /* must reuse cv if autoloaded */
6011         cv_undef(cv);
6012     else {
6013         cv = (CV*)newSV_type(SVt_PVCV);
6014         if (name) {
6015             GvCV(gv) = cv;
6016             GvCVGEN(gv) = 0;
6017             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6018         }
6019     }
6020     CvGV(cv) = gv;
6021     (void)gv_fetchfile(filename);
6022     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6023                                    an external constant string */
6024     CvISXSUB_on(cv);
6025     CvXSUB(cv) = subaddr;
6026
6027     if (name)
6028         process_special_blocks(name, gv, cv);
6029     else
6030         CvANON_on(cv);
6031
6032     return cv;
6033 }
6034
6035 #ifdef PERL_MAD
6036 OP *
6037 #else
6038 void
6039 #endif
6040 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6041 {
6042     dVAR;
6043     register CV *cv;
6044 #ifdef PERL_MAD
6045     OP* pegop = newOP(OP_NULL, 0);
6046 #endif
6047
6048     GV * const gv = o
6049         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6050         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6051
6052 #ifdef GV_UNIQUE_CHECK
6053     if (GvUNIQUE(gv)) {
6054         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6055     }
6056 #endif
6057     GvMULTI_on(gv);
6058     if ((cv = GvFORM(gv))) {
6059         if (ckWARN(WARN_REDEFINE)) {
6060             const line_t oldline = CopLINE(PL_curcop);
6061             if (PL_parser && PL_parser->copline != NOLINE)
6062                 CopLINE_set(PL_curcop, PL_parser->copline);
6063             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6064                         o ? "Format %"SVf" redefined"
6065                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6066             CopLINE_set(PL_curcop, oldline);
6067         }
6068         SvREFCNT_dec(cv);
6069     }
6070     cv = PL_compcv;
6071     GvFORM(gv) = cv;
6072     CvGV(cv) = gv;
6073     CvFILE_set_from_cop(cv, PL_curcop);
6074
6075
6076     pad_tidy(padtidy_FORMAT);
6077     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6078     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6079     OpREFCNT_set(CvROOT(cv), 1);
6080     CvSTART(cv) = LINKLIST(CvROOT(cv));
6081     CvROOT(cv)->op_next = 0;
6082     CALL_PEEP(CvSTART(cv));
6083 #ifdef PERL_MAD
6084     op_getmad(o,pegop,'n');
6085     op_getmad_weak(block, pegop, 'b');
6086 #else
6087     op_free(o);
6088 #endif
6089     if (PL_parser)
6090         PL_parser->copline = NOLINE;
6091     LEAVE_SCOPE(floor);
6092 #ifdef PERL_MAD
6093     return pegop;
6094 #endif
6095 }
6096
6097 OP *
6098 Perl_newANONLIST(pTHX_ OP *o)
6099 {
6100     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6101 }
6102
6103 OP *
6104 Perl_newANONHASH(pTHX_ OP *o)
6105 {
6106     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6107 }
6108
6109 OP *
6110 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6111 {
6112     return newANONATTRSUB(floor, proto, NULL, block);
6113 }
6114
6115 OP *
6116 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6117 {
6118     return newUNOP(OP_REFGEN, 0,
6119         newSVOP(OP_ANONCODE, 0,
6120                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6121 }
6122
6123 OP *
6124 Perl_oopsAV(pTHX_ OP *o)
6125 {
6126     dVAR;
6127
6128     PERL_ARGS_ASSERT_OOPSAV;
6129
6130     switch (o->op_type) {
6131     case OP_PADSV:
6132         o->op_type = OP_PADAV;
6133         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6134         return ref(o, OP_RV2AV);
6135
6136     case OP_RV2SV:
6137         o->op_type = OP_RV2AV;
6138         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6139         ref(o, OP_RV2AV);
6140         break;
6141
6142     default:
6143         if (ckWARN_d(WARN_INTERNAL))
6144             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6145         break;
6146     }
6147     return o;
6148 }
6149
6150 OP *
6151 Perl_oopsHV(pTHX_ OP *o)
6152 {
6153     dVAR;
6154
6155     PERL_ARGS_ASSERT_OOPSHV;
6156
6157     switch (o->op_type) {
6158     case OP_PADSV:
6159     case OP_PADAV:
6160         o->op_type = OP_PADHV;
6161         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6162         return ref(o, OP_RV2HV);
6163
6164     case OP_RV2SV:
6165     case OP_RV2AV:
6166         o->op_type = OP_RV2HV;
6167         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6168         ref(o, OP_RV2HV);
6169         break;
6170
6171     default:
6172         if (ckWARN_d(WARN_INTERNAL))
6173             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6174         break;
6175     }
6176     return o;
6177 }
6178
6179 OP *
6180 Perl_newAVREF(pTHX_ OP *o)
6181 {
6182     dVAR;
6183
6184     PERL_ARGS_ASSERT_NEWAVREF;
6185
6186     if (o->op_type == OP_PADANY) {
6187         o->op_type = OP_PADAV;
6188         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6189         return o;
6190     }
6191     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6192                 && ckWARN(WARN_DEPRECATED)) {
6193         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6194                 "Using an array as a reference is deprecated");
6195     }
6196     return newUNOP(OP_RV2AV, 0, scalar(o));
6197 }
6198
6199 OP *
6200 Perl_newGVREF(pTHX_ I32 type, OP *o)
6201 {
6202     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6203         return newUNOP(OP_NULL, 0, o);
6204     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6205 }
6206
6207 OP *
6208 Perl_newHVREF(pTHX_ OP *o)
6209 {
6210     dVAR;
6211
6212     PERL_ARGS_ASSERT_NEWHVREF;
6213
6214     if (o->op_type == OP_PADANY) {
6215         o->op_type = OP_PADHV;
6216         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6217         return o;
6218     }
6219     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6220                 && ckWARN(WARN_DEPRECATED)) {
6221         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6222                 "Using a hash as a reference is deprecated");
6223     }
6224     return newUNOP(OP_RV2HV, 0, scalar(o));
6225 }
6226
6227 OP *
6228 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6229 {
6230     return newUNOP(OP_RV2CV, flags, scalar(o));
6231 }
6232
6233 OP *
6234 Perl_newSVREF(pTHX_ OP *o)
6235 {
6236     dVAR;
6237
6238     PERL_ARGS_ASSERT_NEWSVREF;
6239
6240     if (o->op_type == OP_PADANY) {
6241         o->op_type = OP_PADSV;
6242         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6243         return o;
6244     }
6245     return newUNOP(OP_RV2SV, 0, scalar(o));
6246 }
6247
6248 /* Check routines. See the comments at the top of this file for details
6249  * on when these are called */
6250
6251 OP *
6252 Perl_ck_anoncode(pTHX_ OP *o)
6253 {
6254     PERL_ARGS_ASSERT_CK_ANONCODE;
6255
6256     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6257     if (!PL_madskills)
6258         cSVOPo->op_sv = NULL;
6259     return o;
6260 }
6261
6262 OP *
6263 Perl_ck_bitop(pTHX_ OP *o)
6264 {
6265     dVAR;
6266
6267     PERL_ARGS_ASSERT_CK_BITOP;
6268
6269 #define OP_IS_NUMCOMPARE(op) \
6270         ((op) == OP_LT   || (op) == OP_I_LT || \
6271          (op) == OP_GT   || (op) == OP_I_GT || \
6272          (op) == OP_LE   || (op) == OP_I_LE || \
6273          (op) == OP_GE   || (op) == OP_I_GE || \
6274          (op) == OP_EQ   || (op) == OP_I_EQ || \
6275          (op) == OP_NE   || (op) == OP_I_NE || \
6276          (op) == OP_NCMP || (op) == OP_I_NCMP)
6277     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6278     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6279             && (o->op_type == OP_BIT_OR
6280              || o->op_type == OP_BIT_AND
6281              || o->op_type == OP_BIT_XOR))
6282     {
6283         const OP * const left = cBINOPo->op_first;
6284         const OP * const right = left->op_sibling;
6285         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6286                 (left->op_flags & OPf_PARENS) == 0) ||
6287             (OP_IS_NUMCOMPARE(right->op_type) &&
6288                 (right->op_flags & OPf_PARENS) == 0))
6289             if (ckWARN(WARN_PRECEDENCE))
6290                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6291                         "Possible precedence problem on bitwise %c operator",
6292                         o->op_type == OP_BIT_OR ? '|'
6293                             : o->op_type == OP_BIT_AND ? '&' : '^'
6294                         );
6295     }
6296     return o;
6297 }
6298
6299 OP *
6300 Perl_ck_concat(pTHX_ OP *o)
6301 {
6302     const OP * const kid = cUNOPo->op_first;
6303
6304     PERL_ARGS_ASSERT_CK_CONCAT;
6305     PERL_UNUSED_CONTEXT;
6306
6307     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6308             !(kUNOP->op_first->op_flags & OPf_MOD))
6309         o->op_flags |= OPf_STACKED;
6310     return o;
6311 }
6312
6313 OP *
6314 Perl_ck_spair(pTHX_ OP *o)
6315 {
6316     dVAR;
6317
6318     PERL_ARGS_ASSERT_CK_SPAIR;
6319
6320     if (o->op_flags & OPf_KIDS) {
6321         OP* newop;
6322         OP* kid;
6323         const OPCODE type = o->op_type;
6324         o = modkids(ck_fun(o), type);
6325         kid = cUNOPo->op_first;
6326         newop = kUNOP->op_first->op_sibling;
6327         if (newop) {
6328             const OPCODE type = newop->op_type;
6329             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6330                     type == OP_PADAV || type == OP_PADHV ||
6331                     type == OP_RV2AV || type == OP_RV2HV)
6332                 return o;
6333         }
6334 #ifdef PERL_MAD
6335         op_getmad(kUNOP->op_first,newop,'K');
6336 #else
6337         op_free(kUNOP->op_first);
6338 #endif
6339         kUNOP->op_first = newop;
6340     }
6341     o->op_ppaddr = PL_ppaddr[++o->op_type];
6342     return ck_fun(o);
6343 }
6344
6345 OP *
6346 Perl_ck_delete(pTHX_ OP *o)
6347 {
6348     PERL_ARGS_ASSERT_CK_DELETE;
6349
6350     o = ck_fun(o);
6351     o->op_private = 0;
6352     if (o->op_flags & OPf_KIDS) {
6353         OP * const kid = cUNOPo->op_first;
6354         switch (kid->op_type) {
6355         case OP_ASLICE:
6356             o->op_flags |= OPf_SPECIAL;
6357             /* FALL THROUGH */
6358         case OP_HSLICE:
6359             o->op_private |= OPpSLICE;
6360             break;
6361         case OP_AELEM:
6362             o->op_flags |= OPf_SPECIAL;
6363             /* FALL THROUGH */
6364         case OP_HELEM:
6365             break;
6366         default:
6367             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6368                   OP_DESC(o));
6369         }
6370         op_null(kid);
6371     }
6372     return o;
6373 }
6374
6375 OP *
6376 Perl_ck_die(pTHX_ OP *o)
6377 {
6378     PERL_ARGS_ASSERT_CK_DIE;
6379
6380 #ifdef VMS
6381     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6382 #endif
6383     return ck_fun(o);
6384 }
6385
6386 OP *
6387 Perl_ck_eof(pTHX_ OP *o)
6388 {
6389     dVAR;
6390
6391     PERL_ARGS_ASSERT_CK_EOF;
6392
6393     if (o->op_flags & OPf_KIDS) {
6394         if (cLISTOPo->op_first->op_type == OP_STUB) {
6395             OP * const newop
6396                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6397 #ifdef PERL_MAD
6398             op_getmad(o,newop,'O');
6399 #else
6400             op_free(o);
6401 #endif
6402             o = newop;
6403         }
6404         return ck_fun(o);
6405     }
6406     return o;
6407 }
6408
6409 OP *
6410 Perl_ck_eval(pTHX_ OP *o)
6411 {
6412     dVAR;
6413
6414     PERL_ARGS_ASSERT_CK_EVAL;
6415
6416     PL_hints |= HINT_BLOCK_SCOPE;
6417     if (o->op_flags & OPf_KIDS) {
6418         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6419
6420         if (!kid) {
6421             o->op_flags &= ~OPf_KIDS;
6422             op_null(o);
6423         }
6424         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6425             LOGOP *enter;
6426 #ifdef PERL_MAD
6427             OP* const oldo = o;
6428 #endif
6429
6430             cUNOPo->op_first = 0;
6431 #ifndef PERL_MAD
6432             op_free(o);
6433 #endif
6434
6435             NewOp(1101, enter, 1, LOGOP);
6436             enter->op_type = OP_ENTERTRY;
6437             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6438             enter->op_private = 0;
6439
6440             /* establish postfix order */
6441             enter->op_next = (OP*)enter;
6442
6443             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6444             o->op_type = OP_LEAVETRY;
6445             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6446             enter->op_other = o;
6447             op_getmad(oldo,o,'O');
6448             return o;
6449         }
6450         else {
6451             scalar((OP*)kid);
6452             PL_cv_has_eval = 1;
6453         }
6454     }
6455     else {
6456 #ifdef PERL_MAD
6457         OP* const oldo = o;
6458 #else
6459         op_free(o);
6460 #endif
6461         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6462         op_getmad(oldo,o,'O');
6463     }
6464     o->op_targ = (PADOFFSET)PL_hints;
6465     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6466         /* Store a copy of %^H that pp_entereval can pick up.
6467            OPf_SPECIAL flags the opcode as being for this purpose,
6468            so that it in turn will return a copy at every
6469            eval.*/
6470         OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6471                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6472         cUNOPo->op_first->op_sibling = hhop;
6473         o->op_private |= OPpEVAL_HAS_HH;
6474     }
6475     return o;
6476 }
6477
6478 OP *
6479 Perl_ck_exit(pTHX_ OP *o)
6480 {
6481     PERL_ARGS_ASSERT_CK_EXIT;
6482
6483 #ifdef VMS
6484     HV * const table = GvHV(PL_hintgv);
6485     if (table) {
6486        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6487        if (svp && *svp && SvTRUE(*svp))
6488            o->op_private |= OPpEXIT_VMSISH;
6489     }
6490     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6491 #endif
6492     return ck_fun(o);
6493 }
6494
6495 OP *
6496 Perl_ck_exec(pTHX_ OP *o)
6497 {
6498     PERL_ARGS_ASSERT_CK_EXEC;
6499
6500     if (o->op_flags & OPf_STACKED) {
6501         OP *kid;
6502         o = ck_fun(o);
6503         kid = cUNOPo->op_first->op_sibling;
6504         if (kid->op_type == OP_RV2GV)
6505             op_null(kid);
6506     }
6507     else
6508         o = listkids(o);
6509     return o;
6510 }
6511
6512 OP *
6513 Perl_ck_exists(pTHX_ OP *o)
6514 {
6515     dVAR;
6516
6517     PERL_ARGS_ASSERT_CK_EXISTS;
6518
6519     o = ck_fun(o);
6520     if (o->op_flags & OPf_KIDS) {
6521         OP * const kid = cUNOPo->op_first;
6522         if (kid->op_type == OP_ENTERSUB) {
6523             (void) ref(kid, o->op_type);
6524             if (kid->op_type != OP_RV2CV
6525                         && !(PL_parser && PL_parser->error_count))
6526                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6527                             OP_DESC(o));
6528             o->op_private |= OPpEXISTS_SUB;
6529         }
6530         else if (kid->op_type == OP_AELEM)
6531             o->op_flags |= OPf_SPECIAL;
6532         else if (kid->op_type != OP_HELEM)
6533             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6534                         OP_DESC(o));
6535         op_null(kid);
6536     }
6537     return o;
6538 }
6539
6540 OP *
6541 Perl_ck_rvconst(pTHX_ register OP *o)
6542 {
6543     dVAR;
6544     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6545
6546     PERL_ARGS_ASSERT_CK_RVCONST;
6547
6548     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6549     if (o->op_type == OP_RV2CV)
6550         o->op_private &= ~1;
6551
6552     if (kid->op_type == OP_CONST) {
6553         int iscv;
6554         GV *gv;
6555         SV * const kidsv = kid->op_sv;
6556
6557         /* Is it a constant from cv_const_sv()? */
6558         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6559             SV * const rsv = SvRV(kidsv);
6560             const svtype type = SvTYPE(rsv);
6561             const char *badtype = NULL;
6562
6563             switch (o->op_type) {
6564             case OP_RV2SV:
6565                 if (type > SVt_PVMG)
6566                     badtype = "a SCALAR";
6567                 break;
6568             case OP_RV2AV:
6569                 if (type != SVt_PVAV)
6570                     badtype = "an ARRAY";
6571                 break;
6572             case OP_RV2HV:
6573                 if (type != SVt_PVHV)
6574                     badtype = "a HASH";
6575                 break;
6576             case OP_RV2CV:
6577                 if (type != SVt_PVCV)
6578                     badtype = "a CODE";
6579                 break;
6580             }
6581             if (badtype)
6582                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6583             return o;
6584         }
6585         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6586                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6587             /* If this is an access to a stash, disable "strict refs", because
6588              * stashes aren't auto-vivified at compile-time (unless we store
6589              * symbols in them), and we don't want to produce a run-time
6590              * stricture error when auto-vivifying the stash. */
6591             const char *s = SvPV_nolen(kidsv);
6592             const STRLEN l = SvCUR(kidsv);
6593             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6594                 o->op_private &= ~HINT_STRICT_REFS;
6595         }
6596         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6597             const char *badthing;
6598             switch (o->op_type) {
6599             case OP_RV2SV:
6600                 badthing = "a SCALAR";
6601                 break;
6602             case OP_RV2AV:
6603                 badthing = "an ARRAY";
6604                 break;
6605             case OP_RV2HV:
6606                 badthing = "a HASH";
6607                 break;
6608             default:
6609                 badthing = NULL;
6610                 break;
6611             }
6612             if (badthing)
6613                 Perl_croak(aTHX_
6614                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6615                            SVfARG(kidsv), badthing);
6616         }
6617         /*
6618          * This is a little tricky.  We only want to add the symbol if we
6619          * didn't add it in the lexer.  Otherwise we get duplicate strict
6620          * warnings.  But if we didn't add it in the lexer, we must at
6621          * least pretend like we wanted to add it even if it existed before,
6622          * or we get possible typo warnings.  OPpCONST_ENTERED says
6623          * whether the lexer already added THIS instance of this symbol.
6624          */
6625         iscv = (o->op_type == OP_RV2CV) * 2;
6626         do {
6627             gv = gv_fetchsv(kidsv,
6628                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6629                 iscv
6630                     ? SVt_PVCV
6631                     : o->op_type == OP_RV2SV
6632                         ? SVt_PV
6633                         : o->op_type == OP_RV2AV
6634                             ? SVt_PVAV
6635                             : o->op_type == OP_RV2HV
6636                                 ? SVt_PVHV
6637                                 : SVt_PVGV);
6638         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6639         if (gv) {
6640             kid->op_type = OP_GV;
6641             SvREFCNT_dec(kid->op_sv);
6642 #ifdef USE_ITHREADS
6643             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6644             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6645             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6646             GvIN_PAD_on(gv);
6647             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6648 #else
6649             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6650 #endif
6651             kid->op_private = 0;
6652             kid->op_ppaddr = PL_ppaddr[OP_GV];
6653         }
6654     }
6655     return o;
6656 }
6657
6658 OP *
6659 Perl_ck_ftst(pTHX_ OP *o)
6660 {
6661     dVAR;
6662     const I32 type = o->op_type;
6663
6664     PERL_ARGS_ASSERT_CK_FTST;
6665
6666     if (o->op_flags & OPf_REF) {
6667         NOOP;
6668     }
6669     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6670         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6671         const OPCODE kidtype = kid->op_type;
6672
6673         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6674             OP * const newop = newGVOP(type, OPf_REF,
6675                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6676 #ifdef PERL_MAD
6677             op_getmad(o,newop,'O');
6678 #else
6679             op_free(o);
6680 #endif
6681             return newop;
6682         }
6683         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6684             o->op_private |= OPpFT_ACCESS;
6685         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6686                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6687             o->op_private |= OPpFT_STACKED;
6688     }
6689     else {
6690 #ifdef PERL_MAD
6691         OP* const oldo = o;
6692 #else
6693         op_free(o);
6694 #endif
6695         if (type == OP_FTTTY)
6696             o = newGVOP(type, OPf_REF, PL_stdingv);
6697         else
6698             o = newUNOP(type, 0, newDEFSVOP());
6699         op_getmad(oldo,o,'O');
6700     }
6701     return o;
6702 }
6703
6704 OP *
6705 Perl_ck_fun(pTHX_ OP *o)
6706 {
6707     dVAR;
6708     const int type = o->op_type;
6709     register I32 oa = PL_opargs[type] >> OASHIFT;
6710
6711     PERL_ARGS_ASSERT_CK_FUN;
6712
6713     if (o->op_flags & OPf_STACKED) {
6714         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6715             oa &= ~OA_OPTIONAL;
6716         else
6717             return no_fh_allowed(o);
6718     }
6719
6720     if (o->op_flags & OPf_KIDS) {
6721         OP **tokid = &cLISTOPo->op_first;
6722         register OP *kid = cLISTOPo->op_first;
6723         OP *sibl;
6724         I32 numargs = 0;
6725
6726         if (kid->op_type == OP_PUSHMARK ||
6727             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6728         {
6729             tokid = &kid->op_sibling;
6730             kid = kid->op_sibling;
6731         }
6732         if (!kid && PL_opargs[type] & OA_DEFGV)
6733             *tokid = kid = newDEFSVOP();
6734
6735         while (oa && kid) {
6736             numargs++;
6737             sibl = kid->op_sibling;
6738 #ifdef PERL_MAD
6739             if (!sibl && kid->op_type == OP_STUB) {
6740                 numargs--;
6741                 break;
6742             }
6743 #endif
6744             switch (oa & 7) {
6745             case OA_SCALAR:
6746                 /* list seen where single (scalar) arg expected? */
6747                 if (numargs == 1 && !(oa >> 4)
6748                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6749                 {
6750                     return too_many_arguments(o,PL_op_desc[type]);
6751                 }
6752                 scalar(kid);
6753                 break;
6754             case OA_LIST:
6755                 if (oa < 16) {
6756                     kid = 0;
6757                     continue;
6758                 }
6759                 else
6760                     list(kid);
6761                 break;
6762             case OA_AVREF:
6763                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6764                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6765                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6766                         "Useless use of %s with no values",
6767                         PL_op_desc[type]);
6768
6769                 if (kid->op_type == OP_CONST &&
6770                     (kid->op_private & OPpCONST_BARE))
6771                 {
6772                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6773                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6774                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6775                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6776                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6777                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6778 #ifdef PERL_MAD
6779                     op_getmad(kid,newop,'K');
6780 #else
6781                     op_free(kid);
6782 #endif
6783                     kid = newop;
6784                     kid->op_sibling = sibl;
6785                     *tokid = kid;
6786                 }
6787                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6788                     bad_type(numargs, "array", PL_op_desc[type], kid);
6789                 mod(kid, type);
6790                 break;
6791             case OA_HVREF:
6792                 if (kid->op_type == OP_CONST &&
6793                     (kid->op_private & OPpCONST_BARE))
6794                 {
6795                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6796                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6797                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6798                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6799                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6800                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6801 #ifdef PERL_MAD
6802                     op_getmad(kid,newop,'K');
6803 #else
6804                     op_free(kid);
6805 #endif
6806                     kid = newop;
6807                     kid->op_sibling = sibl;
6808                     *tokid = kid;
6809                 }
6810                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6811                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6812                 mod(kid, type);
6813                 break;
6814             case OA_CVREF:
6815                 {
6816                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6817                     kid->op_sibling = 0;
6818                     linklist(kid);
6819                     newop->op_next = newop;
6820                     kid = newop;
6821                     kid->op_sibling = sibl;
6822                     *tokid = kid;
6823                 }
6824                 break;
6825             case OA_FILEREF:
6826                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6827                     if (kid->op_type == OP_CONST &&
6828                         (kid->op_private & OPpCONST_BARE))
6829                     {
6830                         OP * const newop = newGVOP(OP_GV, 0,
6831                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6832                         if (!(o->op_private & 1) && /* if not unop */
6833                             kid == cLISTOPo->op_last)
6834                             cLISTOPo->op_last = newop;
6835 #ifdef PERL_MAD
6836                         op_getmad(kid,newop,'K');
6837 #else
6838                         op_free(kid);
6839 #endif
6840                         kid = newop;
6841                     }
6842                     else if (kid->op_type == OP_READLINE) {
6843                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6844                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6845                     }
6846                     else {
6847                         I32 flags = OPf_SPECIAL;
6848                         I32 priv = 0;
6849                         PADOFFSET targ = 0;
6850
6851                         /* is this op a FH constructor? */
6852                         if (is_handle_constructor(o,numargs)) {
6853                             const char *name = NULL;
6854                             STRLEN len = 0;
6855
6856                             flags = 0;
6857                             /* Set a flag to tell rv2gv to vivify
6858                              * need to "prove" flag does not mean something
6859                              * else already - NI-S 1999/05/07
6860                              */
6861                             priv = OPpDEREF;
6862                             if (kid->op_type == OP_PADSV) {
6863                                 SV *const namesv
6864                                     = PAD_COMPNAME_SV(kid->op_targ);
6865                                 name = SvPV_const(namesv, len);
6866                             }
6867                             else if (kid->op_type == OP_RV2SV
6868                                      && kUNOP->op_first->op_type == OP_GV)
6869                             {
6870                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6871                                 name = GvNAME(gv);
6872                                 len = GvNAMELEN(gv);
6873                             }
6874                             else if (kid->op_type == OP_AELEM
6875                                      || kid->op_type == OP_HELEM)
6876                             {
6877                                  OP *firstop;
6878                                  OP *op = ((BINOP*)kid)->op_first;
6879                                  name = NULL;
6880                                  if (op) {
6881                                       SV *tmpstr = NULL;
6882                                       const char * const a =
6883                                            kid->op_type == OP_AELEM ?
6884                                            "[]" : "{}";
6885                                       if (((op->op_type == OP_RV2AV) ||
6886                                            (op->op_type == OP_RV2HV)) &&
6887                                           (firstop = ((UNOP*)op)->op_first) &&
6888                                           (firstop->op_type == OP_GV)) {
6889                                            /* packagevar $a[] or $h{} */
6890                                            GV * const gv = cGVOPx_gv(firstop);
6891                                            if (gv)
6892                                                 tmpstr =
6893                                                      Perl_newSVpvf(aTHX_
6894                                                                    "%s%c...%c",
6895                                                                    GvNAME(gv),
6896                                                                    a[0], a[1]);
6897                                       }
6898                                       else if (op->op_type == OP_PADAV
6899                                                || op->op_type == OP_PADHV) {
6900                                            /* lexicalvar $a[] or $h{} */
6901                                            const char * const padname =
6902                                                 PAD_COMPNAME_PV(op->op_targ);
6903                                            if (padname)
6904                                                 tmpstr =
6905                                                      Perl_newSVpvf(aTHX_
6906                                                                    "%s%c...%c",
6907                                                                    padname + 1,
6908                                                                    a[0], a[1]);
6909                                       }
6910                                       if (tmpstr) {
6911                                            name = SvPV_const(tmpstr, len);
6912                                            sv_2mortal(tmpstr);
6913                                       }
6914                                  }
6915                                  if (!name) {
6916                                       name = "__ANONIO__";
6917                                       len = 10;
6918                                  }
6919                                  mod(kid, type);
6920                             }
6921                             if (name) {
6922                                 SV *namesv;
6923                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6924                                 namesv = PAD_SVl(targ);
6925                                 SvUPGRADE(namesv, SVt_PV);
6926                                 if (*name != '$')
6927                                     sv_setpvn(namesv, "$", 1);
6928                                 sv_catpvn(namesv, name, len);
6929                             }
6930                         }
6931                         kid->op_sibling = 0;
6932                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6933                         kid->op_targ = targ;
6934                         kid->op_private |= priv;
6935                     }
6936                     kid->op_sibling = sibl;
6937                     *tokid = kid;
6938                 }
6939                 scalar(kid);
6940                 break;
6941             case OA_SCALARREF:
6942                 mod(scalar(kid), type);
6943                 break;
6944             }
6945             oa >>= 4;
6946             tokid = &kid->op_sibling;
6947             kid = kid->op_sibling;
6948         }
6949 #ifdef PERL_MAD
6950         if (kid && kid->op_type != OP_STUB)
6951             return too_many_arguments(o,OP_DESC(o));
6952         o->op_private |= numargs;
6953 #else
6954         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6955         o->op_private |= numargs;
6956         if (kid)
6957             return too_many_arguments(o,OP_DESC(o));
6958 #endif
6959         listkids(o);
6960     }
6961     else if (PL_opargs[type] & OA_DEFGV) {
6962 #ifdef PERL_MAD
6963         OP *newop = newUNOP(type, 0, newDEFSVOP());
6964         op_getmad(o,newop,'O');
6965         return newop;
6966 #else
6967         /* Ordering of these two is important to keep f_map.t passing.  */
6968         op_free(o);
6969         return newUNOP(type, 0, newDEFSVOP());
6970 #endif
6971     }
6972
6973     if (oa) {
6974         while (oa & OA_OPTIONAL)
6975             oa >>= 4;
6976         if (oa && oa != OA_LIST)
6977             return too_few_arguments(o,OP_DESC(o));
6978     }
6979     return o;
6980 }
6981
6982 OP *
6983 Perl_ck_glob(pTHX_ OP *o)
6984 {
6985     dVAR;
6986     GV *gv;
6987
6988     PERL_ARGS_ASSERT_CK_GLOB;
6989
6990     o = ck_fun(o);
6991     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6992         append_elem(OP_GLOB, o, newDEFSVOP());
6993
6994     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6995           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6996     {
6997         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6998     }
6999
7000 #if !defined(PERL_EXTERNAL_GLOB)
7001     /* XXX this can be tightened up and made more failsafe. */
7002     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7003         GV *glob_gv;
7004         ENTER;
7005         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7006                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7007         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7008         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7009         GvCV(gv) = GvCV(glob_gv);
7010         SvREFCNT_inc_void((SV*)GvCV(gv));
7011         GvIMPORTED_CV_on(gv);
7012         LEAVE;
7013     }
7014 #endif /* PERL_EXTERNAL_GLOB */
7015
7016     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7017         append_elem(OP_GLOB, o,
7018                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7019         o->op_type = OP_LIST;
7020         o->op_ppaddr = PL_ppaddr[OP_LIST];
7021         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7022         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7023         cLISTOPo->op_first->op_targ = 0;
7024         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7025                     append_elem(OP_LIST, o,
7026                                 scalar(newUNOP(OP_RV2CV, 0,
7027                                                newGVOP(OP_GV, 0, gv)))));
7028         o = newUNOP(OP_NULL, 0, ck_subr(o));
7029         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7030         return o;
7031     }
7032     gv = newGVgen("main");
7033     gv_IOadd(gv);
7034     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7035     scalarkids(o);
7036     return o;
7037 }
7038
7039 OP *
7040 Perl_ck_grep(pTHX_ OP *o)
7041 {
7042     dVAR;
7043     LOGOP *gwop = NULL;
7044     OP *kid;
7045     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7046     PADOFFSET offset;
7047
7048     PERL_ARGS_ASSERT_CK_GREP;
7049
7050     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7051     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7052
7053     if (o->op_flags & OPf_STACKED) {
7054         OP* k;
7055         o = ck_sort(o);
7056         kid = cLISTOPo->op_first->op_sibling;
7057         if (!cUNOPx(kid)->op_next)
7058             Perl_croak(aTHX_ "panic: ck_grep");
7059         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7060             kid = k;
7061         }
7062         NewOp(1101, gwop, 1, LOGOP);
7063         kid->op_next = (OP*)gwop;
7064         o->op_flags &= ~OPf_STACKED;
7065     }
7066     kid = cLISTOPo->op_first->op_sibling;
7067     if (type == OP_MAPWHILE)
7068         list(kid);
7069     else
7070         scalar(kid);
7071     o = ck_fun(o);
7072     if (PL_parser && PL_parser->error_count)
7073         return o;
7074     kid = cLISTOPo->op_first->op_sibling;
7075     if (kid->op_type != OP_NULL)
7076         Perl_croak(aTHX_ "panic: ck_grep");
7077     kid = kUNOP->op_first;
7078
7079     if (!gwop)
7080         NewOp(1101, gwop, 1, LOGOP);
7081     gwop->op_type = type;
7082     gwop->op_ppaddr = PL_ppaddr[type];
7083     gwop->op_first = listkids(o);
7084     gwop->op_flags |= OPf_KIDS;
7085     gwop->op_other = LINKLIST(kid);
7086     kid->op_next = (OP*)gwop;
7087     offset = pad_findmy("$_");
7088     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7089         o->op_private = gwop->op_private = 0;
7090         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7091     }
7092     else {
7093         o->op_private = gwop->op_private = OPpGREP_LEX;
7094         gwop->op_targ = o->op_targ = offset;
7095     }
7096
7097     kid = cLISTOPo->op_first->op_sibling;
7098     if (!kid || !kid->op_sibling)
7099         return too_few_arguments(o,OP_DESC(o));
7100     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7101         mod(kid, OP_GREPSTART);
7102
7103     return (OP*)gwop;
7104 }
7105
7106 OP *
7107 Perl_ck_index(pTHX_ OP *o)
7108 {
7109     PERL_ARGS_ASSERT_CK_INDEX;
7110
7111     if (o->op_flags & OPf_KIDS) {
7112         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7113         if (kid)
7114             kid = kid->op_sibling;                      /* get past "big" */
7115         if (kid && kid->op_type == OP_CONST)
7116             fbm_compile(((SVOP*)kid)->op_sv, 0);
7117     }
7118     return ck_fun(o);
7119 }
7120
7121 OP *
7122 Perl_ck_lengthconst(pTHX_ OP *o)
7123 {
7124     PERL_ARGS_ASSERT_CK_LENGTHCONST;
7125
7126     /* XXX length optimization goes here */
7127     return ck_fun(o);
7128 }
7129
7130 OP *
7131 Perl_ck_lfun(pTHX_ OP *o)
7132 {
7133     const OPCODE type = o->op_type;
7134
7135     PERL_ARGS_ASSERT_CK_LFUN;
7136
7137     return modkids(ck_fun(o), type);
7138 }
7139
7140 OP *
7141 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7142 {
7143     PERL_ARGS_ASSERT_CK_DEFINED;
7144
7145     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7146         switch (cUNOPo->op_first->op_type) {
7147         case OP_RV2AV:
7148             /* This is needed for
7149                if (defined %stash::)
7150                to work.   Do not break Tk.
7151                */
7152             break;                      /* Globals via GV can be undef */
7153         case OP_PADAV:
7154         case OP_AASSIGN:                /* Is this a good idea? */
7155             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7156                         "defined(@array) is deprecated");
7157             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7158                         "\t(Maybe you should just omit the defined()?)\n");
7159         break;
7160         case OP_RV2HV:
7161             /* This is needed for
7162                if (defined %stash::)
7163                to work.   Do not break Tk.
7164                */
7165             break;                      /* Globals via GV can be undef */
7166         case OP_PADHV:
7167             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7168                         "defined(%%hash) is deprecated");
7169             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7170                         "\t(Maybe you should just omit the defined()?)\n");
7171             break;
7172         default:
7173             /* no warning */
7174             break;
7175         }
7176     }
7177     return ck_rfun(o);
7178 }
7179
7180 OP *
7181 Perl_ck_readline(pTHX_ OP *o)
7182 {
7183     PERL_ARGS_ASSERT_CK_READLINE;
7184
7185     if (!(o->op_flags & OPf_KIDS)) {
7186         OP * const newop
7187             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7188 #ifdef PERL_MAD
7189         op_getmad(o,newop,'O');
7190 #else
7191         op_free(o);
7192 #endif
7193         return newop;
7194     }
7195     return o;
7196 }
7197
7198 OP *
7199 Perl_ck_rfun(pTHX_ OP *o)
7200 {
7201     const OPCODE type = o->op_type;
7202
7203     PERL_ARGS_ASSERT_CK_RFUN;
7204
7205     return refkids(ck_fun(o), type);
7206 }
7207
7208 OP *
7209 Perl_ck_listiob(pTHX_ OP *o)
7210 {
7211     register OP *kid;
7212
7213     PERL_ARGS_ASSERT_CK_LISTIOB;
7214
7215     kid = cLISTOPo->op_first;
7216     if (!kid) {
7217         o = force_list(o);
7218         kid = cLISTOPo->op_first;
7219     }
7220     if (kid->op_type == OP_PUSHMARK)
7221         kid = kid->op_sibling;
7222     if (kid && o->op_flags & OPf_STACKED)
7223         kid = kid->op_sibling;
7224     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7225         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7226             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7227             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7228             cLISTOPo->op_first->op_sibling = kid;
7229             cLISTOPo->op_last = kid;
7230             kid = kid->op_sibling;
7231         }
7232     }
7233
7234     if (!kid)
7235         append_elem(o->op_type, o, newDEFSVOP());
7236
7237     return listkids(o);
7238 }
7239
7240 OP *
7241 Perl_ck_smartmatch(pTHX_ OP *o)
7242 {
7243     dVAR;
7244     if (0 == (o->op_flags & OPf_SPECIAL)) {
7245         OP *first  = cBINOPo->op_first;
7246         OP *second = first->op_sibling;
7247
7248         /* Implicitly take a reference to an array or hash */
7249         first->op_sibling = NULL;
7250         first = cBINOPo->op_first = ref_array_or_hash(first);
7251         second = first->op_sibling = ref_array_or_hash(second);
7252
7253         /* Implicitly take a reference to a regular expression */
7254         if (first->op_type == OP_MATCH) {
7255             first->op_type = OP_QR;
7256             first->op_ppaddr = PL_ppaddr[OP_QR];
7257         }
7258         if (second->op_type == OP_MATCH) {
7259             second->op_type = OP_QR;
7260             second->op_ppaddr = PL_ppaddr[OP_QR];
7261         }
7262     }
7263
7264     return o;
7265 }
7266
7267
7268 OP *
7269 Perl_ck_sassign(pTHX_ OP *o)
7270 {
7271     dVAR;
7272     OP * const kid = cLISTOPo->op_first;
7273
7274     PERL_ARGS_ASSERT_CK_SASSIGN;
7275
7276     /* has a disposable target? */
7277     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7278         && !(kid->op_flags & OPf_STACKED)
7279         /* Cannot steal the second time! */
7280         && !(kid->op_private & OPpTARGET_MY)
7281         /* Keep the full thing for madskills */
7282         && !PL_madskills
7283         )
7284     {
7285         OP * const kkid = kid->op_sibling;
7286
7287         /* Can just relocate the target. */
7288         if (kkid && kkid->op_type == OP_PADSV
7289             && !(kkid->op_private & OPpLVAL_INTRO))
7290         {
7291             kid->op_targ = kkid->op_targ;
7292             kkid->op_targ = 0;
7293             /* Now we do not need PADSV and SASSIGN. */
7294             kid->op_sibling = o->op_sibling;    /* NULL */
7295             cLISTOPo->op_first = NULL;
7296             op_free(o);
7297             op_free(kkid);
7298             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7299             return kid;
7300         }
7301     }
7302     if (kid->op_sibling) {
7303         OP *kkid = kid->op_sibling;
7304         if (kkid->op_type == OP_PADSV
7305                 && (kkid->op_private & OPpLVAL_INTRO)
7306                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7307             const PADOFFSET target = kkid->op_targ;
7308             OP *const other = newOP(OP_PADSV,
7309                                     kkid->op_flags
7310                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7311             OP *const first = newOP(OP_NULL, 0);
7312             OP *const nullop = newCONDOP(0, first, o, other);
7313             OP *const condop = first->op_next;
7314             /* hijacking PADSTALE for uninitialized state variables */
7315             SvPADSTALE_on(PAD_SVl(target));
7316
7317             condop->op_type = OP_ONCE;
7318             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7319             condop->op_targ = target;
7320             other->op_targ = target;
7321
7322             /* Because we change the type of the op here, we will skip the
7323                assinment binop->op_last = binop->op_first->op_sibling; at the
7324                end of Perl_newBINOP(). So need to do it here. */
7325             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7326
7327             return nullop;
7328         }
7329     }
7330     return o;
7331 }
7332
7333 OP *
7334 Perl_ck_match(pTHX_ OP *o)
7335 {
7336     dVAR;
7337
7338     PERL_ARGS_ASSERT_CK_MATCH;
7339
7340     if (o->op_type != OP_QR && PL_compcv) {
7341         const PADOFFSET offset = pad_findmy("$_");
7342         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7343             o->op_targ = offset;
7344             o->op_private |= OPpTARGET_MY;
7345         }
7346     }
7347     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7348         o->op_private |= OPpRUNTIME;
7349     return o;
7350 }
7351
7352 OP *
7353 Perl_ck_method(pTHX_ OP *o)
7354 {
7355     OP * const kid = cUNOPo->op_first;
7356
7357     PERL_ARGS_ASSERT_CK_METHOD;
7358
7359     if (kid->op_type == OP_CONST) {
7360         SV* sv = kSVOP->op_sv;
7361         const char * const method = SvPVX_const(sv);
7362         if (!(strchr(method, ':') || strchr(method, '\''))) {
7363             OP *cmop;
7364             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7365                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7366             }
7367             else {
7368                 kSVOP->op_sv = NULL;
7369             }
7370             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7371 #ifdef PERL_MAD
7372             op_getmad(o,cmop,'O');
7373 #else
7374             op_free(o);
7375 #endif
7376             return cmop;
7377         }
7378     }
7379     return o;
7380 }
7381
7382 OP *
7383 Perl_ck_null(pTHX_ OP *o)
7384 {
7385     PERL_ARGS_ASSERT_CK_NULL;
7386     PERL_UNUSED_CONTEXT;
7387     return o;
7388 }
7389
7390 OP *
7391 Perl_ck_open(pTHX_ OP *o)
7392 {
7393     dVAR;
7394     HV * const table = GvHV(PL_hintgv);
7395
7396     PERL_ARGS_ASSERT_CK_OPEN;
7397
7398     if (table) {
7399         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7400         if (svp && *svp) {
7401             const I32 mode = mode_from_discipline(*svp);
7402             if (mode & O_BINARY)
7403                 o->op_private |= OPpOPEN_IN_RAW;
7404             else if (mode & O_TEXT)
7405                 o->op_private |= OPpOPEN_IN_CRLF;
7406         }
7407
7408         svp = hv_fetchs(table, "open_OUT", FALSE);
7409         if (svp && *svp) {
7410             const I32 mode = mode_from_discipline(*svp);
7411             if (mode & O_BINARY)
7412                 o->op_private |= OPpOPEN_OUT_RAW;
7413             else if (mode & O_TEXT)
7414                 o->op_private |= OPpOPEN_OUT_CRLF;
7415         }
7416     }
7417     if (o->op_type == OP_BACKTICK) {
7418         if (!(o->op_flags & OPf_KIDS)) {
7419             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7420 #ifdef PERL_MAD
7421             op_getmad(o,newop,'O');
7422 #else
7423             op_free(o);
7424 #endif
7425             return newop;
7426         }
7427         return o;
7428     }
7429     {
7430          /* In case of three-arg dup open remove strictness
7431           * from the last arg if it is a bareword. */
7432          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7433          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7434          OP *oa;
7435          const char *mode;
7436
7437          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7438              (last->op_private & OPpCONST_BARE) &&
7439              (last->op_private & OPpCONST_STRICT) &&
7440              (oa = first->op_sibling) &&                /* The fh. */
7441              (oa = oa->op_sibling) &&                   /* The mode. */
7442              (oa->op_type == OP_CONST) &&
7443              SvPOK(((SVOP*)oa)->op_sv) &&
7444              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7445              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7446              (last == oa->op_sibling))                  /* The bareword. */
7447               last->op_private &= ~OPpCONST_STRICT;
7448     }
7449     return ck_fun(o);
7450 }
7451
7452 OP *
7453 Perl_ck_repeat(pTHX_ OP *o)
7454 {
7455     PERL_ARGS_ASSERT_CK_REPEAT;
7456
7457     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7458         o->op_private |= OPpREPEAT_DOLIST;
7459         cBINOPo->op_first = force_list(cBINOPo->op_first);
7460     }
7461     else
7462         scalar(o);
7463     return o;
7464 }
7465
7466 OP *
7467 Perl_ck_require(pTHX_ OP *o)
7468 {
7469     dVAR;
7470     GV* gv = NULL;
7471
7472     PERL_ARGS_ASSERT_CK_REQUIRE;
7473
7474     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7475         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7476
7477         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7478             SV * const sv = kid->op_sv;
7479             U32 was_readonly = SvREADONLY(sv);
7480             char *s;
7481             STRLEN len;
7482             const char *end;
7483
7484             if (was_readonly) {
7485                 if (SvFAKE(sv)) {
7486                     sv_force_normal_flags(sv, 0);
7487                     assert(!SvREADONLY(sv));
7488                     was_readonly = 0;
7489                 } else {
7490                     SvREADONLY_off(sv);
7491                 }
7492             }
7493
7494             s = SvPVX(sv);
7495             len = SvCUR(sv);
7496             end = s + len;
7497             for (; s < end; s++) {
7498                 if (*s == ':' && s[1] == ':') {
7499                     *s = '/';
7500                     Move(s+2, s+1, end - s - 1, char);
7501                     --end;
7502                 }
7503             }
7504             SvEND_set(sv, end);
7505             sv_catpvs(sv, ".pm");
7506             SvFLAGS(sv) |= was_readonly;
7507         }
7508     }
7509
7510     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7511         /* handle override, if any */
7512         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7513         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7514             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7515             gv = gvp ? *gvp : NULL;
7516         }
7517     }
7518
7519     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7520         OP * const kid = cUNOPo->op_first;
7521         OP * newop;
7522
7523         cUNOPo->op_first = 0;
7524 #ifndef PERL_MAD
7525         op_free(o);
7526 #endif
7527         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7528                                 append_elem(OP_LIST, kid,
7529                                             scalar(newUNOP(OP_RV2CV, 0,
7530                                                            newGVOP(OP_GV, 0,
7531                                                                    gv))))));
7532         op_getmad(o,newop,'O');
7533         return newop;
7534     }
7535
7536     return ck_fun(o);
7537 }
7538
7539 OP *
7540 Perl_ck_return(pTHX_ OP *o)
7541 {
7542     dVAR;
7543
7544     PERL_ARGS_ASSERT_CK_RETURN;
7545
7546     if (CvLVALUE(PL_compcv)) {
7547         OP *kid;
7548         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7549             mod(kid, OP_LEAVESUBLV);
7550     }
7551     return o;
7552 }
7553
7554 OP *
7555 Perl_ck_select(pTHX_ OP *o)
7556 {
7557     dVAR;
7558     OP* kid;
7559
7560     PERL_ARGS_ASSERT_CK_SELECT;
7561
7562     if (o->op_flags & OPf_KIDS) {
7563         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7564         if (kid && kid->op_sibling) {
7565             o->op_type = OP_SSELECT;
7566             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7567             o = ck_fun(o);
7568             return fold_constants(o);
7569         }
7570     }
7571     o = ck_fun(o);
7572     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7573     if (kid && kid->op_type == OP_RV2GV)
7574         kid->op_private &= ~HINT_STRICT_REFS;
7575     return o;
7576 }
7577
7578 OP *
7579 Perl_ck_shift(pTHX_ OP *o)
7580 {
7581     dVAR;
7582     const I32 type = o->op_type;
7583
7584     PERL_ARGS_ASSERT_CK_SHIFT;
7585
7586     if (!(o->op_flags & OPf_KIDS)) {
7587         OP *argop;
7588         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7589 #ifdef PERL_MAD
7590         OP * const oldo = o;
7591 #else
7592         op_free(o);
7593 #endif
7594         argop = newUNOP(OP_RV2AV, 0,
7595             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7596 #ifdef PERL_MAD
7597         o = newUNOP(type, 0, scalar(argop));
7598         op_getmad(oldo,o,'O');
7599         return o;
7600 #else
7601         return newUNOP(type, 0, scalar(argop));
7602 #endif
7603     }
7604     return scalar(modkids(ck_fun(o), type));
7605 }
7606
7607 OP *
7608 Perl_ck_sort(pTHX_ OP *o)
7609 {
7610     dVAR;
7611     OP *firstkid;
7612
7613     PERL_ARGS_ASSERT_CK_SORT;
7614
7615     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7616         HV * const hinthv = GvHV(PL_hintgv);
7617         if (hinthv) {
7618             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7619             if (svp) {
7620                 const I32 sorthints = (I32)SvIV(*svp);
7621                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7622                     o->op_private |= OPpSORT_QSORT;
7623                 if ((sorthints & HINT_SORT_STABLE) != 0)
7624                     o->op_private |= OPpSORT_STABLE;
7625             }
7626         }
7627     }
7628
7629     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7630         simplify_sort(o);
7631     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7632     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7633         OP *k = NULL;
7634         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7635
7636         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7637             linklist(kid);
7638             if (kid->op_type == OP_SCOPE) {
7639                 k = kid->op_next;
7640                 kid->op_next = 0;
7641             }
7642             else if (kid->op_type == OP_LEAVE) {
7643                 if (o->op_type == OP_SORT) {
7644                     op_null(kid);                       /* wipe out leave */
7645                     kid->op_next = kid;
7646
7647                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7648                         if (k->op_next == kid)
7649                             k->op_next = 0;
7650                         /* don't descend into loops */
7651                         else if (k->op_type == OP_ENTERLOOP
7652                                  || k->op_type == OP_ENTERITER)
7653                         {
7654                             k = cLOOPx(k)->op_lastop;
7655                         }
7656                     }
7657                 }
7658                 else
7659                     kid->op_next = 0;           /* just disconnect the leave */
7660                 k = kLISTOP->op_first;
7661             }
7662             CALL_PEEP(k);
7663
7664             kid = firstkid;
7665             if (o->op_type == OP_SORT) {
7666                 /* provide scalar context for comparison function/block */
7667                 kid = scalar(kid);
7668                 kid->op_next = kid;
7669             }
7670             else
7671                 kid->op_next = k;
7672             o->op_flags |= OPf_SPECIAL;
7673         }
7674         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7675             op_null(firstkid);
7676
7677         firstkid = firstkid->op_sibling;
7678     }
7679
7680     /* provide list context for arguments */
7681     if (o->op_type == OP_SORT)
7682         list(firstkid);
7683
7684     return o;
7685 }
7686
7687 STATIC void
7688 S_simplify_sort(pTHX_ OP *o)
7689 {
7690     dVAR;
7691     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7692     OP *k;
7693     int descending;
7694     GV *gv;
7695     const char *gvname;
7696
7697     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7698
7699     if (!(o->op_flags & OPf_STACKED))
7700         return;
7701     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7702     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7703     kid = kUNOP->op_first;                              /* get past null */
7704     if (kid->op_type != OP_SCOPE)
7705         return;
7706     kid = kLISTOP->op_last;                             /* get past scope */
7707     switch(kid->op_type) {
7708         case OP_NCMP:
7709         case OP_I_NCMP:
7710         case OP_SCMP:
7711             break;
7712         default:
7713             return;
7714     }
7715     k = kid;                                            /* remember this node*/
7716     if (kBINOP->op_first->op_type != OP_RV2SV)
7717         return;
7718     kid = kBINOP->op_first;                             /* get past cmp */
7719     if (kUNOP->op_first->op_type != OP_GV)
7720         return;
7721     kid = kUNOP->op_first;                              /* get past rv2sv */
7722     gv = kGVOP_gv;
7723     if (GvSTASH(gv) != PL_curstash)
7724         return;
7725     gvname = GvNAME(gv);
7726     if (*gvname == 'a' && gvname[1] == '\0')
7727         descending = 0;
7728     else if (*gvname == 'b' && gvname[1] == '\0')
7729         descending = 1;
7730     else
7731         return;
7732
7733     kid = k;                                            /* back to cmp */
7734     if (kBINOP->op_last->op_type != OP_RV2SV)
7735         return;
7736     kid = kBINOP->op_last;                              /* down to 2nd arg */
7737     if (kUNOP->op_first->op_type != OP_GV)
7738         return;
7739     kid = kUNOP->op_first;                              /* get past rv2sv */
7740     gv = kGVOP_gv;
7741     if (GvSTASH(gv) != PL_curstash)
7742         return;
7743     gvname = GvNAME(gv);
7744     if ( descending
7745          ? !(*gvname == 'a' && gvname[1] == '\0')
7746          : !(*gvname == 'b' && gvname[1] == '\0'))
7747         return;
7748     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7749     if (descending)
7750         o->op_private |= OPpSORT_DESCEND;
7751     if (k->op_type == OP_NCMP)
7752         o->op_private |= OPpSORT_NUMERIC;
7753     if (k->op_type == OP_I_NCMP)
7754         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7755     kid = cLISTOPo->op_first->op_sibling;
7756     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7757 #ifdef PERL_MAD
7758     op_getmad(kid,o,'S');                             /* then delete it */
7759 #else
7760     op_free(kid);                                     /* then delete it */
7761 #endif
7762 }
7763
7764 OP *
7765 Perl_ck_split(pTHX_ OP *o)
7766 {
7767     dVAR;
7768     register OP *kid;
7769
7770     PERL_ARGS_ASSERT_CK_SPLIT;
7771
7772     if (o->op_flags & OPf_STACKED)
7773         return no_fh_allowed(o);
7774
7775     kid = cLISTOPo->op_first;
7776     if (kid->op_type != OP_NULL)
7777         Perl_croak(aTHX_ "panic: ck_split");
7778     kid = kid->op_sibling;
7779     op_free(cLISTOPo->op_first);
7780     cLISTOPo->op_first = kid;
7781     if (!kid) {
7782         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7783         cLISTOPo->op_last = kid; /* There was only one element previously */
7784     }
7785
7786     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7787         OP * const sibl = kid->op_sibling;
7788         kid->op_sibling = 0;
7789         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7790         if (cLISTOPo->op_first == cLISTOPo->op_last)
7791             cLISTOPo->op_last = kid;
7792         cLISTOPo->op_first = kid;
7793         kid->op_sibling = sibl;
7794     }
7795
7796     kid->op_type = OP_PUSHRE;
7797     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7798     scalar(kid);
7799     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7800       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7801                   "Use of /g modifier is meaningless in split");
7802     }
7803
7804     if (!kid->op_sibling)
7805         append_elem(OP_SPLIT, o, newDEFSVOP());
7806
7807     kid = kid->op_sibling;
7808     scalar(kid);
7809
7810     if (!kid->op_sibling)
7811         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7812     assert(kid->op_sibling);
7813
7814     kid = kid->op_sibling;
7815     scalar(kid);
7816
7817     if (kid->op_sibling)
7818         return too_many_arguments(o,OP_DESC(o));
7819
7820     return o;
7821 }
7822
7823 OP *
7824 Perl_ck_join(pTHX_ OP *o)
7825 {
7826     const OP * const kid = cLISTOPo->op_first->op_sibling;
7827
7828     PERL_ARGS_ASSERT_CK_JOIN;
7829
7830     if (kid && kid->op_type == OP_MATCH) {
7831         if (ckWARN(WARN_SYNTAX)) {
7832             const REGEXP *re = PM_GETRE(kPMOP);
7833             const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7834             const STRLEN len = re ? RX_PRELEN(re) : 6;
7835             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7836                         "/%.*s/ should probably be written as \"%.*s\"",
7837                         (int)len, pmstr, (int)len, pmstr);
7838         }
7839     }
7840     return ck_fun(o);
7841 }
7842
7843 OP *
7844 Perl_ck_subr(pTHX_ OP *o)
7845 {
7846     dVAR;
7847     OP *prev = ((cUNOPo->op_first->op_sibling)
7848              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7849     OP *o2 = prev->op_sibling;
7850     OP *cvop;
7851     const char *proto = NULL;
7852     const char *proto_end = NULL;
7853     CV *cv = NULL;
7854     GV *namegv = NULL;
7855     int optional = 0;
7856     I32 arg = 0;
7857     I32 contextclass = 0;
7858     const char *e = NULL;
7859     bool delete_op = 0;
7860
7861     PERL_ARGS_ASSERT_CK_SUBR;
7862
7863     o->op_private |= OPpENTERSUB_HASTARG;
7864     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7865     if (cvop->op_type == OP_RV2CV) {
7866         SVOP* tmpop;
7867         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7868         op_null(cvop);          /* disable rv2cv */
7869         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7870         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7871             GV *gv = cGVOPx_gv(tmpop);
7872             cv = GvCVu(gv);
7873             if (!cv)
7874                 tmpop->op_private |= OPpEARLY_CV;
7875             else {
7876                 if (SvPOK(cv)) {
7877                     STRLEN len;
7878                     namegv = CvANON(cv) ? gv : CvGV(cv);
7879                     proto = SvPV((SV*)cv, len);
7880                     proto_end = proto + len;
7881                 }
7882             }
7883         }
7884     }
7885     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7886         if (o2->op_type == OP_CONST)
7887             o2->op_private &= ~OPpCONST_STRICT;
7888         else if (o2->op_type == OP_LIST) {
7889             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7890             if (sib && sib->op_type == OP_CONST)
7891                 sib->op_private &= ~OPpCONST_STRICT;
7892         }
7893     }
7894     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7895     if (PERLDB_SUB && PL_curstash != PL_debstash)
7896         o->op_private |= OPpENTERSUB_DB;
7897     while (o2 != cvop) {
7898         OP* o3;
7899         if (PL_madskills && o2->op_type == OP_STUB) {
7900             o2 = o2->op_sibling;
7901             continue;
7902         }
7903         if (PL_madskills && o2->op_type == OP_NULL)
7904             o3 = ((UNOP*)o2)->op_first;
7905         else
7906             o3 = o2;
7907         if (proto) {
7908             if (proto >= proto_end)
7909                 return too_many_arguments(o, gv_ename(namegv));
7910
7911             switch (*proto) {
7912             case ';':
7913                 optional = 1;
7914                 proto++;
7915                 continue;
7916             case '_':
7917                 /* _ must be at the end */
7918                 if (proto[1] && proto[1] != ';')
7919                     goto oops;
7920             case '$':
7921                 proto++;
7922                 arg++;
7923                 scalar(o2);
7924                 break;
7925             case '%':
7926             case '@':
7927                 list(o2);
7928                 arg++;
7929                 break;
7930             case '&':
7931                 proto++;
7932                 arg++;
7933                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7934                     bad_type(arg,
7935                         arg == 1 ? "block or sub {}" : "sub {}",
7936                         gv_ename(namegv), o3);
7937                 break;
7938             case '*':
7939                 /* '*' allows any scalar type, including bareword */
7940                 proto++;
7941                 arg++;
7942                 if (o3->op_type == OP_RV2GV)
7943                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7944                 else if (o3->op_type == OP_CONST)
7945                     o3->op_private &= ~OPpCONST_STRICT;
7946                 else if (o3->op_type == OP_ENTERSUB) {
7947                     /* accidental subroutine, revert to bareword */
7948                     OP *gvop = ((UNOP*)o3)->op_first;
7949                     if (gvop && gvop->op_type == OP_NULL) {
7950                         gvop = ((UNOP*)gvop)->op_first;
7951                         if (gvop) {
7952                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7953                                 ;
7954                             if (gvop &&
7955                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7956                                 (gvop = ((UNOP*)gvop)->op_first) &&
7957                                 gvop->op_type == OP_GV)
7958                             {
7959                                 GV * const gv = cGVOPx_gv(gvop);
7960                                 OP * const sibling = o2->op_sibling;
7961                                 SV * const n = newSVpvs("");
7962 #ifdef PERL_MAD
7963                                 OP * const oldo2 = o2;
7964 #else
7965                                 op_free(o2);
7966 #endif
7967                                 gv_fullname4(n, gv, "", FALSE);
7968                                 o2 = newSVOP(OP_CONST, 0, n);
7969                                 op_getmad(oldo2,o2,'O');
7970                                 prev->op_sibling = o2;
7971                                 o2->op_sibling = sibling;
7972                             }
7973                         }
7974                     }
7975                 }
7976                 scalar(o2);
7977                 break;
7978             case '[': case ']':
7979                  goto oops;
7980                  break;
7981             case '\\':
7982                 proto++;
7983                 arg++;
7984             again:
7985                 switch (*proto++) {
7986                 case '[':
7987                      if (contextclass++ == 0) {
7988                           e = strchr(proto, ']');
7989                           if (!e || e == proto)
7990                                goto oops;
7991                      }
7992                      else
7993                           goto oops;
7994                      goto again;
7995                      break;
7996                 case ']':
7997                      if (contextclass) {
7998                          const char *p = proto;
7999                          const char *const end = proto;
8000                          contextclass = 0;
8001                          while (*--p != '[');
8002                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8003                                                  (int)(end - p), p),
8004                                   gv_ename(namegv), o3);
8005                      } else
8006                           goto oops;
8007                      break;
8008                 case '*':
8009                      if (o3->op_type == OP_RV2GV)
8010                           goto wrapref;
8011                      if (!contextclass)
8012                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8013                      break;
8014                 case '&':
8015                      if (o3->op_type == OP_ENTERSUB)
8016                           goto wrapref;
8017                      if (!contextclass)
8018                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8019                                    o3);
8020                      break;
8021                 case '$':
8022                     if (o3->op_type == OP_RV2SV ||
8023                         o3->op_type == OP_PADSV ||
8024                         o3->op_type == OP_HELEM ||
8025                         o3->op_type == OP_AELEM)
8026                          goto wrapref;
8027                     if (!contextclass)
8028                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8029                      break;
8030                 case '@':
8031                     if (o3->op_type == OP_RV2AV ||
8032                         o3->op_type == OP_PADAV)
8033                          goto wrapref;
8034                     if (!contextclass)
8035                         bad_type(arg, "array", gv_ename(namegv), o3);
8036                     break;
8037                 case '%':
8038                     if (o3->op_type == OP_RV2HV ||
8039                         o3->op_type == OP_PADHV)
8040                          goto wrapref;
8041                     if (!contextclass)
8042                          bad_type(arg, "hash", gv_ename(namegv), o3);
8043                     break;
8044                 wrapref:
8045                     {
8046                         OP* const kid = o2;
8047                         OP* const sib = kid->op_sibling;
8048                         kid->op_sibling = 0;
8049                         o2 = newUNOP(OP_REFGEN, 0, kid);
8050                         o2->op_sibling = sib;
8051                         prev->op_sibling = o2;
8052                     }
8053                     if (contextclass && e) {
8054                          proto = e + 1;
8055                          contextclass = 0;
8056                     }
8057                     break;
8058                 default: goto oops;
8059                 }
8060                 if (contextclass)
8061                      goto again;
8062                 break;
8063             case ' ':
8064                 proto++;
8065                 continue;
8066             default:
8067               oops:
8068                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8069                            gv_ename(namegv), SVfARG(cv));
8070             }
8071         }
8072         else
8073             list(o2);
8074         mod(o2, OP_ENTERSUB);
8075         prev = o2;
8076         o2 = o2->op_sibling;
8077     } /* while */
8078     if (o2 == cvop && proto && *proto == '_') {
8079         /* generate an access to $_ */
8080         o2 = newDEFSVOP();
8081         o2->op_sibling = prev->op_sibling;
8082         prev->op_sibling = o2; /* instead of cvop */
8083     }
8084     if (proto && !optional && proto_end > proto &&
8085         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8086         return too_few_arguments(o, gv_ename(namegv));
8087     if(delete_op) {
8088 #ifdef PERL_MAD
8089         OP * const oldo = o;
8090 #else
8091         op_free(o);
8092 #endif
8093         o=newSVOP(OP_CONST, 0, newSViv(0));
8094         op_getmad(oldo,o,'O');
8095     }
8096     return o;
8097 }
8098
8099 OP *
8100 Perl_ck_svconst(pTHX_ OP *o)
8101 {
8102     PERL_ARGS_ASSERT_CK_SVCONST;
8103     PERL_UNUSED_CONTEXT;
8104     SvREADONLY_on(cSVOPo->op_sv);
8105     return o;
8106 }
8107
8108 OP *
8109 Perl_ck_chdir(pTHX_ OP *o)
8110 {
8111     if (o->op_flags & OPf_KIDS) {
8112         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8113
8114         if (kid && kid->op_type == OP_CONST &&
8115             (kid->op_private & OPpCONST_BARE))
8116         {
8117             o->op_flags |= OPf_SPECIAL;
8118             kid->op_private &= ~OPpCONST_STRICT;
8119         }
8120     }
8121     return ck_fun(o);
8122 }
8123
8124 OP *
8125 Perl_ck_trunc(pTHX_ OP *o)
8126 {
8127     PERL_ARGS_ASSERT_CK_TRUNC;
8128
8129     if (o->op_flags & OPf_KIDS) {
8130         SVOP *kid = (SVOP*)cUNOPo->op_first;
8131
8132         if (kid->op_type == OP_NULL)
8133             kid = (SVOP*)kid->op_sibling;
8134         if (kid && kid->op_type == OP_CONST &&
8135             (kid->op_private & OPpCONST_BARE))
8136         {
8137             o->op_flags |= OPf_SPECIAL;
8138             kid->op_private &= ~OPpCONST_STRICT;
8139         }
8140     }
8141     return ck_fun(o);
8142 }
8143
8144 OP *
8145 Perl_ck_unpack(pTHX_ OP *o)
8146 {
8147     OP *kid = cLISTOPo->op_first;
8148
8149     PERL_ARGS_ASSERT_CK_UNPACK;
8150
8151     if (kid->op_sibling) {
8152         kid = kid->op_sibling;
8153         if (!kid->op_sibling)
8154             kid->op_sibling = newDEFSVOP();
8155     }
8156     return ck_fun(o);
8157 }
8158
8159 OP *
8160 Perl_ck_substr(pTHX_ OP *o)
8161 {
8162     PERL_ARGS_ASSERT_CK_SUBSTR;
8163
8164     o = ck_fun(o);
8165     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8166         OP *kid = cLISTOPo->op_first;
8167
8168         if (kid->op_type == OP_NULL)
8169             kid = kid->op_sibling;
8170         if (kid)
8171             kid->op_flags |= OPf_MOD;
8172
8173     }
8174     return o;
8175 }
8176
8177 OP *
8178 Perl_ck_each(pTHX_ OP *o)
8179 {
8180     dVAR;
8181     OP *kid = cLISTOPo->op_first;
8182
8183     PERL_ARGS_ASSERT_CK_EACH;
8184
8185     if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8186         const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8187             : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8188         o->op_type = new_type;
8189         o->op_ppaddr = PL_ppaddr[new_type];
8190     }
8191     else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8192                || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8193                )) {
8194         bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8195         return o;
8196     }
8197     return ck_fun(o);
8198 }
8199
8200 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8201  * See the comments at the top of this file for more details about when
8202  * peep() is called */
8203
8204 void
8205 Perl_peep(pTHX_ register OP *o)
8206 {
8207     dVAR;
8208     register OP* oldop = NULL;
8209
8210     if (!o || o->op_opt)
8211         return;
8212     ENTER;
8213     SAVEOP();
8214     SAVEVPTR(PL_curcop);
8215     for (; o; o = o->op_next) {
8216         if (o->op_opt)
8217             break;
8218         /* By default, this op has now been optimised. A couple of cases below
8219            clear this again.  */
8220         o->op_opt = 1;
8221         PL_op = o;
8222         switch (o->op_type) {
8223         case OP_NEXTSTATE:
8224         case OP_DBSTATE:
8225             PL_curcop = ((COP*)o);              /* for warnings */
8226             break;
8227
8228         case OP_CONST:
8229             if (cSVOPo->op_private & OPpCONST_STRICT)
8230                 no_bareword_allowed(o);
8231 #ifdef USE_ITHREADS
8232         case OP_METHOD_NAMED:
8233             /* Relocate sv to the pad for thread safety.
8234              * Despite being a "constant", the SV is written to,
8235              * for reference counts, sv_upgrade() etc. */
8236             if (cSVOP->op_sv) {
8237                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8238                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
8239                     /* If op_sv is already a PADTMP then it is being used by
8240                      * some pad, so make a copy. */
8241                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8242                     SvREADONLY_on(PAD_SVl(ix));
8243                     SvREFCNT_dec(cSVOPo->op_sv);
8244                 }
8245                 else if (o->op_type == OP_CONST
8246                          && cSVOPo->op_sv == &PL_sv_undef) {
8247                     /* PL_sv_undef is hack - it's unsafe to store it in the
8248                        AV that is the pad, because av_fetch treats values of
8249                        PL_sv_undef as a "free" AV entry and will merrily
8250                        replace them with a new SV, causing pad_alloc to think
8251                        that this pad slot is free. (When, clearly, it is not)
8252                     */
8253                     SvOK_off(PAD_SVl(ix));
8254                     SvPADTMP_on(PAD_SVl(ix));
8255                     SvREADONLY_on(PAD_SVl(ix));
8256                 }
8257                 else {
8258                     SvREFCNT_dec(PAD_SVl(ix));
8259                     SvPADTMP_on(cSVOPo->op_sv);
8260                     PAD_SETSV(ix, cSVOPo->op_sv);
8261                     /* XXX I don't know how this isn't readonly already. */
8262                     SvREADONLY_on(PAD_SVl(ix));
8263                 }
8264                 cSVOPo->op_sv = NULL;
8265                 o->op_targ = ix;
8266             }
8267 #endif
8268             break;
8269
8270         case OP_CONCAT:
8271             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8272                 if (o->op_next->op_private & OPpTARGET_MY) {
8273                     if (o->op_flags & OPf_STACKED) /* chained concats */
8274                         break; /* ignore_optimization */
8275                     else {
8276                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8277                         o->op_targ = o->op_next->op_targ;
8278                         o->op_next->op_targ = 0;
8279                         o->op_private |= OPpTARGET_MY;
8280                     }
8281                 }
8282                 op_null(o->op_next);
8283             }
8284             break;
8285         case OP_STUB:
8286             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8287                 break; /* Scalar stub must produce undef.  List stub is noop */
8288             }
8289             goto nothin;
8290         case OP_NULL:
8291             if (o->op_targ == OP_NEXTSTATE
8292                 || o->op_targ == OP_DBSTATE)
8293             {
8294                 PL_curcop = ((COP*)o);
8295             }
8296             /* XXX: We avoid setting op_seq here to prevent later calls
8297                to peep() from mistakenly concluding that optimisation
8298                has already occurred. This doesn't fix the real problem,
8299                though (See 20010220.007). AMS 20010719 */
8300             /* op_seq functionality is now replaced by op_opt */
8301             o->op_opt = 0;
8302             /* FALL THROUGH */
8303         case OP_SCALAR:
8304         case OP_LINESEQ:
8305         case OP_SCOPE:
8306         nothin:
8307             if (oldop && o->op_next) {
8308                 oldop->op_next = o->op_next;
8309                 o->op_opt = 0;
8310                 continue;
8311             }
8312             break;
8313
8314         case OP_PADAV:
8315         case OP_GV:
8316             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8317                 OP* const pop = (o->op_type == OP_PADAV) ?
8318                             o->op_next : o->op_next->op_next;
8319                 IV i;
8320                 if (pop && pop->op_type == OP_CONST &&
8321                     ((PL_op = pop->op_next)) &&
8322                     pop->op_next->op_type == OP_AELEM &&
8323                     !(pop->op_next->op_private &
8324                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8325                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8326                                 <= 255 &&
8327                     i >= 0)
8328                 {
8329                     GV *gv;
8330                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8331                         no_bareword_allowed(pop);
8332                     if (o->op_type == OP_GV)
8333                         op_null(o->op_next);
8334                     op_null(pop->op_next);
8335                     op_null(pop);
8336                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8337                     o->op_next = pop->op_next->op_next;
8338                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8339                     o->op_private = (U8)i;
8340                     if (o->op_type == OP_GV) {
8341                         gv = cGVOPo_gv;
8342                         GvAVn(gv);
8343                     }
8344                     else
8345                         o->op_flags |= OPf_SPECIAL;
8346                     o->op_type = OP_AELEMFAST;
8347                 }
8348                 break;
8349             }
8350
8351             if (o->op_next->op_type == OP_RV2SV) {
8352                 if (!(o->op_next->op_private & OPpDEREF)) {
8353                     op_null(o->op_next);
8354                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8355                                                                | OPpOUR_INTRO);
8356                     o->op_next = o->op_next->op_next;
8357                     o->op_type = OP_GVSV;
8358                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8359                 }
8360             }
8361             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8362                 GV * const gv = cGVOPo_gv;
8363                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8364                     /* XXX could check prototype here instead of just carping */
8365                     SV * const sv = sv_newmortal();
8366                     gv_efullname3(sv, gv, NULL);
8367                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8368                                 "%"SVf"() called too early to check prototype",
8369                                 SVfARG(sv));
8370                 }
8371             }
8372             else if (o->op_next->op_type == OP_READLINE
8373                     && o->op_next->op_next->op_type == OP_CONCAT
8374                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8375             {
8376                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8377                 o->op_type   = OP_RCATLINE;
8378                 o->op_flags |= OPf_STACKED;
8379                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8380                 op_null(o->op_next->op_next);
8381                 op_null(o->op_next);
8382             }
8383
8384             break;
8385
8386         case OP_MAPWHILE:
8387         case OP_GREPWHILE:
8388         case OP_AND:
8389         case OP_OR:
8390         case OP_DOR:
8391         case OP_ANDASSIGN:
8392         case OP_ORASSIGN:
8393         case OP_DORASSIGN:
8394         case OP_COND_EXPR:
8395         case OP_RANGE:
8396         case OP_ONCE:
8397             while (cLOGOP->op_other->op_type == OP_NULL)
8398                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8399             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8400             break;
8401
8402         case OP_ENTERLOOP:
8403         case OP_ENTERITER:
8404             while (cLOOP->op_redoop->op_type == OP_NULL)
8405                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8406             peep(cLOOP->op_redoop);
8407             while (cLOOP->op_nextop->op_type == OP_NULL)
8408                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8409             peep(cLOOP->op_nextop);
8410             while (cLOOP->op_lastop->op_type == OP_NULL)
8411                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8412             peep(cLOOP->op_lastop);
8413             break;
8414
8415         case OP_SUBST:
8416             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8417             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8418                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8419                 cPMOP->op_pmstashstartu.op_pmreplstart
8420                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8421             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8422             break;
8423
8424         case OP_EXEC:
8425             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8426                 && ckWARN(WARN_SYNTAX))
8427             {
8428                 if (o->op_next->op_sibling) {
8429                     const OPCODE type = o->op_next->op_sibling->op_type;
8430                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8431                         const line_t oldline = CopLINE(PL_curcop);
8432                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8433                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8434                                     "Statement unlikely to be reached");
8435                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8436                                     "\t(Maybe you meant system() when you said exec()?)\n");
8437                         CopLINE_set(PL_curcop, oldline);
8438                     }
8439                 }
8440             }
8441             break;
8442
8443         case OP_HELEM: {
8444             UNOP *rop;
8445             SV *lexname;
8446             GV **fields;
8447             SV **svp, *sv;
8448             const char *key = NULL;
8449             STRLEN keylen;
8450
8451             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8452                 break;
8453
8454             /* Make the CONST have a shared SV */
8455             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8456             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8457                 key = SvPV_const(sv, keylen);
8458                 lexname = newSVpvn_share(key,
8459                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8460                                          0);
8461                 SvREFCNT_dec(sv);
8462                 *svp = lexname;
8463             }
8464
8465             if ((o->op_private & (OPpLVAL_INTRO)))
8466                 break;
8467
8468             rop = (UNOP*)((BINOP*)o)->op_first;
8469             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8470                 break;
8471             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8472             if (!SvPAD_TYPED(lexname))
8473                 break;
8474             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8475             if (!fields || !GvHV(*fields))
8476                 break;
8477             key = SvPV_const(*svp, keylen);
8478             if (!hv_fetch(GvHV(*fields), key,
8479                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8480             {
8481                 Perl_croak(aTHX_ "No such class field \"%s\" "
8482                            "in variable %s of type %s",
8483                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8484             }
8485
8486             break;
8487         }
8488
8489         case OP_HSLICE: {
8490             UNOP *rop;
8491             SV *lexname;
8492             GV **fields;
8493             SV **svp;
8494             const char *key;
8495             STRLEN keylen;
8496             SVOP *first_key_op, *key_op;
8497
8498             if ((o->op_private & (OPpLVAL_INTRO))
8499                 /* I bet there's always a pushmark... */
8500                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8501                 /* hmmm, no optimization if list contains only one key. */
8502                 break;
8503             rop = (UNOP*)((LISTOP*)o)->op_last;
8504             if (rop->op_type != OP_RV2HV)
8505                 break;
8506             if (rop->op_first->op_type == OP_PADSV)
8507                 /* @$hash{qw(keys here)} */
8508                 rop = (UNOP*)rop->op_first;
8509             else {
8510                 /* @{$hash}{qw(keys here)} */
8511                 if (rop->op_first->op_type == OP_SCOPE
8512                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8513                 {
8514                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8515                 }
8516                 else
8517                     break;
8518             }
8519
8520             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8521             if (!SvPAD_TYPED(lexname))
8522                 break;
8523             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8524             if (!fields || !GvHV(*fields))
8525                 break;
8526             /* Again guessing that the pushmark can be jumped over.... */
8527             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8528                 ->op_first->op_sibling;
8529             for (key_op = first_key_op; key_op;
8530                  key_op = (SVOP*)key_op->op_sibling) {
8531                 if (key_op->op_type != OP_CONST)
8532                     continue;
8533                 svp = cSVOPx_svp(key_op);
8534                 key = SvPV_const(*svp, keylen);
8535                 if (!hv_fetch(GvHV(*fields), key,
8536                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8537                 {
8538                     Perl_croak(aTHX_ "No such class field \"%s\" "
8539                                "in variable %s of type %s",
8540                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8541                 }
8542             }
8543             break;
8544         }
8545
8546         case OP_SORT: {
8547             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8548             OP *oleft;
8549             OP *o2;
8550
8551             /* check that RHS of sort is a single plain array */
8552             OP *oright = cUNOPo->op_first;
8553             if (!oright || oright->op_type != OP_PUSHMARK)
8554                 break;
8555
8556             /* reverse sort ... can be optimised.  */
8557             if (!cUNOPo->op_sibling) {
8558                 /* Nothing follows us on the list. */
8559                 OP * const reverse = o->op_next;
8560
8561                 if (reverse->op_type == OP_REVERSE &&
8562                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8563                     OP * const pushmark = cUNOPx(reverse)->op_first;
8564                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8565                         && (cUNOPx(pushmark)->op_sibling == o)) {
8566                         /* reverse -> pushmark -> sort */
8567                         o->op_private |= OPpSORT_REVERSE;
8568                         op_null(reverse);
8569                         pushmark->op_next = oright->op_next;
8570                         op_null(oright);
8571                     }
8572                 }
8573             }
8574
8575             /* make @a = sort @a act in-place */
8576
8577             oright = cUNOPx(oright)->op_sibling;
8578             if (!oright)
8579                 break;
8580             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8581                 oright = cUNOPx(oright)->op_sibling;
8582             }
8583
8584             if (!oright ||
8585                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8586                 || oright->op_next != o
8587                 || (oright->op_private & OPpLVAL_INTRO)
8588             )
8589                 break;
8590
8591             /* o2 follows the chain of op_nexts through the LHS of the
8592              * assign (if any) to the aassign op itself */
8593             o2 = o->op_next;
8594             if (!o2 || o2->op_type != OP_NULL)
8595                 break;
8596             o2 = o2->op_next;
8597             if (!o2 || o2->op_type != OP_PUSHMARK)
8598                 break;
8599             o2 = o2->op_next;
8600             if (o2 && o2->op_type == OP_GV)
8601                 o2 = o2->op_next;
8602             if (!o2
8603                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8604                 || (o2->op_private & OPpLVAL_INTRO)
8605             )
8606                 break;
8607             oleft = o2;
8608             o2 = o2->op_next;
8609             if (!o2 || o2->op_type != OP_NULL)
8610                 break;
8611             o2 = o2->op_next;
8612             if (!o2 || o2->op_type != OP_AASSIGN
8613                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8614                 break;
8615
8616             /* check that the sort is the first arg on RHS of assign */
8617
8618             o2 = cUNOPx(o2)->op_first;
8619             if (!o2 || o2->op_type != OP_NULL)
8620                 break;
8621             o2 = cUNOPx(o2)->op_first;
8622             if (!o2 || o2->op_type != OP_PUSHMARK)
8623                 break;
8624             if (o2->op_sibling != o)
8625                 break;
8626
8627             /* check the array is the same on both sides */
8628             if (oleft->op_type == OP_RV2AV) {
8629                 if (oright->op_type != OP_RV2AV
8630                     || !cUNOPx(oright)->op_first
8631                     || cUNOPx(oright)->op_first->op_type != OP_GV
8632                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8633                         cGVOPx_gv(cUNOPx(oright)->op_first)
8634                 )
8635                     break;
8636             }
8637             else if (oright->op_type != OP_PADAV
8638                 || oright->op_targ != oleft->op_targ
8639             )
8640                 break;
8641
8642             /* transfer MODishness etc from LHS arg to RHS arg */
8643             oright->op_flags = oleft->op_flags;
8644             o->op_private |= OPpSORT_INPLACE;
8645
8646             /* excise push->gv->rv2av->null->aassign */
8647             o2 = o->op_next->op_next;
8648             op_null(o2); /* PUSHMARK */
8649             o2 = o2->op_next;
8650             if (o2->op_type == OP_GV) {
8651                 op_null(o2); /* GV */
8652                 o2 = o2->op_next;
8653             }
8654             op_null(o2); /* RV2AV or PADAV */
8655             o2 = o2->op_next->op_next;
8656             op_null(o2); /* AASSIGN */
8657
8658             o->op_next = o2->op_next;
8659
8660             break;
8661         }
8662
8663         case OP_REVERSE: {
8664             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8665             OP *gvop = NULL;
8666             LISTOP *enter, *exlist;
8667
8668             enter = (LISTOP *) o->op_next;
8669             if (!enter)
8670                 break;
8671             if (enter->op_type == OP_NULL) {
8672                 enter = (LISTOP *) enter->op_next;
8673                 if (!enter)
8674                     break;
8675             }
8676             /* for $a (...) will have OP_GV then OP_RV2GV here.
8677                for (...) just has an OP_GV.  */
8678             if (enter->op_type == OP_GV) {
8679                 gvop = (OP *) enter;
8680                 enter = (LISTOP *) enter->op_next;
8681                 if (!enter)
8682                     break;
8683                 if (enter->op_type == OP_RV2GV) {
8684                   enter = (LISTOP *) enter->op_next;
8685                   if (!enter)
8686                     break;
8687                 }
8688             }
8689
8690             if (enter->op_type != OP_ENTERITER)
8691                 break;
8692
8693             iter = enter->op_next;
8694             if (!iter || iter->op_type != OP_ITER)
8695                 break;
8696
8697             expushmark = enter->op_first;
8698             if (!expushmark || expushmark->op_type != OP_NULL
8699                 || expushmark->op_targ != OP_PUSHMARK)
8700                 break;
8701
8702             exlist = (LISTOP *) expushmark->op_sibling;
8703             if (!exlist || exlist->op_type != OP_NULL
8704                 || exlist->op_targ != OP_LIST)
8705                 break;
8706
8707             if (exlist->op_last != o) {
8708                 /* Mmm. Was expecting to point back to this op.  */
8709                 break;
8710             }
8711             theirmark = exlist->op_first;
8712             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8713                 break;
8714
8715             if (theirmark->op_sibling != o) {
8716                 /* There's something between the mark and the reverse, eg
8717                    for (1, reverse (...))
8718                    so no go.  */
8719                 break;
8720             }
8721
8722             ourmark = ((LISTOP *)o)->op_first;
8723             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8724                 break;
8725
8726             ourlast = ((LISTOP *)o)->op_last;
8727             if (!ourlast || ourlast->op_next != o)
8728                 break;
8729
8730             rv2av = ourmark->op_sibling;
8731             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8732                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8733                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8734                 /* We're just reversing a single array.  */
8735                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8736                 enter->op_flags |= OPf_STACKED;
8737             }
8738
8739             /* We don't have control over who points to theirmark, so sacrifice
8740                ours.  */
8741             theirmark->op_next = ourmark->op_next;
8742             theirmark->op_flags = ourmark->op_flags;
8743             ourlast->op_next = gvop ? gvop : (OP *) enter;
8744             op_null(ourmark);
8745             op_null(o);
8746             enter->op_private |= OPpITER_REVERSED;
8747             iter->op_private |= OPpITER_REVERSED;
8748
8749             break;
8750         }
8751
8752         case OP_SASSIGN: {
8753             OP *rv2gv;
8754             UNOP *refgen, *rv2cv;
8755             LISTOP *exlist;
8756
8757             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8758                 break;
8759
8760             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8761                 break;
8762
8763             rv2gv = ((BINOP *)o)->op_last;
8764             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8765                 break;
8766
8767             refgen = (UNOP *)((BINOP *)o)->op_first;
8768
8769             if (!refgen || refgen->op_type != OP_REFGEN)
8770                 break;
8771
8772             exlist = (LISTOP *)refgen->op_first;
8773             if (!exlist || exlist->op_type != OP_NULL
8774                 || exlist->op_targ != OP_LIST)
8775                 break;
8776
8777             if (exlist->op_first->op_type != OP_PUSHMARK)
8778                 break;
8779
8780             rv2cv = (UNOP*)exlist->op_last;
8781
8782             if (rv2cv->op_type != OP_RV2CV)
8783                 break;
8784
8785             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8786             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8787             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8788
8789             o->op_private |= OPpASSIGN_CV_TO_GV;
8790             rv2gv->op_private |= OPpDONT_INIT_GV;
8791             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8792
8793             break;
8794         }
8795
8796
8797         case OP_QR:
8798         case OP_MATCH:
8799             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8800                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8801             }
8802             break;
8803         }
8804         oldop = o;
8805     }
8806     LEAVE;
8807 }
8808
8809 const char*
8810 Perl_custom_op_name(pTHX_ const OP* o)
8811 {
8812     dVAR;
8813     const IV index = PTR2IV(o->op_ppaddr);
8814     SV* keysv;
8815     HE* he;
8816
8817     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8818
8819     if (!PL_custom_op_names) /* This probably shouldn't happen */
8820         return (char *)PL_op_name[OP_CUSTOM];
8821
8822     keysv = sv_2mortal(newSViv(index));
8823
8824     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8825     if (!he)
8826         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8827
8828     return SvPV_nolen(HeVAL(he));
8829 }
8830
8831 const char*
8832 Perl_custom_op_desc(pTHX_ const OP* o)
8833 {
8834     dVAR;
8835     const IV index = PTR2IV(o->op_ppaddr);
8836     SV* keysv;
8837     HE* he;
8838
8839     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8840
8841     if (!PL_custom_op_descs)
8842         return (char *)PL_op_desc[OP_CUSTOM];
8843
8844     keysv = sv_2mortal(newSViv(index));
8845
8846     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8847     if (!he)
8848         return (char *)PL_op_desc[OP_CUSTOM];
8849
8850     return SvPV_nolen(HeVAL(he));
8851 }
8852
8853 #include "XSUB.h"
8854
8855 /* Efficient sub that returns a constant scalar value. */
8856 static void
8857 const_sv_xsub(pTHX_ CV* cv)
8858 {
8859     dVAR;
8860     dXSARGS;
8861     if (items != 0) {
8862         NOOP;
8863 #if 0
8864         Perl_croak(aTHX_ "usage: %s::%s()",
8865                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8866 #endif
8867     }
8868     EXTEND(sp, 1);
8869     ST(0) = (SV*)XSANY.any_ptr;
8870     XSRETURN(1);
8871 }
8872
8873 /*
8874  * Local variables:
8875  * c-indentation-style: bsd
8876  * c-basic-offset: 4
8877  * indent-tabs-mode: t
8878  * End:
8879  *
8880  * ex: set ts=8 sts=4 sw=4 noet:
8881  */