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