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