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         /* Proof of concept for now - for efficiency reasons these are likely
4384            to end up being replaced by a custom function in hv.c  */
4385         SV *const key = newSVpvs(":");
4386         SV *const value = newSVpv(label, 0);
4387         cop->cop_hints_hash
4388             = Perl_refcounted_he_new(aTHX_ cop->cop_hints_hash, key, value);
4389
4390         PL_hints |= HINT_BLOCK_SCOPE;
4391         /* It seems that we need to defer freeing this pointer, as other parts
4392            of the grammar end up wanting to copy it after this op has been
4393            created. */
4394         SAVEFREEPV(label);
4395         SvREFCNT_dec(key);
4396         SvREFCNT_dec(value);
4397     }
4398
4399     if (PL_parser && PL_parser->copline == NOLINE)
4400         CopLINE_set(cop, CopLINE(PL_curcop));
4401     else {
4402         CopLINE_set(cop, PL_parser->copline);
4403         if (PL_parser)
4404             PL_parser->copline = NOLINE;
4405     }
4406 #ifdef USE_ITHREADS
4407     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4408 #else
4409     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4410 #endif
4411     CopSTASH_set(cop, PL_curstash);
4412
4413     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4414         AV *av = CopFILEAVx(PL_curcop);
4415         if (av) {
4416             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4417             if (svp && *svp != &PL_sv_undef ) {
4418                 (void)SvIOK_on(*svp);
4419                 SvIV_set(*svp, PTR2IV(cop));
4420             }
4421         }
4422     }
4423
4424     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4425 }
4426
4427
4428 OP *
4429 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4430 {
4431     dVAR;
4432
4433     PERL_ARGS_ASSERT_NEWLOGOP;
4434
4435     return new_logop(type, flags, &first, &other);
4436 }
4437
4438 STATIC OP *
4439 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4440 {
4441     dVAR;
4442     LOGOP *logop;
4443     OP *o;
4444     OP *first = *firstp;
4445     OP * const other = *otherp;
4446
4447     PERL_ARGS_ASSERT_NEW_LOGOP;
4448
4449     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4450         return newBINOP(type, flags, scalar(first), scalar(other));
4451
4452     scalarboolean(first);
4453     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4454     if (first->op_type == OP_NOT
4455         && (first->op_flags & OPf_SPECIAL)
4456         && (first->op_flags & OPf_KIDS)
4457         && !PL_madskills) {
4458         if (type == OP_AND || type == OP_OR) {
4459             if (type == OP_AND)
4460                 type = OP_OR;
4461             else
4462                 type = OP_AND;
4463             o = first;
4464             first = *firstp = cUNOPo->op_first;
4465             if (o->op_next)
4466                 first->op_next = o->op_next;
4467             cUNOPo->op_first = NULL;
4468             op_free(o);
4469         }
4470     }
4471     if (first->op_type == OP_CONST) {
4472         if (first->op_private & OPpCONST_STRICT)
4473             no_bareword_allowed(first);
4474         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4475                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4476         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4477             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4478             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4479             *firstp = NULL;
4480             if (other->op_type == OP_CONST)
4481                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4482             if (PL_madskills) {
4483                 OP *newop = newUNOP(OP_NULL, 0, other);
4484                 op_getmad(first, newop, '1');
4485                 newop->op_targ = type;  /* set "was" field */
4486                 return newop;
4487             }
4488             op_free(first);
4489             return other;
4490         }
4491         else {
4492             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4493             const OP *o2 = other;
4494             if ( ! (o2->op_type == OP_LIST
4495                     && (( o2 = cUNOPx(o2)->op_first))
4496                     && o2->op_type == OP_PUSHMARK
4497                     && (( o2 = o2->op_sibling)) )
4498             )
4499                 o2 = other;
4500             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4501                         || o2->op_type == OP_PADHV)
4502                 && o2->op_private & OPpLVAL_INTRO
4503                 && !(o2->op_private & OPpPAD_STATE)
4504                 && ckWARN(WARN_DEPRECATED))
4505             {
4506                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4507                             "Deprecated use of my() in false conditional");
4508             }
4509
4510             *otherp = NULL;
4511             if (first->op_type == OP_CONST)
4512                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4513             if (PL_madskills) {
4514                 first = newUNOP(OP_NULL, 0, first);
4515                 op_getmad(other, first, '2');
4516                 first->op_targ = type;  /* set "was" field */
4517             }
4518             else
4519                 op_free(other);
4520             return first;
4521         }
4522     }
4523     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4524         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4525     {
4526         const OP * const k1 = ((UNOP*)first)->op_first;
4527         const OP * const k2 = k1->op_sibling;
4528         OPCODE warnop = 0;
4529         switch (first->op_type)
4530         {
4531         case OP_NULL:
4532             if (k2 && k2->op_type == OP_READLINE
4533                   && (k2->op_flags & OPf_STACKED)
4534                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4535             {
4536                 warnop = k2->op_type;
4537             }
4538             break;
4539
4540         case OP_SASSIGN:
4541             if (k1->op_type == OP_READDIR
4542                   || k1->op_type == OP_GLOB
4543                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4544                   || k1->op_type == OP_EACH)
4545             {
4546                 warnop = ((k1->op_type == OP_NULL)
4547                           ? (OPCODE)k1->op_targ : k1->op_type);
4548             }
4549             break;
4550         }
4551         if (warnop) {
4552             const line_t oldline = CopLINE(PL_curcop);
4553             CopLINE_set(PL_curcop, PL_parser->copline);
4554             Perl_warner(aTHX_ packWARN(WARN_MISC),
4555                  "Value of %s%s can be \"0\"; test with defined()",
4556                  PL_op_desc[warnop],
4557                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4558                   ? " construct" : "() operator"));
4559             CopLINE_set(PL_curcop, oldline);
4560         }
4561     }
4562
4563     if (!other)
4564         return first;
4565
4566     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4567         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4568
4569     NewOp(1101, logop, 1, LOGOP);
4570
4571     logop->op_type = (OPCODE)type;
4572     logop->op_ppaddr = PL_ppaddr[type];
4573     logop->op_first = first;
4574     logop->op_flags = (U8)(flags | OPf_KIDS);
4575     logop->op_other = LINKLIST(other);
4576     logop->op_private = (U8)(1 | (flags >> 8));
4577
4578     /* establish postfix order */
4579     logop->op_next = LINKLIST(first);
4580     first->op_next = (OP*)logop;
4581     first->op_sibling = other;
4582
4583     CHECKOP(type,logop);
4584
4585     o = newUNOP(OP_NULL, 0, (OP*)logop);
4586     other->op_next = o;
4587
4588     return o;
4589 }
4590
4591 OP *
4592 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4593 {
4594     dVAR;
4595     LOGOP *logop;
4596     OP *start;
4597     OP *o;
4598
4599     PERL_ARGS_ASSERT_NEWCONDOP;
4600
4601     if (!falseop)
4602         return newLOGOP(OP_AND, 0, first, trueop);
4603     if (!trueop)
4604         return newLOGOP(OP_OR, 0, first, falseop);
4605
4606     scalarboolean(first);
4607     if (first->op_type == OP_CONST) {
4608         /* Left or right arm of the conditional?  */
4609         const bool left = SvTRUE(((SVOP*)first)->op_sv);
4610         OP *live = left ? trueop : falseop;
4611         OP *const dead = left ? falseop : trueop;
4612         if (first->op_private & OPpCONST_BARE &&
4613             first->op_private & OPpCONST_STRICT) {
4614             no_bareword_allowed(first);
4615         }
4616         if (PL_madskills) {
4617             /* This is all dead code when PERL_MAD is not defined.  */
4618             live = newUNOP(OP_NULL, 0, live);
4619             op_getmad(first, live, 'C');
4620             op_getmad(dead, live, left ? 'e' : 't');
4621         } else {
4622             op_free(first);
4623             op_free(dead);
4624         }
4625         return live;
4626     }
4627     NewOp(1101, logop, 1, LOGOP);
4628     logop->op_type = OP_COND_EXPR;
4629     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4630     logop->op_first = first;
4631     logop->op_flags = (U8)(flags | OPf_KIDS);
4632     logop->op_private = (U8)(1 | (flags >> 8));
4633     logop->op_other = LINKLIST(trueop);
4634     logop->op_next = LINKLIST(falseop);
4635
4636     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4637             logop);
4638
4639     /* establish postfix order */
4640     start = LINKLIST(first);
4641     first->op_next = (OP*)logop;
4642
4643     first->op_sibling = trueop;
4644     trueop->op_sibling = falseop;
4645     o = newUNOP(OP_NULL, 0, (OP*)logop);
4646
4647     trueop->op_next = falseop->op_next = o;
4648
4649     o->op_next = start;
4650     return o;
4651 }
4652
4653 OP *
4654 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4655 {
4656     dVAR;
4657     LOGOP *range;
4658     OP *flip;
4659     OP *flop;
4660     OP *leftstart;
4661     OP *o;
4662
4663     PERL_ARGS_ASSERT_NEWRANGE;
4664
4665     NewOp(1101, range, 1, LOGOP);
4666
4667     range->op_type = OP_RANGE;
4668     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4669     range->op_first = left;
4670     range->op_flags = OPf_KIDS;
4671     leftstart = LINKLIST(left);
4672     range->op_other = LINKLIST(right);
4673     range->op_private = (U8)(1 | (flags >> 8));
4674
4675     left->op_sibling = right;
4676
4677     range->op_next = (OP*)range;
4678     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4679     flop = newUNOP(OP_FLOP, 0, flip);
4680     o = newUNOP(OP_NULL, 0, flop);
4681     linklist(flop);
4682     range->op_next = leftstart;
4683
4684     left->op_next = flip;
4685     right->op_next = flop;
4686
4687     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4688     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4689     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4690     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4691
4692     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4693     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4694
4695     flip->op_next = o;
4696     if (!flip->op_private || !flop->op_private)
4697         linklist(o);            /* blow off optimizer unless constant */
4698
4699     return o;
4700 }
4701
4702 OP *
4703 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4704 {
4705     dVAR;
4706     OP* listop;
4707     OP* o;
4708     const bool once = block && block->op_flags & OPf_SPECIAL &&
4709       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4710
4711     PERL_UNUSED_ARG(debuggable);
4712
4713     if (expr) {
4714         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4715             return block;       /* do {} while 0 does once */
4716         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4717             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4718             expr = newUNOP(OP_DEFINED, 0,
4719                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4720         } else if (expr->op_flags & OPf_KIDS) {
4721             const OP * const k1 = ((UNOP*)expr)->op_first;
4722             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4723             switch (expr->op_type) {
4724               case OP_NULL:
4725                 if (k2 && k2->op_type == OP_READLINE
4726                       && (k2->op_flags & OPf_STACKED)
4727                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4728                     expr = newUNOP(OP_DEFINED, 0, expr);
4729                 break;
4730
4731               case OP_SASSIGN:
4732                 if (k1 && (k1->op_type == OP_READDIR
4733                       || k1->op_type == OP_GLOB
4734                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4735                       || k1->op_type == OP_EACH))
4736                     expr = newUNOP(OP_DEFINED, 0, expr);
4737                 break;
4738             }
4739         }
4740     }
4741
4742     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4743      * op, in listop. This is wrong. [perl #27024] */
4744     if (!block)
4745         block = newOP(OP_NULL, 0);
4746     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4747     o = new_logop(OP_AND, 0, &expr, &listop);
4748
4749     if (listop)
4750         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4751
4752     if (once && o != listop)
4753         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4754
4755     if (o == listop)
4756         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4757
4758     o->op_flags |= flags;
4759     o = scope(o);
4760     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4761     return o;
4762 }
4763
4764 OP *
4765 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4766 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4767 {
4768     dVAR;
4769     OP *redo;
4770     OP *next = NULL;
4771     OP *listop;
4772     OP *o;
4773     U8 loopflags = 0;
4774
4775     PERL_UNUSED_ARG(debuggable);
4776
4777     if (expr) {
4778         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4779                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4780             expr = newUNOP(OP_DEFINED, 0,
4781                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4782         } else if (expr->op_flags & OPf_KIDS) {
4783             const OP * const k1 = ((UNOP*)expr)->op_first;
4784             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4785             switch (expr->op_type) {
4786               case OP_NULL:
4787                 if (k2 && k2->op_type == OP_READLINE
4788                       && (k2->op_flags & OPf_STACKED)
4789                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4790                     expr = newUNOP(OP_DEFINED, 0, expr);
4791                 break;
4792
4793               case OP_SASSIGN:
4794                 if (k1 && (k1->op_type == OP_READDIR
4795                       || k1->op_type == OP_GLOB
4796                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4797                       || k1->op_type == OP_EACH))
4798                     expr = newUNOP(OP_DEFINED, 0, expr);
4799                 break;
4800             }
4801         }
4802     }
4803
4804     if (!block)
4805         block = newOP(OP_NULL, 0);
4806     else if (cont || has_my) {
4807         block = scope(block);
4808     }
4809
4810     if (cont) {
4811         next = LINKLIST(cont);
4812     }
4813     if (expr) {
4814         OP * const unstack = newOP(OP_UNSTACK, 0);
4815         if (!next)
4816             next = unstack;
4817         cont = append_elem(OP_LINESEQ, cont, unstack);
4818     }
4819
4820     assert(block);
4821     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4822     assert(listop);
4823     redo = LINKLIST(listop);
4824
4825     if (expr) {
4826         PL_parser->copline = (line_t)whileline;
4827         scalar(listop);
4828         o = new_logop(OP_AND, 0, &expr, &listop);
4829         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4830             op_free(expr);              /* oops, it's a while (0) */
4831             op_free((OP*)loop);
4832             return NULL;                /* listop already freed by new_logop */
4833         }
4834         if (listop)
4835             ((LISTOP*)listop)->op_last->op_next =
4836                 (o == listop ? redo : LINKLIST(o));
4837     }
4838     else
4839         o = listop;
4840
4841     if (!loop) {
4842         NewOp(1101,loop,1,LOOP);
4843         loop->op_type = OP_ENTERLOOP;
4844         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4845         loop->op_private = 0;
4846         loop->op_next = (OP*)loop;
4847     }
4848
4849     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4850
4851     loop->op_redoop = redo;
4852     loop->op_lastop = o;
4853     o->op_private |= loopflags;
4854
4855     if (next)
4856         loop->op_nextop = next;
4857     else
4858         loop->op_nextop = o;
4859
4860     o->op_flags |= flags;
4861     o->op_private |= (flags >> 8);
4862     return o;
4863 }
4864
4865 OP *
4866 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4867 {
4868     dVAR;
4869     LOOP *loop;
4870     OP *wop;
4871     PADOFFSET padoff = 0;
4872     I32 iterflags = 0;
4873     I32 iterpflags = 0;
4874     OP *madsv = NULL;
4875
4876     PERL_ARGS_ASSERT_NEWFOROP;
4877
4878     if (sv) {
4879         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4880             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4881             sv->op_type = OP_RV2GV;
4882             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4883
4884             /* The op_type check is needed to prevent a possible segfault
4885              * if the loop variable is undeclared and 'strict vars' is in
4886              * effect. This is illegal but is nonetheless parsed, so we
4887              * may reach this point with an OP_CONST where we're expecting
4888              * an OP_GV.
4889              */
4890             if (cUNOPx(sv)->op_first->op_type == OP_GV
4891              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4892                 iterpflags |= OPpITER_DEF;
4893         }
4894         else if (sv->op_type == OP_PADSV) { /* private variable */
4895             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4896             padoff = sv->op_targ;
4897             if (PL_madskills)
4898                 madsv = sv;
4899             else {
4900                 sv->op_targ = 0;
4901                 op_free(sv);
4902             }
4903             sv = NULL;
4904         }
4905         else
4906             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4907         if (padoff) {
4908             SV *const namesv = PAD_COMPNAME_SV(padoff);
4909             STRLEN len;
4910             const char *const name = SvPV_const(namesv, len);
4911
4912             if (len == 2 && name[0] == '$' && name[1] == '_')
4913                 iterpflags |= OPpITER_DEF;
4914         }
4915     }
4916     else {
4917         const PADOFFSET offset = pad_findmy("$_");
4918         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4919             sv = newGVOP(OP_GV, 0, PL_defgv);
4920         }
4921         else {
4922             padoff = offset;
4923         }
4924         iterpflags |= OPpITER_DEF;
4925     }
4926     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4927         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4928         iterflags |= OPf_STACKED;
4929     }
4930     else if (expr->op_type == OP_NULL &&
4931              (expr->op_flags & OPf_KIDS) &&
4932              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4933     {
4934         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4935          * set the STACKED flag to indicate that these values are to be
4936          * treated as min/max values by 'pp_iterinit'.
4937          */
4938         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4939         LOGOP* const range = (LOGOP*) flip->op_first;
4940         OP* const left  = range->op_first;
4941         OP* const right = left->op_sibling;
4942         LISTOP* listop;
4943
4944         range->op_flags &= ~OPf_KIDS;
4945         range->op_first = NULL;
4946
4947         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4948         listop->op_first->op_next = range->op_next;
4949         left->op_next = range->op_other;
4950         right->op_next = (OP*)listop;
4951         listop->op_next = listop->op_first;
4952
4953 #ifdef PERL_MAD
4954         op_getmad(expr,(OP*)listop,'O');
4955 #else
4956         op_free(expr);
4957 #endif
4958         expr = (OP*)(listop);
4959         op_null(expr);
4960         iterflags |= OPf_STACKED;
4961     }
4962     else {
4963         expr = mod(force_list(expr), OP_GREPSTART);
4964     }
4965
4966     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4967                                append_elem(OP_LIST, expr, scalar(sv))));
4968     assert(!loop->op_next);
4969     /* for my  $x () sets OPpLVAL_INTRO;
4970      * for our $x () sets OPpOUR_INTRO */
4971     loop->op_private = (U8)iterpflags;
4972 #ifdef PL_OP_SLAB_ALLOC
4973     {
4974         LOOP *tmp;
4975         NewOp(1234,tmp,1,LOOP);
4976         Copy(loop,tmp,1,LISTOP);
4977         S_op_destroy(aTHX_ (OP*)loop);
4978         loop = tmp;
4979     }
4980 #else
4981     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4982 #endif
4983     loop->op_targ = padoff;
4984     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4985     if (madsv)
4986         op_getmad(madsv, (OP*)loop, 'v');
4987     PL_parser->copline = forline;
4988     return newSTATEOP(0, label, wop);
4989 }
4990
4991 OP*
4992 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4993 {
4994     dVAR;
4995     OP *o;
4996
4997     PERL_ARGS_ASSERT_NEWLOOPEX;
4998
4999     if (type != OP_GOTO || label->op_type == OP_CONST) {
5000         /* "last()" means "last" */
5001         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5002             o = newOP(type, OPf_SPECIAL);
5003         else {
5004             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5005                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5006                                         : ""));
5007         }
5008 #ifdef PERL_MAD
5009         op_getmad(label,o,'L');
5010 #else
5011         op_free(label);
5012 #endif
5013     }
5014     else {
5015         /* Check whether it's going to be a goto &function */
5016         if (label->op_type == OP_ENTERSUB
5017                 && !(label->op_flags & OPf_STACKED))
5018             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5019         o = newUNOP(type, OPf_STACKED, label);
5020     }
5021     PL_hints |= HINT_BLOCK_SCOPE;
5022     return o;
5023 }
5024
5025 /* if the condition is a literal array or hash
5026    (or @{ ... } etc), make a reference to it.
5027  */
5028 STATIC OP *
5029 S_ref_array_or_hash(pTHX_ OP *cond)
5030 {
5031     if (cond
5032     && (cond->op_type == OP_RV2AV
5033     ||  cond->op_type == OP_PADAV
5034     ||  cond->op_type == OP_RV2HV
5035     ||  cond->op_type == OP_PADHV))
5036
5037         return newUNOP(OP_REFGEN,
5038             0, mod(cond, OP_REFGEN));
5039
5040     else
5041         return cond;
5042 }
5043
5044 /* These construct the optree fragments representing given()
5045    and when() blocks.
5046
5047    entergiven and enterwhen are LOGOPs; the op_other pointer
5048    points up to the associated leave op. We need this so we
5049    can put it in the context and make break/continue work.
5050    (Also, of course, pp_enterwhen will jump straight to
5051    op_other if the match fails.)
5052  */
5053
5054 STATIC OP *
5055 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5056                    I32 enter_opcode, I32 leave_opcode,
5057                    PADOFFSET entertarg)
5058 {
5059     dVAR;
5060     LOGOP *enterop;
5061     OP *o;
5062
5063     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5064
5065     NewOp(1101, enterop, 1, LOGOP);
5066     enterop->op_type = (optype)enter_opcode;
5067     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5068     enterop->op_flags =  (U8) OPf_KIDS;
5069     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5070     enterop->op_private = 0;
5071
5072     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5073
5074     if (cond) {
5075         enterop->op_first = scalar(cond);
5076         cond->op_sibling = block;
5077
5078         o->op_next = LINKLIST(cond);
5079         cond->op_next = (OP *) enterop;
5080     }
5081     else {
5082         /* This is a default {} block */
5083         enterop->op_first = block;
5084         enterop->op_flags |= OPf_SPECIAL;
5085
5086         o->op_next = (OP *) enterop;
5087     }
5088
5089     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5090                                        entergiven and enterwhen both
5091                                        use ck_null() */
5092
5093     enterop->op_next = LINKLIST(block);
5094     block->op_next = enterop->op_other = o;
5095
5096     return o;
5097 }
5098
5099 /* Does this look like a boolean operation? For these purposes
5100    a boolean operation is:
5101      - a subroutine call [*]
5102      - a logical connective
5103      - a comparison operator
5104      - a filetest operator, with the exception of -s -M -A -C
5105      - defined(), exists() or eof()
5106      - /$re/ or $foo =~ /$re/
5107
5108    [*] possibly surprising
5109  */
5110 STATIC bool
5111 S_looks_like_bool(pTHX_ const OP *o)
5112 {
5113     dVAR;
5114
5115     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5116
5117     switch(o->op_type) {
5118         case OP_OR:
5119             return looks_like_bool(cLOGOPo->op_first);
5120
5121         case OP_AND:
5122             return (
5123                 looks_like_bool(cLOGOPo->op_first)
5124              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5125
5126         case OP_NULL:
5127             return (
5128                 o->op_flags & OPf_KIDS
5129             && looks_like_bool(cUNOPo->op_first));
5130
5131         case OP_ENTERSUB:
5132
5133         case OP_NOT:    case OP_XOR:
5134         /* Note that OP_DOR is not here */
5135
5136         case OP_EQ:     case OP_NE:     case OP_LT:
5137         case OP_GT:     case OP_LE:     case OP_GE:
5138
5139         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5140         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5141
5142         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5143         case OP_SGT:    case OP_SLE:    case OP_SGE:
5144
5145         case OP_SMARTMATCH:
5146
5147         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5148         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5149         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5150         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5151         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5152         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5153         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5154         case OP_FTTEXT:   case OP_FTBINARY:
5155
5156         case OP_DEFINED: case OP_EXISTS:
5157         case OP_MATCH:   case OP_EOF:
5158
5159             return TRUE;
5160
5161         case OP_CONST:
5162             /* Detect comparisons that have been optimized away */
5163             if (cSVOPo->op_sv == &PL_sv_yes
5164             ||  cSVOPo->op_sv == &PL_sv_no)
5165
5166                 return TRUE;
5167
5168         /* FALL THROUGH */
5169         default:
5170             return FALSE;
5171     }
5172 }
5173
5174 OP *
5175 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5176 {
5177     dVAR;
5178     PERL_ARGS_ASSERT_NEWGIVENOP;
5179     return newGIVWHENOP(
5180         ref_array_or_hash(cond),
5181         block,
5182         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5183         defsv_off);
5184 }
5185
5186 /* If cond is null, this is a default {} block */
5187 OP *
5188 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5189 {
5190     const bool cond_llb = (!cond || looks_like_bool(cond));
5191     OP *cond_op;
5192
5193     PERL_ARGS_ASSERT_NEWWHENOP;
5194
5195     if (cond_llb)
5196         cond_op = cond;
5197     else {
5198         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5199                 newDEFSVOP(),
5200                 scalar(ref_array_or_hash(cond)));
5201     }
5202
5203     return newGIVWHENOP(
5204         cond_op,
5205         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5206         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5207 }
5208
5209 /*
5210 =for apidoc cv_undef
5211
5212 Clear out all the active components of a CV. This can happen either
5213 by an explicit C<undef &foo>, or by the reference count going to zero.
5214 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5215 children can still follow the full lexical scope chain.
5216
5217 =cut
5218 */
5219
5220 void
5221 Perl_cv_undef(pTHX_ CV *cv)
5222 {
5223     dVAR;
5224
5225     PERL_ARGS_ASSERT_CV_UNDEF;
5226
5227     DEBUG_X(PerlIO_printf(Perl_debug_log,
5228           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5229             PTR2UV(cv), PTR2UV(PL_comppad))
5230     );
5231
5232 #ifdef USE_ITHREADS
5233     if (CvFILE(cv) && !CvISXSUB(cv)) {
5234         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5235         Safefree(CvFILE(cv));
5236     }
5237     CvFILE(cv) = NULL;
5238 #endif
5239
5240     if (!CvISXSUB(cv) && CvROOT(cv)) {
5241         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5242             Perl_croak(aTHX_ "Can't undef active subroutine");
5243         ENTER;
5244
5245         PAD_SAVE_SETNULLPAD();
5246
5247         op_free(CvROOT(cv));
5248         CvROOT(cv) = NULL;
5249         CvSTART(cv) = NULL;
5250         LEAVE;
5251     }
5252     SvPOK_off((SV*)cv);         /* forget prototype */
5253     CvGV(cv) = NULL;
5254
5255     pad_undef(cv);
5256
5257     /* remove CvOUTSIDE unless this is an undef rather than a free */
5258     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5259         if (!CvWEAKOUTSIDE(cv))
5260             SvREFCNT_dec(CvOUTSIDE(cv));
5261         CvOUTSIDE(cv) = NULL;
5262     }
5263     if (CvCONST(cv)) {
5264         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5265         CvCONST_off(cv);
5266     }
5267     if (CvISXSUB(cv) && CvXSUB(cv)) {
5268         CvXSUB(cv) = NULL;
5269     }
5270     /* delete all flags except WEAKOUTSIDE */
5271     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5272 }
5273
5274 void
5275 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5276                     const STRLEN len)
5277 {
5278     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5279
5280     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5281        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5282     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5283          || (p && (len != SvCUR(cv) /* Not the same length.  */
5284                    || memNE(p, SvPVX_const(cv), len))))
5285          && ckWARN_d(WARN_PROTOTYPE)) {
5286         SV* const msg = sv_newmortal();
5287         SV* name = NULL;
5288
5289         if (gv)
5290             gv_efullname3(name = sv_newmortal(), gv, NULL);
5291         sv_setpvs(msg, "Prototype mismatch:");
5292         if (name)
5293             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5294         if (SvPOK(cv))
5295             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5296         else
5297             sv_catpvs(msg, ": none");
5298         sv_catpvs(msg, " vs ");
5299         if (p)
5300             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5301         else
5302             sv_catpvs(msg, "none");
5303         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5304     }
5305 }
5306
5307 static void const_sv_xsub(pTHX_ CV* cv);
5308
5309 /*
5310
5311 =head1 Optree Manipulation Functions
5312
5313 =for apidoc cv_const_sv
5314
5315 If C<cv> is a constant sub eligible for inlining. returns the constant
5316 value returned by the sub.  Otherwise, returns NULL.
5317
5318 Constant subs can be created with C<newCONSTSUB> or as described in
5319 L<perlsub/"Constant Functions">.
5320
5321 =cut
5322 */
5323 SV *
5324 Perl_cv_const_sv(pTHX_ CV *cv)
5325 {
5326     PERL_UNUSED_CONTEXT;
5327     if (!cv)
5328         return NULL;
5329     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5330         return NULL;
5331     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5332 }
5333
5334 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5335  * Can be called in 3 ways:
5336  *
5337  * !cv
5338  *      look for a single OP_CONST with attached value: return the value
5339  *
5340  * cv && CvCLONE(cv) && !CvCONST(cv)
5341  *
5342  *      examine the clone prototype, and if contains only a single
5343  *      OP_CONST referencing a pad const, or a single PADSV referencing
5344  *      an outer lexical, return a non-zero value to indicate the CV is
5345  *      a candidate for "constizing" at clone time
5346  *
5347  * cv && CvCONST(cv)
5348  *
5349  *      We have just cloned an anon prototype that was marked as a const
5350  *      candidiate. Try to grab the current value, and in the case of
5351  *      PADSV, ignore it if it has multiple references. Return the value.
5352  */
5353
5354 SV *
5355 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5356 {
5357     dVAR;
5358     SV *sv = NULL;
5359
5360     if (PL_madskills)
5361         return NULL;
5362
5363     if (!o)
5364         return NULL;
5365
5366     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5367         o = cLISTOPo->op_first->op_sibling;
5368
5369     for (; o; o = o->op_next) {
5370         const OPCODE type = o->op_type;
5371
5372         if (sv && o->op_next == o)
5373             return sv;
5374         if (o->op_next != o) {
5375             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5376                 continue;
5377             if (type == OP_DBSTATE)
5378                 continue;
5379         }
5380         if (type == OP_LEAVESUB || type == OP_RETURN)
5381             break;
5382         if (sv)
5383             return NULL;
5384         if (type == OP_CONST && cSVOPo->op_sv)
5385             sv = cSVOPo->op_sv;
5386         else if (cv && type == OP_CONST) {
5387             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5388             if (!sv)
5389                 return NULL;
5390         }
5391         else if (cv && type == OP_PADSV) {
5392             if (CvCONST(cv)) { /* newly cloned anon */
5393                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5394                 /* the candidate should have 1 ref from this pad and 1 ref
5395                  * from the parent */
5396                 if (!sv || SvREFCNT(sv) != 2)
5397                     return NULL;
5398                 sv = newSVsv(sv);
5399                 SvREADONLY_on(sv);
5400                 return sv;
5401             }
5402             else {
5403                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5404                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5405             }
5406         }
5407         else {
5408             return NULL;
5409         }
5410     }
5411     return sv;
5412 }
5413
5414 #ifdef PERL_MAD
5415 OP *
5416 #else
5417 void
5418 #endif
5419 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5420 {
5421 #if 0
5422     /* This would be the return value, but the return cannot be reached.  */
5423     OP* pegop = newOP(OP_NULL, 0);
5424 #endif
5425
5426     PERL_UNUSED_ARG(floor);
5427
5428     if (o)
5429         SAVEFREEOP(o);
5430     if (proto)
5431         SAVEFREEOP(proto);
5432     if (attrs)
5433         SAVEFREEOP(attrs);
5434     if (block)
5435         SAVEFREEOP(block);
5436     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5437 #ifdef PERL_MAD
5438     NORETURN_FUNCTION_END;
5439 #endif
5440 }
5441
5442 CV *
5443 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5444 {
5445     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5446 }
5447
5448 CV *
5449 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5450 {
5451     dVAR;
5452     const char *aname;
5453     GV *gv;
5454     const char *ps;
5455     STRLEN ps_len;
5456     register CV *cv = NULL;
5457     SV *const_sv;
5458     /* If the subroutine has no body, no attributes, and no builtin attributes
5459        then it's just a sub declaration, and we may be able to get away with
5460        storing with a placeholder scalar in the symbol table, rather than a
5461        full GV and CV.  If anything is present then it will take a full CV to
5462        store it.  */
5463     const I32 gv_fetch_flags
5464         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5465            || PL_madskills)
5466         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5467     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5468
5469     if (proto) {
5470         assert(proto->op_type == OP_CONST);
5471         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5472     }
5473     else
5474         ps = NULL;
5475
5476     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5477         SV * const sv = sv_newmortal();
5478         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5479                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5480                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5481         aname = SvPVX_const(sv);
5482     }
5483     else
5484         aname = NULL;
5485
5486     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5487         : gv_fetchpv(aname ? aname
5488                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5489                      gv_fetch_flags, SVt_PVCV);
5490
5491     if (!PL_madskills) {
5492         if (o)
5493             SAVEFREEOP(o);
5494         if (proto)
5495             SAVEFREEOP(proto);
5496         if (attrs)
5497             SAVEFREEOP(attrs);
5498     }
5499
5500     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5501                                            maximum a prototype before. */
5502         if (SvTYPE(gv) > SVt_NULL) {
5503             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5504                 && ckWARN_d(WARN_PROTOTYPE))
5505             {
5506                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5507             }
5508             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5509         }
5510         if (ps)
5511             sv_setpvn((SV*)gv, ps, ps_len);
5512         else
5513             sv_setiv((SV*)gv, -1);
5514
5515         SvREFCNT_dec(PL_compcv);
5516         cv = PL_compcv = NULL;
5517         goto done;
5518     }
5519
5520     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5521
5522 #ifdef GV_UNIQUE_CHECK
5523     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5524         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5525     }
5526 #endif
5527
5528     if (!block || !ps || *ps || attrs
5529         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5530 #ifdef PERL_MAD
5531         || block->op_type == OP_NULL
5532 #endif
5533         )
5534         const_sv = NULL;
5535     else
5536         const_sv = op_const_sv(block, NULL);
5537
5538     if (cv) {
5539         const bool exists = CvROOT(cv) || CvXSUB(cv);
5540
5541 #ifdef GV_UNIQUE_CHECK
5542         if (exists && GvUNIQUE(gv)) {
5543             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5544         }
5545 #endif
5546
5547         /* if the subroutine doesn't exist and wasn't pre-declared
5548          * with a prototype, assume it will be AUTOLOADed,
5549          * skipping the prototype check
5550          */
5551         if (exists || SvPOK(cv))
5552             cv_ckproto_len(cv, gv, ps, ps_len);
5553         /* already defined (or promised)? */
5554         if (exists || GvASSUMECV(gv)) {
5555             if ((!block
5556 #ifdef PERL_MAD
5557                  || block->op_type == OP_NULL
5558 #endif
5559                  )&& !attrs) {
5560                 if (CvFLAGS(PL_compcv)) {
5561                     /* might have had built-in attrs applied */
5562                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5563                 }
5564                 /* just a "sub foo;" when &foo is already defined */
5565                 SAVEFREESV(PL_compcv);
5566                 goto done;
5567             }
5568             if (block
5569 #ifdef PERL_MAD
5570                 && block->op_type != OP_NULL
5571 #endif
5572                 ) {
5573                 if (ckWARN(WARN_REDEFINE)
5574                     || (CvCONST(cv)
5575                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5576                 {
5577                     const line_t oldline = CopLINE(PL_curcop);
5578                     if (PL_parser && PL_parser->copline != NOLINE)
5579                         CopLINE_set(PL_curcop, PL_parser->copline);
5580                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5581                         CvCONST(cv) ? "Constant subroutine %s redefined"
5582                                     : "Subroutine %s redefined", name);
5583                     CopLINE_set(PL_curcop, oldline);
5584                 }
5585 #ifdef PERL_MAD
5586                 if (!PL_minus_c)        /* keep old one around for madskills */
5587 #endif
5588                     {
5589                         /* (PL_madskills unset in used file.) */
5590                         SvREFCNT_dec(cv);
5591                     }
5592                 cv = NULL;
5593             }
5594         }
5595     }
5596     if (const_sv) {
5597         SvREFCNT_inc_simple_void_NN(const_sv);
5598         if (cv) {
5599             assert(!CvROOT(cv) && !CvCONST(cv));
5600             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5601             CvXSUBANY(cv).any_ptr = const_sv;
5602             CvXSUB(cv) = const_sv_xsub;
5603             CvCONST_on(cv);
5604             CvISXSUB_on(cv);
5605         }
5606         else {
5607             GvCV(gv) = NULL;
5608             cv = newCONSTSUB(NULL, name, const_sv);
5609         }
5610         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5611             (CvGV(cv) && GvSTASH(CvGV(cv)))
5612                 ? GvSTASH(CvGV(cv))
5613                 : CvSTASH(cv)
5614                     ? CvSTASH(cv)
5615                     : PL_curstash
5616         );
5617         if (PL_madskills)
5618             goto install_block;
5619         op_free(block);
5620         SvREFCNT_dec(PL_compcv);
5621         PL_compcv = NULL;
5622         goto done;
5623     }
5624     if (attrs) {
5625         HV *stash;
5626         SV *rcv;
5627
5628         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5629          * before we clobber PL_compcv.
5630          */
5631         if (cv && (!block
5632 #ifdef PERL_MAD
5633                     || block->op_type == OP_NULL
5634 #endif
5635                     )) {
5636             rcv = (SV*)cv;
5637             /* Might have had built-in attributes applied -- propagate them. */
5638             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5639             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5640                 stash = GvSTASH(CvGV(cv));
5641             else if (CvSTASH(cv))
5642                 stash = CvSTASH(cv);
5643             else
5644                 stash = PL_curstash;
5645         }
5646         else {
5647             /* possibly about to re-define existing subr -- ignore old cv */
5648             rcv = (SV*)PL_compcv;
5649             if (name && GvSTASH(gv))
5650                 stash = GvSTASH(gv);
5651             else
5652                 stash = PL_curstash;
5653         }
5654         apply_attrs(stash, rcv, attrs, FALSE);
5655     }
5656     if (cv) {                           /* must reuse cv if autoloaded */
5657         if (
5658 #ifdef PERL_MAD
5659             (
5660 #endif
5661              !block
5662 #ifdef PERL_MAD
5663              || block->op_type == OP_NULL) && !PL_madskills
5664 #endif
5665              ) {
5666             /* got here with just attrs -- work done, so bug out */
5667             SAVEFREESV(PL_compcv);
5668             goto done;
5669         }
5670         /* transfer PL_compcv to cv */
5671         cv_undef(cv);
5672         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5673         if (!CvWEAKOUTSIDE(cv))
5674             SvREFCNT_dec(CvOUTSIDE(cv));
5675         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5676         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5677         CvOUTSIDE(PL_compcv) = 0;
5678         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5679         CvPADLIST(PL_compcv) = 0;
5680         /* inner references to PL_compcv must be fixed up ... */
5681         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5682         /* ... before we throw it away */
5683         SvREFCNT_dec(PL_compcv);
5684         PL_compcv = cv;
5685         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5686           ++PL_sub_generation;
5687     }
5688     else {
5689         cv = PL_compcv;
5690         if (name) {
5691             GvCV(gv) = cv;
5692             if (PL_madskills) {
5693                 if (strEQ(name, "import")) {
5694                     PL_formfeed = (SV*)cv;
5695                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5696                 }
5697             }
5698             GvCVGEN(gv) = 0;
5699             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5700         }
5701     }
5702     CvGV(cv) = gv;
5703     CvFILE_set_from_cop(cv, PL_curcop);
5704     CvSTASH(cv) = PL_curstash;
5705
5706     if (ps)
5707         sv_setpvn((SV*)cv, ps, ps_len);
5708
5709     if (PL_parser && PL_parser->error_count) {
5710         op_free(block);
5711         block = NULL;
5712         if (name) {
5713             const char *s = strrchr(name, ':');
5714             s = s ? s+1 : name;
5715             if (strEQ(s, "BEGIN")) {
5716                 const char not_safe[] =
5717                     "BEGIN not safe after errors--compilation aborted";
5718                 if (PL_in_eval & EVAL_KEEPERR)
5719                     Perl_croak(aTHX_ not_safe);
5720                 else {
5721                     /* force display of errors found but not reported */
5722                     sv_catpv(ERRSV, not_safe);
5723                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5724                 }
5725             }
5726         }
5727     }
5728  install_block:
5729     if (!block)
5730         goto done;
5731
5732     if (CvLVALUE(cv)) {
5733         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5734                              mod(scalarseq(block), OP_LEAVESUBLV));
5735         block->op_attached = 1;
5736     }
5737     else {
5738         /* This makes sub {}; work as expected.  */
5739         if (block->op_type == OP_STUB) {
5740             OP* const newblock = newSTATEOP(0, NULL, 0);
5741 #ifdef PERL_MAD
5742             op_getmad(block,newblock,'B');
5743 #else
5744             op_free(block);
5745 #endif
5746             block = newblock;
5747         }
5748         else
5749             block->op_attached = 1;
5750         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5751     }
5752     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5753     OpREFCNT_set(CvROOT(cv), 1);
5754     CvSTART(cv) = LINKLIST(CvROOT(cv));
5755     CvROOT(cv)->op_next = 0;
5756     CALL_PEEP(CvSTART(cv));
5757
5758     /* now that optimizer has done its work, adjust pad values */
5759
5760     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5761
5762     if (CvCLONE(cv)) {
5763         assert(!CvCONST(cv));
5764         if (ps && !*ps && op_const_sv(block, cv))
5765             CvCONST_on(cv);
5766     }
5767
5768     if (name || aname) {
5769         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5770             SV * const sv = newSV(0);
5771             SV * const tmpstr = sv_newmortal();
5772             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5773                                                   GV_ADDMULTI, SVt_PVHV);
5774             HV *hv;
5775
5776             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5777                            CopFILE(PL_curcop),
5778                            (long)PL_subline, (long)CopLINE(PL_curcop));
5779             gv_efullname3(tmpstr, gv, NULL);
5780             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5781                     SvCUR(tmpstr), sv, 0);
5782             hv = GvHVn(db_postponed);
5783             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5784                 CV * const pcv = GvCV(db_postponed);
5785                 if (pcv) {
5786                     dSP;
5787                     PUSHMARK(SP);
5788                     XPUSHs(tmpstr);
5789                     PUTBACK;
5790                     call_sv((SV*)pcv, G_DISCARD);
5791                 }
5792             }
5793         }
5794
5795         if (name && ! (PL_parser && PL_parser->error_count))
5796             process_special_blocks(name, gv, cv);
5797     }
5798
5799   done:
5800     if (PL_parser)
5801         PL_parser->copline = NOLINE;
5802     LEAVE_SCOPE(floor);
5803     return cv;
5804 }
5805
5806 STATIC void
5807 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5808                          CV *const cv)
5809 {
5810     const char *const colon = strrchr(fullname,':');
5811     const char *const name = colon ? colon + 1 : fullname;
5812
5813     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5814
5815     if (*name == 'B') {
5816         if (strEQ(name, "BEGIN")) {
5817             const I32 oldscope = PL_scopestack_ix;
5818             ENTER;
5819             SAVECOPFILE(&PL_compiling);
5820             SAVECOPLINE(&PL_compiling);
5821
5822             DEBUG_x( dump_sub(gv) );
5823             Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5824             GvCV(gv) = 0;               /* cv has been hijacked */
5825             call_list(oldscope, PL_beginav);
5826
5827             PL_curcop = &PL_compiling;
5828             CopHINTS_set(&PL_compiling, PL_hints);
5829             LEAVE;
5830         }
5831         else
5832             return;
5833     } else {
5834         if (*name == 'E') {
5835             if strEQ(name, "END") {
5836                 DEBUG_x( dump_sub(gv) );
5837                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5838             } else
5839                 return;
5840         } else if (*name == 'U') {
5841             if (strEQ(name, "UNITCHECK")) {
5842                 /* It's never too late to run a unitcheck block */
5843                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5844             }
5845             else
5846                 return;
5847         } else if (*name == 'C') {
5848             if (strEQ(name, "CHECK")) {
5849                 if (PL_main_start && ckWARN(WARN_VOID))
5850                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5851                                 "Too late to run CHECK block");
5852                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5853             }
5854             else
5855                 return;
5856         } else if (*name == 'I') {
5857             if (strEQ(name, "INIT")) {
5858                 if (PL_main_start && ckWARN(WARN_VOID))
5859                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5860                                 "Too late to run INIT block");
5861                 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5862             }
5863             else
5864                 return;
5865         } else
5866             return;
5867         DEBUG_x( dump_sub(gv) );
5868         GvCV(gv) = 0;           /* cv has been hijacked */
5869     }
5870 }
5871
5872 /*
5873 =for apidoc newCONSTSUB
5874
5875 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5876 eligible for inlining at compile-time.
5877
5878 =cut
5879 */
5880
5881 CV *
5882 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5883 {
5884     dVAR;
5885     CV* cv;
5886 #ifdef USE_ITHREADS
5887     const char *const temp_p = CopFILE(PL_curcop);
5888     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5889 #else
5890     SV *const temp_sv = CopFILESV(PL_curcop);
5891     STRLEN len;
5892     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5893 #endif
5894     char *const file = savepvn(temp_p, temp_p ? len : 0);
5895
5896     ENTER;
5897
5898     if (IN_PERL_RUNTIME) {
5899         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5900          * an op shared between threads. Use a non-shared COP for our
5901          * dirty work */
5902          SAVEVPTR(PL_curcop);
5903          PL_curcop = &PL_compiling;
5904     }
5905     SAVECOPLINE(PL_curcop);
5906     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5907
5908     SAVEHINTS();
5909     PL_hints &= ~HINT_BLOCK_SCOPE;
5910
5911     if (stash) {
5912         SAVESPTR(PL_curstash);
5913         SAVECOPSTASH(PL_curcop);
5914         PL_curstash = stash;
5915         CopSTASH_set(PL_curcop,stash);
5916     }
5917
5918     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5919        and so doesn't get free()d.  (It's expected to be from the C pre-
5920        processor __FILE__ directive). But we need a dynamically allocated one,
5921        and we need it to get freed.  */
5922     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5923     CvXSUBANY(cv).any_ptr = sv;
5924     CvCONST_on(cv);
5925     Safefree(file);
5926
5927 #ifdef USE_ITHREADS
5928     if (stash)
5929         CopSTASH_free(PL_curcop);
5930 #endif
5931     LEAVE;
5932
5933     return cv;
5934 }
5935
5936 CV *
5937 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5938                  const char *const filename, const char *const proto,
5939                  U32 flags)
5940 {
5941     CV *cv = newXS(name, subaddr, filename);
5942
5943     PERL_ARGS_ASSERT_NEWXS_FLAGS;
5944
5945     if (flags & XS_DYNAMIC_FILENAME) {
5946         /* We need to "make arrangements" (ie cheat) to ensure that the
5947            filename lasts as long as the PVCV we just created, but also doesn't
5948            leak  */
5949         STRLEN filename_len = strlen(filename);
5950         STRLEN proto_and_file_len = filename_len;
5951         char *proto_and_file;
5952         STRLEN proto_len;
5953
5954         if (proto) {
5955             proto_len = strlen(proto);
5956             proto_and_file_len += proto_len;
5957
5958             Newx(proto_and_file, proto_and_file_len + 1, char);
5959             Copy(proto, proto_and_file, proto_len, char);
5960             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5961         } else {
5962             proto_len = 0;
5963             proto_and_file = savepvn(filename, filename_len);
5964         }
5965
5966         /* This gets free()d.  :-)  */
5967         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5968                         SV_HAS_TRAILING_NUL);
5969         if (proto) {
5970             /* This gives us the correct prototype, rather than one with the
5971                file name appended.  */
5972             SvCUR_set(cv, proto_len);
5973         } else {
5974             SvPOK_off(cv);
5975         }
5976         CvFILE(cv) = proto_and_file + proto_len;
5977     } else {
5978         sv_setpv((SV *)cv, proto);
5979     }
5980     return cv;
5981 }
5982
5983 /*
5984 =for apidoc U||newXS
5985
5986 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5987 static storage, as it is used directly as CvFILE(), without a copy being made.
5988
5989 =cut
5990 */
5991
5992 CV *
5993 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5994 {
5995     dVAR;
5996     GV * const gv = gv_fetchpv(name ? name :
5997                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5998                         GV_ADDMULTI, SVt_PVCV);
5999     register CV *cv;
6000
6001     PERL_ARGS_ASSERT_NEWXS;
6002
6003     if (!subaddr)
6004         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6005
6006     if ((cv = (name ? GvCV(gv) : NULL))) {
6007         if (GvCVGEN(gv)) {
6008             /* just a cached method */
6009             SvREFCNT_dec(cv);
6010             cv = NULL;
6011         }
6012         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6013             /* already defined (or promised) */
6014             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6015             if (ckWARN(WARN_REDEFINE)) {
6016                 GV * const gvcv = CvGV(cv);
6017                 if (gvcv) {
6018                     HV * const stash = GvSTASH(gvcv);
6019                     if (stash) {
6020                         const char *redefined_name = HvNAME_get(stash);
6021                         if ( strEQ(redefined_name,"autouse") ) {
6022                             const line_t oldline = CopLINE(PL_curcop);
6023                             if (PL_parser && PL_parser->copline != NOLINE)
6024                                 CopLINE_set(PL_curcop, PL_parser->copline);
6025                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6026                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6027                                                     : "Subroutine %s redefined"
6028                                         ,name);
6029                             CopLINE_set(PL_curcop, oldline);
6030                         }
6031                     }
6032                 }
6033             }
6034             SvREFCNT_dec(cv);
6035             cv = NULL;
6036         }
6037     }
6038
6039     if (cv)                             /* must reuse cv if autoloaded */
6040         cv_undef(cv);
6041     else {
6042         cv = (CV*)newSV_type(SVt_PVCV);
6043         if (name) {
6044             GvCV(gv) = cv;
6045             GvCVGEN(gv) = 0;
6046             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6047         }
6048     }
6049     CvGV(cv) = gv;
6050     (void)gv_fetchfile(filename);
6051     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6052                                    an external constant string */
6053     CvISXSUB_on(cv);
6054     CvXSUB(cv) = subaddr;
6055
6056     if (name)
6057         process_special_blocks(name, gv, cv);
6058     else
6059         CvANON_on(cv);
6060
6061     return cv;
6062 }
6063
6064 #ifdef PERL_MAD
6065 OP *
6066 #else
6067 void
6068 #endif
6069 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6070 {
6071     dVAR;
6072     register CV *cv;
6073 #ifdef PERL_MAD
6074     OP* pegop = newOP(OP_NULL, 0);
6075 #endif
6076
6077     GV * const gv = o
6078         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6079         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6080
6081 #ifdef GV_UNIQUE_CHECK
6082     if (GvUNIQUE(gv)) {
6083         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6084     }
6085 #endif
6086     GvMULTI_on(gv);
6087     if ((cv = GvFORM(gv))) {
6088         if (ckWARN(WARN_REDEFINE)) {
6089             const line_t oldline = CopLINE(PL_curcop);
6090             if (PL_parser && PL_parser->copline != NOLINE)
6091                 CopLINE_set(PL_curcop, PL_parser->copline);
6092             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6093                         o ? "Format %"SVf" redefined"
6094                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6095             CopLINE_set(PL_curcop, oldline);
6096         }
6097         SvREFCNT_dec(cv);
6098     }
6099     cv = PL_compcv;
6100     GvFORM(gv) = cv;
6101     CvGV(cv) = gv;
6102     CvFILE_set_from_cop(cv, PL_curcop);
6103
6104
6105     pad_tidy(padtidy_FORMAT);
6106     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6107     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6108     OpREFCNT_set(CvROOT(cv), 1);
6109     CvSTART(cv) = LINKLIST(CvROOT(cv));
6110     CvROOT(cv)->op_next = 0;
6111     CALL_PEEP(CvSTART(cv));
6112 #ifdef PERL_MAD
6113     op_getmad(o,pegop,'n');
6114     op_getmad_weak(block, pegop, 'b');
6115 #else
6116     op_free(o);
6117 #endif
6118     if (PL_parser)
6119         PL_parser->copline = NOLINE;
6120     LEAVE_SCOPE(floor);
6121 #ifdef PERL_MAD
6122     return pegop;
6123 #endif
6124 }
6125
6126 OP *
6127 Perl_newANONLIST(pTHX_ OP *o)
6128 {
6129     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6130 }
6131
6132 OP *
6133 Perl_newANONHASH(pTHX_ OP *o)
6134 {
6135     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6136 }
6137
6138 OP *
6139 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6140 {
6141     return newANONATTRSUB(floor, proto, NULL, block);
6142 }
6143
6144 OP *
6145 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6146 {
6147     return newUNOP(OP_REFGEN, 0,
6148         newSVOP(OP_ANONCODE, 0,
6149                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6150 }
6151
6152 OP *
6153 Perl_oopsAV(pTHX_ OP *o)
6154 {
6155     dVAR;
6156
6157     PERL_ARGS_ASSERT_OOPSAV;
6158
6159     switch (o->op_type) {
6160     case OP_PADSV:
6161         o->op_type = OP_PADAV;
6162         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6163         return ref(o, OP_RV2AV);
6164
6165     case OP_RV2SV:
6166         o->op_type = OP_RV2AV;
6167         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6168         ref(o, OP_RV2AV);
6169         break;
6170
6171     default:
6172         if (ckWARN_d(WARN_INTERNAL))
6173             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6174         break;
6175     }
6176     return o;
6177 }
6178
6179 OP *
6180 Perl_oopsHV(pTHX_ OP *o)
6181 {
6182     dVAR;
6183
6184     PERL_ARGS_ASSERT_OOPSHV;
6185
6186     switch (o->op_type) {
6187     case OP_PADSV:
6188     case OP_PADAV:
6189         o->op_type = OP_PADHV;
6190         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6191         return ref(o, OP_RV2HV);
6192
6193     case OP_RV2SV:
6194     case OP_RV2AV:
6195         o->op_type = OP_RV2HV;
6196         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6197         ref(o, OP_RV2HV);
6198         break;
6199
6200     default:
6201         if (ckWARN_d(WARN_INTERNAL))
6202             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6203         break;
6204     }
6205     return o;
6206 }
6207
6208 OP *
6209 Perl_newAVREF(pTHX_ OP *o)
6210 {
6211     dVAR;
6212
6213     PERL_ARGS_ASSERT_NEWAVREF;
6214
6215     if (o->op_type == OP_PADANY) {
6216         o->op_type = OP_PADAV;
6217         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6218         return o;
6219     }
6220     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6221                 && ckWARN(WARN_DEPRECATED)) {
6222         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6223                 "Using an array as a reference is deprecated");
6224     }
6225     return newUNOP(OP_RV2AV, 0, scalar(o));
6226 }
6227
6228 OP *
6229 Perl_newGVREF(pTHX_ I32 type, OP *o)
6230 {
6231     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6232         return newUNOP(OP_NULL, 0, o);
6233     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6234 }
6235
6236 OP *
6237 Perl_newHVREF(pTHX_ OP *o)
6238 {
6239     dVAR;
6240
6241     PERL_ARGS_ASSERT_NEWHVREF;
6242
6243     if (o->op_type == OP_PADANY) {
6244         o->op_type = OP_PADHV;
6245         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6246         return o;
6247     }
6248     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6249                 && ckWARN(WARN_DEPRECATED)) {
6250         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6251                 "Using a hash as a reference is deprecated");
6252     }
6253     return newUNOP(OP_RV2HV, 0, scalar(o));
6254 }
6255
6256 OP *
6257 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6258 {
6259     return newUNOP(OP_RV2CV, flags, scalar(o));
6260 }
6261
6262 OP *
6263 Perl_newSVREF(pTHX_ OP *o)
6264 {
6265     dVAR;
6266
6267     PERL_ARGS_ASSERT_NEWSVREF;
6268
6269     if (o->op_type == OP_PADANY) {
6270         o->op_type = OP_PADSV;
6271         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6272         return o;
6273     }
6274     return newUNOP(OP_RV2SV, 0, scalar(o));
6275 }
6276
6277 /* Check routines. See the comments at the top of this file for details
6278  * on when these are called */
6279
6280 OP *
6281 Perl_ck_anoncode(pTHX_ OP *o)
6282 {
6283     PERL_ARGS_ASSERT_CK_ANONCODE;
6284
6285     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6286     if (!PL_madskills)
6287         cSVOPo->op_sv = NULL;
6288     return o;
6289 }
6290
6291 OP *
6292 Perl_ck_bitop(pTHX_ OP *o)
6293 {
6294     dVAR;
6295
6296     PERL_ARGS_ASSERT_CK_BITOP;
6297
6298 #define OP_IS_NUMCOMPARE(op) \
6299         ((op) == OP_LT   || (op) == OP_I_LT || \
6300          (op) == OP_GT   || (op) == OP_I_GT || \
6301          (op) == OP_LE   || (op) == OP_I_LE || \
6302          (op) == OP_GE   || (op) == OP_I_GE || \
6303          (op) == OP_EQ   || (op) == OP_I_EQ || \
6304          (op) == OP_NE   || (op) == OP_I_NE || \
6305          (op) == OP_NCMP || (op) == OP_I_NCMP)
6306     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6307     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6308             && (o->op_type == OP_BIT_OR
6309              || o->op_type == OP_BIT_AND
6310              || o->op_type == OP_BIT_XOR))
6311     {
6312         const OP * const left = cBINOPo->op_first;
6313         const OP * const right = left->op_sibling;
6314         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6315                 (left->op_flags & OPf_PARENS) == 0) ||
6316             (OP_IS_NUMCOMPARE(right->op_type) &&
6317                 (right->op_flags & OPf_PARENS) == 0))
6318             if (ckWARN(WARN_PRECEDENCE))
6319                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6320                         "Possible precedence problem on bitwise %c operator",
6321                         o->op_type == OP_BIT_OR ? '|'
6322                             : o->op_type == OP_BIT_AND ? '&' : '^'
6323                         );
6324     }
6325     return o;
6326 }
6327
6328 OP *
6329 Perl_ck_concat(pTHX_ OP *o)
6330 {
6331     const OP * const kid = cUNOPo->op_first;
6332
6333     PERL_ARGS_ASSERT_CK_CONCAT;
6334     PERL_UNUSED_CONTEXT;
6335
6336     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6337             !(kUNOP->op_first->op_flags & OPf_MOD))
6338         o->op_flags |= OPf_STACKED;
6339     return o;
6340 }
6341
6342 OP *
6343 Perl_ck_spair(pTHX_ OP *o)
6344 {
6345     dVAR;
6346
6347     PERL_ARGS_ASSERT_CK_SPAIR;
6348
6349     if (o->op_flags & OPf_KIDS) {
6350         OP* newop;
6351         OP* kid;
6352         const OPCODE type = o->op_type;
6353         o = modkids(ck_fun(o), type);
6354         kid = cUNOPo->op_first;
6355         newop = kUNOP->op_first->op_sibling;
6356         if (newop) {
6357             const OPCODE type = newop->op_type;
6358             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6359                     type == OP_PADAV || type == OP_PADHV ||
6360                     type == OP_RV2AV || type == OP_RV2HV)
6361                 return o;
6362         }
6363 #ifdef PERL_MAD
6364         op_getmad(kUNOP->op_first,newop,'K');
6365 #else
6366         op_free(kUNOP->op_first);
6367 #endif
6368         kUNOP->op_first = newop;
6369     }
6370     o->op_ppaddr = PL_ppaddr[++o->op_type];
6371     return ck_fun(o);
6372 }
6373
6374 OP *
6375 Perl_ck_delete(pTHX_ OP *o)
6376 {
6377     PERL_ARGS_ASSERT_CK_DELETE;
6378
6379     o = ck_fun(o);
6380     o->op_private = 0;
6381     if (o->op_flags & OPf_KIDS) {
6382         OP * const kid = cUNOPo->op_first;
6383         switch (kid->op_type) {
6384         case OP_ASLICE:
6385             o->op_flags |= OPf_SPECIAL;
6386             /* FALL THROUGH */
6387         case OP_HSLICE:
6388             o->op_private |= OPpSLICE;
6389             break;
6390         case OP_AELEM:
6391             o->op_flags |= OPf_SPECIAL;
6392             /* FALL THROUGH */
6393         case OP_HELEM:
6394             break;
6395         default:
6396             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6397                   OP_DESC(o));
6398         }
6399         op_null(kid);
6400     }
6401     return o;
6402 }
6403
6404 OP *
6405 Perl_ck_die(pTHX_ OP *o)
6406 {
6407     PERL_ARGS_ASSERT_CK_DIE;
6408
6409 #ifdef VMS
6410     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6411 #endif
6412     return ck_fun(o);
6413 }
6414
6415 OP *
6416 Perl_ck_eof(pTHX_ OP *o)
6417 {
6418     dVAR;
6419
6420     PERL_ARGS_ASSERT_CK_EOF;
6421
6422     if (o->op_flags & OPf_KIDS) {
6423         if (cLISTOPo->op_first->op_type == OP_STUB) {
6424             OP * const newop
6425                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6426 #ifdef PERL_MAD
6427             op_getmad(o,newop,'O');
6428 #else
6429             op_free(o);
6430 #endif
6431             o = newop;
6432         }
6433         return ck_fun(o);
6434     }
6435     return o;
6436 }
6437
6438 OP *
6439 Perl_ck_eval(pTHX_ OP *o)
6440 {
6441     dVAR;
6442
6443     PERL_ARGS_ASSERT_CK_EVAL;
6444
6445     PL_hints |= HINT_BLOCK_SCOPE;
6446     if (o->op_flags & OPf_KIDS) {
6447         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6448
6449         if (!kid) {
6450             o->op_flags &= ~OPf_KIDS;
6451             op_null(o);
6452         }
6453         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6454             LOGOP *enter;
6455 #ifdef PERL_MAD
6456             OP* const oldo = o;
6457 #endif
6458
6459             cUNOPo->op_first = 0;
6460 #ifndef PERL_MAD
6461             op_free(o);
6462 #endif
6463
6464             NewOp(1101, enter, 1, LOGOP);
6465             enter->op_type = OP_ENTERTRY;
6466             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6467             enter->op_private = 0;
6468
6469             /* establish postfix order */
6470             enter->op_next = (OP*)enter;
6471
6472             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6473             o->op_type = OP_LEAVETRY;
6474             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6475             enter->op_other = o;
6476             op_getmad(oldo,o,'O');
6477             return o;
6478         }
6479         else {
6480             scalar((OP*)kid);
6481             PL_cv_has_eval = 1;
6482         }
6483     }
6484     else {
6485 #ifdef PERL_MAD
6486         OP* const oldo = o;
6487 #else
6488         op_free(o);
6489 #endif
6490         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6491         op_getmad(oldo,o,'O');
6492     }
6493     o->op_targ = (PADOFFSET)PL_hints;
6494     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6495         /* Store a copy of %^H that pp_entereval can pick up. */
6496         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6497                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6498         cUNOPo->op_first->op_sibling = hhop;
6499         o->op_private |= OPpEVAL_HAS_HH;
6500     }
6501     return o;
6502 }
6503
6504 OP *
6505 Perl_ck_exit(pTHX_ OP *o)
6506 {
6507     PERL_ARGS_ASSERT_CK_EXIT;
6508
6509 #ifdef VMS
6510     HV * const table = GvHV(PL_hintgv);
6511     if (table) {
6512        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6513        if (svp && *svp && SvTRUE(*svp))
6514            o->op_private |= OPpEXIT_VMSISH;
6515     }
6516     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6517 #endif
6518     return ck_fun(o);
6519 }
6520
6521 OP *
6522 Perl_ck_exec(pTHX_ OP *o)
6523 {
6524     PERL_ARGS_ASSERT_CK_EXEC;
6525
6526     if (o->op_flags & OPf_STACKED) {
6527         OP *kid;
6528         o = ck_fun(o);
6529         kid = cUNOPo->op_first->op_sibling;
6530         if (kid->op_type == OP_RV2GV)
6531             op_null(kid);
6532     }
6533     else
6534         o = listkids(o);
6535     return o;
6536 }
6537
6538 OP *
6539 Perl_ck_exists(pTHX_ OP *o)
6540 {
6541     dVAR;
6542
6543     PERL_ARGS_ASSERT_CK_EXISTS;
6544
6545     o = ck_fun(o);
6546     if (o->op_flags & OPf_KIDS) {
6547         OP * const kid = cUNOPo->op_first;
6548         if (kid->op_type == OP_ENTERSUB) {
6549             (void) ref(kid, o->op_type);
6550             if (kid->op_type != OP_RV2CV
6551                         && !(PL_parser && PL_parser->error_count))
6552                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6553                             OP_DESC(o));
6554             o->op_private |= OPpEXISTS_SUB;
6555         }
6556         else if (kid->op_type == OP_AELEM)
6557             o->op_flags |= OPf_SPECIAL;
6558         else if (kid->op_type != OP_HELEM)
6559             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6560                         OP_DESC(o));
6561         op_null(kid);
6562     }
6563     return o;
6564 }
6565
6566 OP *
6567 Perl_ck_rvconst(pTHX_ register OP *o)
6568 {
6569     dVAR;
6570     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6571
6572     PERL_ARGS_ASSERT_CK_RVCONST;
6573
6574     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6575     if (o->op_type == OP_RV2CV)
6576         o->op_private &= ~1;
6577
6578     if (kid->op_type == OP_CONST) {
6579         int iscv;
6580         GV *gv;
6581         SV * const kidsv = kid->op_sv;
6582
6583         /* Is it a constant from cv_const_sv()? */
6584         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6585             SV * const rsv = SvRV(kidsv);
6586             const svtype type = SvTYPE(rsv);
6587             const char *badtype = NULL;
6588
6589             switch (o->op_type) {
6590             case OP_RV2SV:
6591                 if (type > SVt_PVMG)
6592                     badtype = "a SCALAR";
6593                 break;
6594             case OP_RV2AV:
6595                 if (type != SVt_PVAV)
6596                     badtype = "an ARRAY";
6597                 break;
6598             case OP_RV2HV:
6599                 if (type != SVt_PVHV)
6600                     badtype = "a HASH";
6601                 break;
6602             case OP_RV2CV:
6603                 if (type != SVt_PVCV)
6604                     badtype = "a CODE";
6605                 break;
6606             }
6607             if (badtype)
6608                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6609             return o;
6610         }
6611         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6612                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6613             /* If this is an access to a stash, disable "strict refs", because
6614              * stashes aren't auto-vivified at compile-time (unless we store
6615              * symbols in them), and we don't want to produce a run-time
6616              * stricture error when auto-vivifying the stash. */
6617             const char *s = SvPV_nolen(kidsv);
6618             const STRLEN l = SvCUR(kidsv);
6619             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6620                 o->op_private &= ~HINT_STRICT_REFS;
6621         }
6622         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6623             const char *badthing;
6624             switch (o->op_type) {
6625             case OP_RV2SV:
6626                 badthing = "a SCALAR";
6627                 break;
6628             case OP_RV2AV:
6629                 badthing = "an ARRAY";
6630                 break;
6631             case OP_RV2HV:
6632                 badthing = "a HASH";
6633                 break;
6634             default:
6635                 badthing = NULL;
6636                 break;
6637             }
6638             if (badthing)
6639                 Perl_croak(aTHX_
6640                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6641                            SVfARG(kidsv), badthing);
6642         }
6643         /*
6644          * This is a little tricky.  We only want to add the symbol if we
6645          * didn't add it in the lexer.  Otherwise we get duplicate strict
6646          * warnings.  But if we didn't add it in the lexer, we must at
6647          * least pretend like we wanted to add it even if it existed before,
6648          * or we get possible typo warnings.  OPpCONST_ENTERED says
6649          * whether the lexer already added THIS instance of this symbol.
6650          */
6651         iscv = (o->op_type == OP_RV2CV) * 2;
6652         do {
6653             gv = gv_fetchsv(kidsv,
6654                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6655                 iscv
6656                     ? SVt_PVCV
6657                     : o->op_type == OP_RV2SV
6658                         ? SVt_PV
6659                         : o->op_type == OP_RV2AV
6660                             ? SVt_PVAV
6661                             : o->op_type == OP_RV2HV
6662                                 ? SVt_PVHV
6663                                 : SVt_PVGV);
6664         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6665         if (gv) {
6666             kid->op_type = OP_GV;
6667             SvREFCNT_dec(kid->op_sv);
6668 #ifdef USE_ITHREADS
6669             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6670             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6671             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6672             GvIN_PAD_on(gv);
6673             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6674 #else
6675             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6676 #endif
6677             kid->op_private = 0;
6678             kid->op_ppaddr = PL_ppaddr[OP_GV];
6679         }
6680     }
6681     return o;
6682 }
6683
6684 OP *
6685 Perl_ck_ftst(pTHX_ OP *o)
6686 {
6687     dVAR;
6688     const I32 type = o->op_type;
6689
6690     PERL_ARGS_ASSERT_CK_FTST;
6691
6692     if (o->op_flags & OPf_REF) {
6693         NOOP;
6694     }
6695     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6696         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6697         const OPCODE kidtype = kid->op_type;
6698
6699         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6700             OP * const newop = newGVOP(type, OPf_REF,
6701                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6702 #ifdef PERL_MAD
6703             op_getmad(o,newop,'O');
6704 #else
6705             op_free(o);
6706 #endif
6707             return newop;
6708         }
6709         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6710             o->op_private |= OPpFT_ACCESS;
6711         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6712                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6713             o->op_private |= OPpFT_STACKED;
6714     }
6715     else {
6716 #ifdef PERL_MAD
6717         OP* const oldo = o;
6718 #else
6719         op_free(o);
6720 #endif
6721         if (type == OP_FTTTY)
6722             o = newGVOP(type, OPf_REF, PL_stdingv);
6723         else
6724             o = newUNOP(type, 0, newDEFSVOP());
6725         op_getmad(oldo,o,'O');
6726     }
6727     return o;
6728 }
6729
6730 OP *
6731 Perl_ck_fun(pTHX_ OP *o)
6732 {
6733     dVAR;
6734     const int type = o->op_type;
6735     register I32 oa = PL_opargs[type] >> OASHIFT;
6736
6737     PERL_ARGS_ASSERT_CK_FUN;
6738
6739     if (o->op_flags & OPf_STACKED) {
6740         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6741             oa &= ~OA_OPTIONAL;
6742         else
6743             return no_fh_allowed(o);
6744     }
6745
6746     if (o->op_flags & OPf_KIDS) {
6747         OP **tokid = &cLISTOPo->op_first;
6748         register OP *kid = cLISTOPo->op_first;
6749         OP *sibl;
6750         I32 numargs = 0;
6751
6752         if (kid->op_type == OP_PUSHMARK ||
6753             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6754         {
6755             tokid = &kid->op_sibling;
6756             kid = kid->op_sibling;
6757         }
6758         if (!kid && PL_opargs[type] & OA_DEFGV)
6759             *tokid = kid = newDEFSVOP();
6760
6761         while (oa && kid) {
6762             numargs++;
6763             sibl = kid->op_sibling;
6764 #ifdef PERL_MAD
6765             if (!sibl && kid->op_type == OP_STUB) {
6766                 numargs--;
6767                 break;
6768             }
6769 #endif
6770             switch (oa & 7) {
6771             case OA_SCALAR:
6772                 /* list seen where single (scalar) arg expected? */
6773                 if (numargs == 1 && !(oa >> 4)
6774                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6775                 {
6776                     return too_many_arguments(o,PL_op_desc[type]);
6777                 }
6778                 scalar(kid);
6779                 break;
6780             case OA_LIST:
6781                 if (oa < 16) {
6782                     kid = 0;
6783                     continue;
6784                 }
6785                 else
6786                     list(kid);
6787                 break;
6788             case OA_AVREF:
6789                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6790                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6791                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6792                         "Useless use of %s with no values",
6793                         PL_op_desc[type]);
6794
6795                 if (kid->op_type == OP_CONST &&
6796                     (kid->op_private & OPpCONST_BARE))
6797                 {
6798                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6799                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6800                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6801                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6802                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6803                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6804 #ifdef PERL_MAD
6805                     op_getmad(kid,newop,'K');
6806 #else
6807                     op_free(kid);
6808 #endif
6809                     kid = newop;
6810                     kid->op_sibling = sibl;
6811                     *tokid = kid;
6812                 }
6813                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6814                     bad_type(numargs, "array", PL_op_desc[type], kid);
6815                 mod(kid, type);
6816                 break;
6817             case OA_HVREF:
6818                 if (kid->op_type == OP_CONST &&
6819                     (kid->op_private & OPpCONST_BARE))
6820                 {
6821                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6822                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6823                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6824                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6825                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6826                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6827 #ifdef PERL_MAD
6828                     op_getmad(kid,newop,'K');
6829 #else
6830                     op_free(kid);
6831 #endif
6832                     kid = newop;
6833                     kid->op_sibling = sibl;
6834                     *tokid = kid;
6835                 }
6836                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6837                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6838                 mod(kid, type);
6839                 break;
6840             case OA_CVREF:
6841                 {
6842                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6843                     kid->op_sibling = 0;
6844                     linklist(kid);
6845                     newop->op_next = newop;
6846                     kid = newop;
6847                     kid->op_sibling = sibl;
6848                     *tokid = kid;
6849                 }
6850                 break;
6851             case OA_FILEREF:
6852                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6853                     if (kid->op_type == OP_CONST &&
6854                         (kid->op_private & OPpCONST_BARE))
6855                     {
6856                         OP * const newop = newGVOP(OP_GV, 0,
6857                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6858                         if (!(o->op_private & 1) && /* if not unop */
6859                             kid == cLISTOPo->op_last)
6860                             cLISTOPo->op_last = newop;
6861 #ifdef PERL_MAD
6862                         op_getmad(kid,newop,'K');
6863 #else
6864                         op_free(kid);
6865 #endif
6866                         kid = newop;
6867                     }
6868                     else if (kid->op_type == OP_READLINE) {
6869                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6870                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6871                     }
6872                     else {
6873                         I32 flags = OPf_SPECIAL;
6874                         I32 priv = 0;
6875                         PADOFFSET targ = 0;
6876
6877                         /* is this op a FH constructor? */
6878                         if (is_handle_constructor(o,numargs)) {
6879                             const char *name = NULL;
6880                             STRLEN len = 0;
6881
6882                             flags = 0;
6883                             /* Set a flag to tell rv2gv to vivify
6884                              * need to "prove" flag does not mean something
6885                              * else already - NI-S 1999/05/07
6886                              */
6887                             priv = OPpDEREF;
6888                             if (kid->op_type == OP_PADSV) {
6889                                 SV *const namesv
6890                                     = PAD_COMPNAME_SV(kid->op_targ);
6891                                 name = SvPV_const(namesv, len);
6892                             }
6893                             else if (kid->op_type == OP_RV2SV
6894                                      && kUNOP->op_first->op_type == OP_GV)
6895                             {
6896                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6897                                 name = GvNAME(gv);
6898                                 len = GvNAMELEN(gv);
6899                             }
6900                             else if (kid->op_type == OP_AELEM
6901                                      || kid->op_type == OP_HELEM)
6902                             {
6903                                  OP *firstop;
6904                                  OP *op = ((BINOP*)kid)->op_first;
6905                                  name = NULL;
6906                                  if (op) {
6907                                       SV *tmpstr = NULL;
6908                                       const char * const a =
6909                                            kid->op_type == OP_AELEM ?
6910                                            "[]" : "{}";
6911                                       if (((op->op_type == OP_RV2AV) ||
6912                                            (op->op_type == OP_RV2HV)) &&
6913                                           (firstop = ((UNOP*)op)->op_first) &&
6914                                           (firstop->op_type == OP_GV)) {
6915                                            /* packagevar $a[] or $h{} */
6916                                            GV * const gv = cGVOPx_gv(firstop);
6917                                            if (gv)
6918                                                 tmpstr =
6919                                                      Perl_newSVpvf(aTHX_
6920                                                                    "%s%c...%c",
6921                                                                    GvNAME(gv),
6922                                                                    a[0], a[1]);
6923                                       }
6924                                       else if (op->op_type == OP_PADAV
6925                                                || op->op_type == OP_PADHV) {
6926                                            /* lexicalvar $a[] or $h{} */
6927                                            const char * const padname =
6928                                                 PAD_COMPNAME_PV(op->op_targ);
6929                                            if (padname)
6930                                                 tmpstr =
6931                                                      Perl_newSVpvf(aTHX_
6932                                                                    "%s%c...%c",
6933                                                                    padname + 1,
6934                                                                    a[0], a[1]);
6935                                       }
6936                                       if (tmpstr) {
6937                                            name = SvPV_const(tmpstr, len);
6938                                            sv_2mortal(tmpstr);
6939                                       }
6940                                  }
6941                                  if (!name) {
6942                                       name = "__ANONIO__";
6943                                       len = 10;
6944                                  }
6945                                  mod(kid, type);
6946                             }
6947                             if (name) {
6948                                 SV *namesv;
6949                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6950                                 namesv = PAD_SVl(targ);
6951                                 SvUPGRADE(namesv, SVt_PV);
6952                                 if (*name != '$')
6953                                     sv_setpvn(namesv, "$", 1);
6954                                 sv_catpvn(namesv, name, len);
6955                             }
6956                         }
6957                         kid->op_sibling = 0;
6958                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6959                         kid->op_targ = targ;
6960                         kid->op_private |= priv;
6961                     }
6962                     kid->op_sibling = sibl;
6963                     *tokid = kid;
6964                 }
6965                 scalar(kid);
6966                 break;
6967             case OA_SCALARREF:
6968                 mod(scalar(kid), type);
6969                 break;
6970             }
6971             oa >>= 4;
6972             tokid = &kid->op_sibling;
6973             kid = kid->op_sibling;
6974         }
6975 #ifdef PERL_MAD
6976         if (kid && kid->op_type != OP_STUB)
6977             return too_many_arguments(o,OP_DESC(o));
6978         o->op_private |= numargs;
6979 #else
6980         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6981         o->op_private |= numargs;
6982         if (kid)
6983             return too_many_arguments(o,OP_DESC(o));
6984 #endif
6985         listkids(o);
6986     }
6987     else if (PL_opargs[type] & OA_DEFGV) {
6988 #ifdef PERL_MAD
6989         OP *newop = newUNOP(type, 0, newDEFSVOP());
6990         op_getmad(o,newop,'O');
6991         return newop;
6992 #else
6993         /* Ordering of these two is important to keep f_map.t passing.  */
6994         op_free(o);
6995         return newUNOP(type, 0, newDEFSVOP());
6996 #endif
6997     }
6998
6999     if (oa) {
7000         while (oa & OA_OPTIONAL)
7001             oa >>= 4;
7002         if (oa && oa != OA_LIST)
7003             return too_few_arguments(o,OP_DESC(o));
7004     }
7005     return o;
7006 }
7007
7008 OP *
7009 Perl_ck_glob(pTHX_ OP *o)
7010 {
7011     dVAR;
7012     GV *gv;
7013
7014     PERL_ARGS_ASSERT_CK_GLOB;
7015
7016     o = ck_fun(o);
7017     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7018         append_elem(OP_GLOB, o, newDEFSVOP());
7019
7020     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7021           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7022     {
7023         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7024     }
7025
7026 #if !defined(PERL_EXTERNAL_GLOB)
7027     /* XXX this can be tightened up and made more failsafe. */
7028     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7029         GV *glob_gv;
7030         ENTER;
7031         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7032                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7033         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7034         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7035         GvCV(gv) = GvCV(glob_gv);
7036         SvREFCNT_inc_void((SV*)GvCV(gv));
7037         GvIMPORTED_CV_on(gv);
7038         LEAVE;
7039     }
7040 #endif /* PERL_EXTERNAL_GLOB */
7041
7042     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7043         append_elem(OP_GLOB, o,
7044                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7045         o->op_type = OP_LIST;
7046         o->op_ppaddr = PL_ppaddr[OP_LIST];
7047         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7048         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7049         cLISTOPo->op_first->op_targ = 0;
7050         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7051                     append_elem(OP_LIST, o,
7052                                 scalar(newUNOP(OP_RV2CV, 0,
7053                                                newGVOP(OP_GV, 0, gv)))));
7054         o = newUNOP(OP_NULL, 0, ck_subr(o));
7055         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7056         return o;
7057     }
7058     gv = newGVgen("main");
7059     gv_IOadd(gv);
7060     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7061     scalarkids(o);
7062     return o;
7063 }
7064
7065 OP *
7066 Perl_ck_grep(pTHX_ OP *o)
7067 {
7068     dVAR;
7069     LOGOP *gwop = NULL;
7070     OP *kid;
7071     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7072     PADOFFSET offset;
7073
7074     PERL_ARGS_ASSERT_CK_GREP;
7075
7076     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7077     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7078
7079     if (o->op_flags & OPf_STACKED) {
7080         OP* k;
7081         o = ck_sort(o);
7082         kid = cLISTOPo->op_first->op_sibling;
7083         if (!cUNOPx(kid)->op_next)
7084             Perl_croak(aTHX_ "panic: ck_grep");
7085         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7086             kid = k;
7087         }
7088         NewOp(1101, gwop, 1, LOGOP);
7089         kid->op_next = (OP*)gwop;
7090         o->op_flags &= ~OPf_STACKED;
7091     }
7092     kid = cLISTOPo->op_first->op_sibling;
7093     if (type == OP_MAPWHILE)
7094         list(kid);
7095     else
7096         scalar(kid);
7097     o = ck_fun(o);
7098     if (PL_parser && PL_parser->error_count)
7099         return o;
7100     kid = cLISTOPo->op_first->op_sibling;
7101     if (kid->op_type != OP_NULL)
7102         Perl_croak(aTHX_ "panic: ck_grep");
7103     kid = kUNOP->op_first;
7104
7105     if (!gwop)
7106         NewOp(1101, gwop, 1, LOGOP);
7107     gwop->op_type = type;
7108     gwop->op_ppaddr = PL_ppaddr[type];
7109     gwop->op_first = listkids(o);
7110     gwop->op_flags |= OPf_KIDS;
7111     gwop->op_other = LINKLIST(kid);
7112     kid->op_next = (OP*)gwop;
7113     offset = pad_findmy("$_");
7114     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7115         o->op_private = gwop->op_private = 0;
7116         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7117     }
7118     else {
7119         o->op_private = gwop->op_private = OPpGREP_LEX;
7120         gwop->op_targ = o->op_targ = offset;
7121     }
7122
7123     kid = cLISTOPo->op_first->op_sibling;
7124     if (!kid || !kid->op_sibling)
7125         return too_few_arguments(o,OP_DESC(o));
7126     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7127         mod(kid, OP_GREPSTART);
7128
7129     return (OP*)gwop;
7130 }
7131
7132 OP *
7133 Perl_ck_index(pTHX_ OP *o)
7134 {
7135     PERL_ARGS_ASSERT_CK_INDEX;
7136
7137     if (o->op_flags & OPf_KIDS) {
7138         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7139         if (kid)
7140             kid = kid->op_sibling;                      /* get past "big" */
7141         if (kid && kid->op_type == OP_CONST)
7142             fbm_compile(((SVOP*)kid)->op_sv, 0);
7143     }
7144     return ck_fun(o);
7145 }
7146
7147 OP *
7148 Perl_ck_lfun(pTHX_ OP *o)
7149 {
7150     const OPCODE type = o->op_type;
7151
7152     PERL_ARGS_ASSERT_CK_LFUN;
7153
7154     return modkids(ck_fun(o), type);
7155 }
7156
7157 OP *
7158 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7159 {
7160     PERL_ARGS_ASSERT_CK_DEFINED;
7161
7162     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7163         switch (cUNOPo->op_first->op_type) {
7164         case OP_RV2AV:
7165             /* This is needed for
7166                if (defined %stash::)
7167                to work.   Do not break Tk.
7168                */
7169             break;                      /* Globals via GV can be undef */
7170         case OP_PADAV:
7171         case OP_AASSIGN:                /* Is this a good idea? */
7172             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7173                         "defined(@array) is deprecated");
7174             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7175                         "\t(Maybe you should just omit the defined()?)\n");
7176         break;
7177         case OP_RV2HV:
7178             /* This is needed for
7179                if (defined %stash::)
7180                to work.   Do not break Tk.
7181                */
7182             break;                      /* Globals via GV can be undef */
7183         case OP_PADHV:
7184             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7185                         "defined(%%hash) is deprecated");
7186             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7187                         "\t(Maybe you should just omit the defined()?)\n");
7188             break;
7189         default:
7190             /* no warning */
7191             break;
7192         }
7193     }
7194     return ck_rfun(o);
7195 }
7196
7197 OP *
7198 Perl_ck_readline(pTHX_ OP *o)
7199 {
7200     PERL_ARGS_ASSERT_CK_READLINE;
7201
7202     if (!(o->op_flags & OPf_KIDS)) {
7203         OP * const newop
7204             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7205 #ifdef PERL_MAD
7206         op_getmad(o,newop,'O');
7207 #else
7208         op_free(o);
7209 #endif
7210         return newop;
7211     }
7212     return o;
7213 }
7214
7215 OP *
7216 Perl_ck_rfun(pTHX_ OP *o)
7217 {
7218     const OPCODE type = o->op_type;
7219
7220     PERL_ARGS_ASSERT_CK_RFUN;
7221
7222     return refkids(ck_fun(o), type);
7223 }
7224
7225 OP *
7226 Perl_ck_listiob(pTHX_ OP *o)
7227 {
7228     register OP *kid;
7229
7230     PERL_ARGS_ASSERT_CK_LISTIOB;
7231
7232     kid = cLISTOPo->op_first;
7233     if (!kid) {
7234         o = force_list(o);
7235         kid = cLISTOPo->op_first;
7236     }
7237     if (kid->op_type == OP_PUSHMARK)
7238         kid = kid->op_sibling;
7239     if (kid && o->op_flags & OPf_STACKED)
7240         kid = kid->op_sibling;
7241     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7242         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7243             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7244             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7245             cLISTOPo->op_first->op_sibling = kid;
7246             cLISTOPo->op_last = kid;
7247             kid = kid->op_sibling;
7248         }
7249     }
7250
7251     if (!kid)
7252         append_elem(o->op_type, o, newDEFSVOP());
7253
7254     return listkids(o);
7255 }
7256
7257 OP *
7258 Perl_ck_smartmatch(pTHX_ OP *o)
7259 {
7260     dVAR;
7261     if (0 == (o->op_flags & OPf_SPECIAL)) {
7262         OP *first  = cBINOPo->op_first;
7263         OP *second = first->op_sibling;
7264
7265         /* Implicitly take a reference to an array or hash */
7266         first->op_sibling = NULL;
7267         first = cBINOPo->op_first = ref_array_or_hash(first);
7268         second = first->op_sibling = ref_array_or_hash(second);
7269
7270         /* Implicitly take a reference to a regular expression */
7271         if (first->op_type == OP_MATCH) {
7272             first->op_type = OP_QR;
7273             first->op_ppaddr = PL_ppaddr[OP_QR];
7274         }
7275         if (second->op_type == OP_MATCH) {
7276             second->op_type = OP_QR;
7277             second->op_ppaddr = PL_ppaddr[OP_QR];
7278         }
7279     }
7280
7281     return o;
7282 }
7283
7284
7285 OP *
7286 Perl_ck_sassign(pTHX_ OP *o)
7287 {
7288     dVAR;
7289     OP * const kid = cLISTOPo->op_first;
7290
7291     PERL_ARGS_ASSERT_CK_SASSIGN;
7292
7293     /* has a disposable target? */
7294     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7295         && !(kid->op_flags & OPf_STACKED)
7296         /* Cannot steal the second time! */
7297         && !(kid->op_private & OPpTARGET_MY)
7298         /* Keep the full thing for madskills */
7299         && !PL_madskills
7300         )
7301     {
7302         OP * const kkid = kid->op_sibling;
7303
7304         /* Can just relocate the target. */
7305         if (kkid && kkid->op_type == OP_PADSV
7306             && !(kkid->op_private & OPpLVAL_INTRO))
7307         {
7308             kid->op_targ = kkid->op_targ;
7309             kkid->op_targ = 0;
7310             /* Now we do not need PADSV and SASSIGN. */
7311             kid->op_sibling = o->op_sibling;    /* NULL */
7312             cLISTOPo->op_first = NULL;
7313             op_free(o);
7314             op_free(kkid);
7315             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7316             return kid;
7317         }
7318     }
7319     if (kid->op_sibling) {
7320         OP *kkid = kid->op_sibling;
7321         if (kkid->op_type == OP_PADSV
7322                 && (kkid->op_private & OPpLVAL_INTRO)
7323                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7324             const PADOFFSET target = kkid->op_targ;
7325             OP *const other = newOP(OP_PADSV,
7326                                     kkid->op_flags
7327                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7328             OP *const first = newOP(OP_NULL, 0);
7329             OP *const nullop = newCONDOP(0, first, o, other);
7330             OP *const condop = first->op_next;
7331             /* hijacking PADSTALE for uninitialized state variables */
7332             SvPADSTALE_on(PAD_SVl(target));
7333
7334             condop->op_type = OP_ONCE;
7335             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7336             condop->op_targ = target;
7337             other->op_targ = target;
7338
7339             /* Because we change the type of the op here, we will skip the
7340                assinment binop->op_last = binop->op_first->op_sibling; at the
7341                end of Perl_newBINOP(). So need to do it here. */
7342             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7343
7344             return nullop;
7345         }
7346     }
7347     return o;
7348 }
7349
7350 OP *
7351 Perl_ck_match(pTHX_ OP *o)
7352 {
7353     dVAR;
7354
7355     PERL_ARGS_ASSERT_CK_MATCH;
7356
7357     if (o->op_type != OP_QR && PL_compcv) {
7358         const PADOFFSET offset = pad_findmy("$_");
7359         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7360             o->op_targ = offset;
7361             o->op_private |= OPpTARGET_MY;
7362         }
7363     }
7364     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7365         o->op_private |= OPpRUNTIME;
7366     return o;
7367 }
7368
7369 OP *
7370 Perl_ck_method(pTHX_ OP *o)
7371 {
7372     OP * const kid = cUNOPo->op_first;
7373
7374     PERL_ARGS_ASSERT_CK_METHOD;
7375
7376     if (kid->op_type == OP_CONST) {
7377         SV* sv = kSVOP->op_sv;
7378         const char * const method = SvPVX_const(sv);
7379         if (!(strchr(method, ':') || strchr(method, '\''))) {
7380             OP *cmop;
7381             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7382                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7383             }
7384             else {
7385                 kSVOP->op_sv = NULL;
7386             }
7387             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7388 #ifdef PERL_MAD
7389             op_getmad(o,cmop,'O');
7390 #else
7391             op_free(o);
7392 #endif
7393             return cmop;
7394         }
7395     }
7396     return o;
7397 }
7398
7399 OP *
7400 Perl_ck_null(pTHX_ OP *o)
7401 {
7402     PERL_ARGS_ASSERT_CK_NULL;
7403     PERL_UNUSED_CONTEXT;
7404     return o;
7405 }
7406
7407 OP *
7408 Perl_ck_open(pTHX_ OP *o)
7409 {
7410     dVAR;
7411     HV * const table = GvHV(PL_hintgv);
7412
7413     PERL_ARGS_ASSERT_CK_OPEN;
7414
7415     if (table) {
7416         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7417         if (svp && *svp) {
7418             const I32 mode = mode_from_discipline(*svp);
7419             if (mode & O_BINARY)
7420                 o->op_private |= OPpOPEN_IN_RAW;
7421             else if (mode & O_TEXT)
7422                 o->op_private |= OPpOPEN_IN_CRLF;
7423         }
7424
7425         svp = hv_fetchs(table, "open_OUT", FALSE);
7426         if (svp && *svp) {
7427             const I32 mode = mode_from_discipline(*svp);
7428             if (mode & O_BINARY)
7429                 o->op_private |= OPpOPEN_OUT_RAW;
7430             else if (mode & O_TEXT)
7431                 o->op_private |= OPpOPEN_OUT_CRLF;
7432         }
7433     }
7434     if (o->op_type == OP_BACKTICK) {
7435         if (!(o->op_flags & OPf_KIDS)) {
7436             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7437 #ifdef PERL_MAD
7438             op_getmad(o,newop,'O');
7439 #else
7440             op_free(o);
7441 #endif
7442             return newop;
7443         }
7444         return o;
7445     }
7446     {
7447          /* In case of three-arg dup open remove strictness
7448           * from the last arg if it is a bareword. */
7449          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7450          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7451          OP *oa;
7452          const char *mode;
7453
7454          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7455              (last->op_private & OPpCONST_BARE) &&
7456              (last->op_private & OPpCONST_STRICT) &&
7457              (oa = first->op_sibling) &&                /* The fh. */
7458              (oa = oa->op_sibling) &&                   /* The mode. */
7459              (oa->op_type == OP_CONST) &&
7460              SvPOK(((SVOP*)oa)->op_sv) &&
7461              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7462              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7463              (last == oa->op_sibling))                  /* The bareword. */
7464               last->op_private &= ~OPpCONST_STRICT;
7465     }
7466     return ck_fun(o);
7467 }
7468
7469 OP *
7470 Perl_ck_repeat(pTHX_ OP *o)
7471 {
7472     PERL_ARGS_ASSERT_CK_REPEAT;
7473
7474     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7475         o->op_private |= OPpREPEAT_DOLIST;
7476         cBINOPo->op_first = force_list(cBINOPo->op_first);
7477     }
7478     else
7479         scalar(o);
7480     return o;
7481 }
7482
7483 OP *
7484 Perl_ck_require(pTHX_ OP *o)
7485 {
7486     dVAR;
7487     GV* gv = NULL;
7488
7489     PERL_ARGS_ASSERT_CK_REQUIRE;
7490
7491     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7492         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7493
7494         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7495             SV * const sv = kid->op_sv;
7496             U32 was_readonly = SvREADONLY(sv);
7497             char *s;
7498             STRLEN len;
7499             const char *end;
7500
7501             if (was_readonly) {
7502                 if (SvFAKE(sv)) {
7503                     sv_force_normal_flags(sv, 0);
7504                     assert(!SvREADONLY(sv));
7505                     was_readonly = 0;
7506                 } else {
7507                     SvREADONLY_off(sv);
7508                 }
7509             }
7510
7511             s = SvPVX(sv);
7512             len = SvCUR(sv);
7513             end = s + len;
7514             for (; s < end; s++) {
7515                 if (*s == ':' && s[1] == ':') {
7516                     *s = '/';
7517                     Move(s+2, s+1, end - s - 1, char);
7518                     --end;
7519                 }
7520             }
7521             SvEND_set(sv, end);
7522             sv_catpvs(sv, ".pm");
7523             SvFLAGS(sv) |= was_readonly;
7524         }
7525     }
7526
7527     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7528         /* handle override, if any */
7529         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7530         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7531             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7532             gv = gvp ? *gvp : NULL;
7533         }
7534     }
7535
7536     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7537         OP * const kid = cUNOPo->op_first;
7538         OP * newop;
7539
7540         cUNOPo->op_first = 0;
7541 #ifndef PERL_MAD
7542         op_free(o);
7543 #endif
7544         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7545                                 append_elem(OP_LIST, kid,
7546                                             scalar(newUNOP(OP_RV2CV, 0,
7547                                                            newGVOP(OP_GV, 0,
7548                                                                    gv))))));
7549         op_getmad(o,newop,'O');
7550         return newop;
7551     }
7552
7553     return ck_fun(o);
7554 }
7555
7556 OP *
7557 Perl_ck_return(pTHX_ OP *o)
7558 {
7559     dVAR;
7560
7561     PERL_ARGS_ASSERT_CK_RETURN;
7562
7563     if (CvLVALUE(PL_compcv)) {
7564         OP *kid;
7565         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7566             mod(kid, OP_LEAVESUBLV);
7567     }
7568     return o;
7569 }
7570
7571 OP *
7572 Perl_ck_select(pTHX_ OP *o)
7573 {
7574     dVAR;
7575     OP* kid;
7576
7577     PERL_ARGS_ASSERT_CK_SELECT;
7578
7579     if (o->op_flags & OPf_KIDS) {
7580         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7581         if (kid && kid->op_sibling) {
7582             o->op_type = OP_SSELECT;
7583             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7584             o = ck_fun(o);
7585             return fold_constants(o);
7586         }
7587     }
7588     o = ck_fun(o);
7589     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7590     if (kid && kid->op_type == OP_RV2GV)
7591         kid->op_private &= ~HINT_STRICT_REFS;
7592     return o;
7593 }
7594
7595 OP *
7596 Perl_ck_shift(pTHX_ OP *o)
7597 {
7598     dVAR;
7599     const I32 type = o->op_type;
7600
7601     PERL_ARGS_ASSERT_CK_SHIFT;
7602
7603     if (!(o->op_flags & OPf_KIDS)) {
7604         OP *argop;
7605         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7606 #ifdef PERL_MAD
7607         OP * const oldo = o;
7608 #else
7609         op_free(o);
7610 #endif
7611         argop = newUNOP(OP_RV2AV, 0,
7612             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7613 #ifdef PERL_MAD
7614         o = newUNOP(type, 0, scalar(argop));
7615         op_getmad(oldo,o,'O');
7616         return o;
7617 #else
7618         return newUNOP(type, 0, scalar(argop));
7619 #endif
7620     }
7621     return scalar(modkids(ck_fun(o), type));
7622 }
7623
7624 OP *
7625 Perl_ck_sort(pTHX_ OP *o)
7626 {
7627     dVAR;
7628     OP *firstkid;
7629
7630     PERL_ARGS_ASSERT_CK_SORT;
7631
7632     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7633         HV * const hinthv = GvHV(PL_hintgv);
7634         if (hinthv) {
7635             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7636             if (svp) {
7637                 const I32 sorthints = (I32)SvIV(*svp);
7638                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7639                     o->op_private |= OPpSORT_QSORT;
7640                 if ((sorthints & HINT_SORT_STABLE) != 0)
7641                     o->op_private |= OPpSORT_STABLE;
7642             }
7643         }
7644     }
7645
7646     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7647         simplify_sort(o);
7648     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7649     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7650         OP *k = NULL;
7651         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7652
7653         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7654             linklist(kid);
7655             if (kid->op_type == OP_SCOPE) {
7656                 k = kid->op_next;
7657                 kid->op_next = 0;
7658             }
7659             else if (kid->op_type == OP_LEAVE) {
7660                 if (o->op_type == OP_SORT) {
7661                     op_null(kid);                       /* wipe out leave */
7662                     kid->op_next = kid;
7663
7664                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7665                         if (k->op_next == kid)
7666                             k->op_next = 0;
7667                         /* don't descend into loops */
7668                         else if (k->op_type == OP_ENTERLOOP
7669                                  || k->op_type == OP_ENTERITER)
7670                         {
7671                             k = cLOOPx(k)->op_lastop;
7672                         }
7673                     }
7674                 }
7675                 else
7676                     kid->op_next = 0;           /* just disconnect the leave */
7677                 k = kLISTOP->op_first;
7678             }
7679             CALL_PEEP(k);
7680
7681             kid = firstkid;
7682             if (o->op_type == OP_SORT) {
7683                 /* provide scalar context for comparison function/block */
7684                 kid = scalar(kid);
7685                 kid->op_next = kid;
7686             }
7687             else
7688                 kid->op_next = k;
7689             o->op_flags |= OPf_SPECIAL;
7690         }
7691         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7692             op_null(firstkid);
7693
7694         firstkid = firstkid->op_sibling;
7695     }
7696
7697     /* provide list context for arguments */
7698     if (o->op_type == OP_SORT)
7699         list(firstkid);
7700
7701     return o;
7702 }
7703
7704 STATIC void
7705 S_simplify_sort(pTHX_ OP *o)
7706 {
7707     dVAR;
7708     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7709     OP *k;
7710     int descending;
7711     GV *gv;
7712     const char *gvname;
7713
7714     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7715
7716     if (!(o->op_flags & OPf_STACKED))
7717         return;
7718     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7719     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7720     kid = kUNOP->op_first;                              /* get past null */
7721     if (kid->op_type != OP_SCOPE)
7722         return;
7723     kid = kLISTOP->op_last;                             /* get past scope */
7724     switch(kid->op_type) {
7725         case OP_NCMP:
7726         case OP_I_NCMP:
7727         case OP_SCMP:
7728             break;
7729         default:
7730             return;
7731     }
7732     k = kid;                                            /* remember this node*/
7733     if (kBINOP->op_first->op_type != OP_RV2SV)
7734         return;
7735     kid = kBINOP->op_first;                             /* get past cmp */
7736     if (kUNOP->op_first->op_type != OP_GV)
7737         return;
7738     kid = kUNOP->op_first;                              /* get past rv2sv */
7739     gv = kGVOP_gv;
7740     if (GvSTASH(gv) != PL_curstash)
7741         return;
7742     gvname = GvNAME(gv);
7743     if (*gvname == 'a' && gvname[1] == '\0')
7744         descending = 0;
7745     else if (*gvname == 'b' && gvname[1] == '\0')
7746         descending = 1;
7747     else
7748         return;
7749
7750     kid = k;                                            /* back to cmp */
7751     if (kBINOP->op_last->op_type != OP_RV2SV)
7752         return;
7753     kid = kBINOP->op_last;                              /* down to 2nd arg */
7754     if (kUNOP->op_first->op_type != OP_GV)
7755         return;
7756     kid = kUNOP->op_first;                              /* get past rv2sv */
7757     gv = kGVOP_gv;
7758     if (GvSTASH(gv) != PL_curstash)
7759         return;
7760     gvname = GvNAME(gv);
7761     if ( descending
7762          ? !(*gvname == 'a' && gvname[1] == '\0')
7763          : !(*gvname == 'b' && gvname[1] == '\0'))
7764         return;
7765     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7766     if (descending)
7767         o->op_private |= OPpSORT_DESCEND;
7768     if (k->op_type == OP_NCMP)
7769         o->op_private |= OPpSORT_NUMERIC;
7770     if (k->op_type == OP_I_NCMP)
7771         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7772     kid = cLISTOPo->op_first->op_sibling;
7773     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7774 #ifdef PERL_MAD
7775     op_getmad(kid,o,'S');                             /* then delete it */
7776 #else
7777     op_free(kid);                                     /* then delete it */
7778 #endif
7779 }
7780
7781 OP *
7782 Perl_ck_split(pTHX_ OP *o)
7783 {
7784     dVAR;
7785     register OP *kid;
7786
7787     PERL_ARGS_ASSERT_CK_SPLIT;
7788
7789     if (o->op_flags & OPf_STACKED)
7790         return no_fh_allowed(o);
7791
7792     kid = cLISTOPo->op_first;
7793     if (kid->op_type != OP_NULL)
7794         Perl_croak(aTHX_ "panic: ck_split");
7795     kid = kid->op_sibling;
7796     op_free(cLISTOPo->op_first);
7797     cLISTOPo->op_first = kid;
7798     if (!kid) {
7799         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7800         cLISTOPo->op_last = kid; /* There was only one element previously */
7801     }
7802
7803     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7804         OP * const sibl = kid->op_sibling;
7805         kid->op_sibling = 0;
7806         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7807         if (cLISTOPo->op_first == cLISTOPo->op_last)
7808             cLISTOPo->op_last = kid;
7809         cLISTOPo->op_first = kid;
7810         kid->op_sibling = sibl;
7811     }
7812
7813     kid->op_type = OP_PUSHRE;
7814     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7815     scalar(kid);
7816     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7817       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7818                   "Use of /g modifier is meaningless in split");
7819     }
7820
7821     if (!kid->op_sibling)
7822         append_elem(OP_SPLIT, o, newDEFSVOP());
7823
7824     kid = kid->op_sibling;
7825     scalar(kid);
7826
7827     if (!kid->op_sibling)
7828         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7829     assert(kid->op_sibling);
7830
7831     kid = kid->op_sibling;
7832     scalar(kid);
7833
7834     if (kid->op_sibling)
7835         return too_many_arguments(o,OP_DESC(o));
7836
7837     return o;
7838 }
7839
7840 OP *
7841 Perl_ck_join(pTHX_ OP *o)
7842 {
7843     const OP * const kid = cLISTOPo->op_first->op_sibling;
7844
7845     PERL_ARGS_ASSERT_CK_JOIN;
7846
7847     if (kid && kid->op_type == OP_MATCH) {
7848         if (ckWARN(WARN_SYNTAX)) {
7849             const REGEXP *re = PM_GETRE(kPMOP);
7850             const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7851             const STRLEN len = re ? RX_PRELEN(re) : 6;
7852             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7853                         "/%.*s/ should probably be written as \"%.*s\"",
7854                         (int)len, pmstr, (int)len, pmstr);
7855         }
7856     }
7857     return ck_fun(o);
7858 }
7859
7860 OP *
7861 Perl_ck_subr(pTHX_ OP *o)
7862 {
7863     dVAR;
7864     OP *prev = ((cUNOPo->op_first->op_sibling)
7865              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7866     OP *o2 = prev->op_sibling;
7867     OP *cvop;
7868     const char *proto = NULL;
7869     const char *proto_end = NULL;
7870     CV *cv = NULL;
7871     GV *namegv = NULL;
7872     int optional = 0;
7873     I32 arg = 0;
7874     I32 contextclass = 0;
7875     const char *e = NULL;
7876     bool delete_op = 0;
7877
7878     PERL_ARGS_ASSERT_CK_SUBR;
7879
7880     o->op_private |= OPpENTERSUB_HASTARG;
7881     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7882     if (cvop->op_type == OP_RV2CV) {
7883         SVOP* tmpop;
7884         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7885         op_null(cvop);          /* disable rv2cv */
7886         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7887         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7888             GV *gv = cGVOPx_gv(tmpop);
7889             cv = GvCVu(gv);
7890             if (!cv)
7891                 tmpop->op_private |= OPpEARLY_CV;
7892             else {
7893                 if (SvPOK(cv)) {
7894                     STRLEN len;
7895                     namegv = CvANON(cv) ? gv : CvGV(cv);
7896                     proto = SvPV((SV*)cv, len);
7897                     proto_end = proto + len;
7898                 }
7899             }
7900         }
7901     }
7902     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7903         if (o2->op_type == OP_CONST)
7904             o2->op_private &= ~OPpCONST_STRICT;
7905         else if (o2->op_type == OP_LIST) {
7906             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7907             if (sib && sib->op_type == OP_CONST)
7908                 sib->op_private &= ~OPpCONST_STRICT;
7909         }
7910     }
7911     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7912     if (PERLDB_SUB && PL_curstash != PL_debstash)
7913         o->op_private |= OPpENTERSUB_DB;
7914     while (o2 != cvop) {
7915         OP* o3;
7916         if (PL_madskills && o2->op_type == OP_STUB) {
7917             o2 = o2->op_sibling;
7918             continue;
7919         }
7920         if (PL_madskills && o2->op_type == OP_NULL)
7921             o3 = ((UNOP*)o2)->op_first;
7922         else
7923             o3 = o2;
7924         if (proto) {
7925             if (proto >= proto_end)
7926                 return too_many_arguments(o, gv_ename(namegv));
7927
7928             switch (*proto) {
7929             case ';':
7930                 optional = 1;
7931                 proto++;
7932                 continue;
7933             case '_':
7934                 /* _ must be at the end */
7935                 if (proto[1] && proto[1] != ';')
7936                     goto oops;
7937             case '$':
7938                 proto++;
7939                 arg++;
7940                 scalar(o2);
7941                 break;
7942             case '%':
7943             case '@':
7944                 list(o2);
7945                 arg++;
7946                 break;
7947             case '&':
7948                 proto++;
7949                 arg++;
7950                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7951                     bad_type(arg,
7952                         arg == 1 ? "block or sub {}" : "sub {}",
7953                         gv_ename(namegv), o3);
7954                 break;
7955             case '*':
7956                 /* '*' allows any scalar type, including bareword */
7957                 proto++;
7958                 arg++;
7959                 if (o3->op_type == OP_RV2GV)
7960                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7961                 else if (o3->op_type == OP_CONST)
7962                     o3->op_private &= ~OPpCONST_STRICT;
7963                 else if (o3->op_type == OP_ENTERSUB) {
7964                     /* accidental subroutine, revert to bareword */
7965                     OP *gvop = ((UNOP*)o3)->op_first;
7966                     if (gvop && gvop->op_type == OP_NULL) {
7967                         gvop = ((UNOP*)gvop)->op_first;
7968                         if (gvop) {
7969                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7970                                 ;
7971                             if (gvop &&
7972                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7973                                 (gvop = ((UNOP*)gvop)->op_first) &&
7974                                 gvop->op_type == OP_GV)
7975                             {
7976                                 GV * const gv = cGVOPx_gv(gvop);
7977                                 OP * const sibling = o2->op_sibling;
7978                                 SV * const n = newSVpvs("");
7979 #ifdef PERL_MAD
7980                                 OP * const oldo2 = o2;
7981 #else
7982                                 op_free(o2);
7983 #endif
7984                                 gv_fullname4(n, gv, "", FALSE);
7985                                 o2 = newSVOP(OP_CONST, 0, n);
7986                                 op_getmad(oldo2,o2,'O');
7987                                 prev->op_sibling = o2;
7988                                 o2->op_sibling = sibling;
7989                             }
7990                         }
7991                     }
7992                 }
7993                 scalar(o2);
7994                 break;
7995             case '[': case ']':
7996                  goto oops;
7997                  break;
7998             case '\\':
7999                 proto++;
8000                 arg++;
8001             again:
8002                 switch (*proto++) {
8003                 case '[':
8004                      if (contextclass++ == 0) {
8005                           e = strchr(proto, ']');
8006                           if (!e || e == proto)
8007                                goto oops;
8008                      }
8009                      else
8010                           goto oops;
8011                      goto again;
8012                      break;
8013                 case ']':
8014                      if (contextclass) {
8015                          const char *p = proto;
8016                          const char *const end = proto;
8017                          contextclass = 0;
8018                          while (*--p != '[');
8019                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8020                                                  (int)(end - p), p),
8021                                   gv_ename(namegv), o3);
8022                      } else
8023                           goto oops;
8024                      break;
8025                 case '*':
8026                      if (o3->op_type == OP_RV2GV)
8027                           goto wrapref;
8028                      if (!contextclass)
8029                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8030                      break;
8031                 case '&':
8032                      if (o3->op_type == OP_ENTERSUB)
8033                           goto wrapref;
8034                      if (!contextclass)
8035                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8036                                    o3);
8037                      break;
8038                 case '$':
8039                     if (o3->op_type == OP_RV2SV ||
8040                         o3->op_type == OP_PADSV ||
8041                         o3->op_type == OP_HELEM ||
8042                         o3->op_type == OP_AELEM)
8043                          goto wrapref;
8044                     if (!contextclass)
8045                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8046                      break;
8047                 case '@':
8048                     if (o3->op_type == OP_RV2AV ||
8049                         o3->op_type == OP_PADAV)
8050                          goto wrapref;
8051                     if (!contextclass)
8052                         bad_type(arg, "array", gv_ename(namegv), o3);
8053                     break;
8054                 case '%':
8055                     if (o3->op_type == OP_RV2HV ||
8056                         o3->op_type == OP_PADHV)
8057                          goto wrapref;
8058                     if (!contextclass)
8059                          bad_type(arg, "hash", gv_ename(namegv), o3);
8060                     break;
8061                 wrapref:
8062                     {
8063                         OP* const kid = o2;
8064                         OP* const sib = kid->op_sibling;
8065                         kid->op_sibling = 0;
8066                         o2 = newUNOP(OP_REFGEN, 0, kid);
8067                         o2->op_sibling = sib;
8068                         prev->op_sibling = o2;
8069                     }
8070                     if (contextclass && e) {
8071                          proto = e + 1;
8072                          contextclass = 0;
8073                     }
8074                     break;
8075                 default: goto oops;
8076                 }
8077                 if (contextclass)
8078                      goto again;
8079                 break;
8080             case ' ':
8081                 proto++;
8082                 continue;
8083             default:
8084               oops:
8085                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8086                            gv_ename(namegv), SVfARG(cv));
8087             }
8088         }
8089         else
8090             list(o2);
8091         mod(o2, OP_ENTERSUB);
8092         prev = o2;
8093         o2 = o2->op_sibling;
8094     } /* while */
8095     if (o2 == cvop && proto && *proto == '_') {
8096         /* generate an access to $_ */
8097         o2 = newDEFSVOP();
8098         o2->op_sibling = prev->op_sibling;
8099         prev->op_sibling = o2; /* instead of cvop */
8100     }
8101     if (proto && !optional && proto_end > proto &&
8102         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8103         return too_few_arguments(o, gv_ename(namegv));
8104     if(delete_op) {
8105 #ifdef PERL_MAD
8106         OP * const oldo = o;
8107 #else
8108         op_free(o);
8109 #endif
8110         o=newSVOP(OP_CONST, 0, newSViv(0));
8111         op_getmad(oldo,o,'O');
8112     }
8113     return o;
8114 }
8115
8116 OP *
8117 Perl_ck_svconst(pTHX_ OP *o)
8118 {
8119     PERL_ARGS_ASSERT_CK_SVCONST;
8120     PERL_UNUSED_CONTEXT;
8121     SvREADONLY_on(cSVOPo->op_sv);
8122     return o;
8123 }
8124
8125 OP *
8126 Perl_ck_chdir(pTHX_ OP *o)
8127 {
8128     if (o->op_flags & OPf_KIDS) {
8129         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8130
8131         if (kid && kid->op_type == OP_CONST &&
8132             (kid->op_private & OPpCONST_BARE))
8133         {
8134             o->op_flags |= OPf_SPECIAL;
8135             kid->op_private &= ~OPpCONST_STRICT;
8136         }
8137     }
8138     return ck_fun(o);
8139 }
8140
8141 OP *
8142 Perl_ck_trunc(pTHX_ OP *o)
8143 {
8144     PERL_ARGS_ASSERT_CK_TRUNC;
8145
8146     if (o->op_flags & OPf_KIDS) {
8147         SVOP *kid = (SVOP*)cUNOPo->op_first;
8148
8149         if (kid->op_type == OP_NULL)
8150             kid = (SVOP*)kid->op_sibling;
8151         if (kid && kid->op_type == OP_CONST &&
8152             (kid->op_private & OPpCONST_BARE))
8153         {
8154             o->op_flags |= OPf_SPECIAL;
8155             kid->op_private &= ~OPpCONST_STRICT;
8156         }
8157     }
8158     return ck_fun(o);
8159 }
8160
8161 OP *
8162 Perl_ck_unpack(pTHX_ OP *o)
8163 {
8164     OP *kid = cLISTOPo->op_first;
8165
8166     PERL_ARGS_ASSERT_CK_UNPACK;
8167
8168     if (kid->op_sibling) {
8169         kid = kid->op_sibling;
8170         if (!kid->op_sibling)
8171             kid->op_sibling = newDEFSVOP();
8172     }
8173     return ck_fun(o);
8174 }
8175
8176 OP *
8177 Perl_ck_substr(pTHX_ OP *o)
8178 {
8179     PERL_ARGS_ASSERT_CK_SUBSTR;
8180
8181     o = ck_fun(o);
8182     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8183         OP *kid = cLISTOPo->op_first;
8184
8185         if (kid->op_type == OP_NULL)
8186             kid = kid->op_sibling;
8187         if (kid)
8188             kid->op_flags |= OPf_MOD;
8189
8190     }
8191     return o;
8192 }
8193
8194 OP *
8195 Perl_ck_each(pTHX_ OP *o)
8196 {
8197     dVAR;
8198     OP *kid = cLISTOPo->op_first;
8199
8200     PERL_ARGS_ASSERT_CK_EACH;
8201
8202     if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8203         const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8204             : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8205         o->op_type = new_type;
8206         o->op_ppaddr = PL_ppaddr[new_type];
8207     }
8208     else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8209                || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8210                )) {
8211         bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8212         return o;
8213     }
8214     return ck_fun(o);
8215 }
8216
8217 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8218  * See the comments at the top of this file for more details about when
8219  * peep() is called */
8220
8221 void
8222 Perl_peep(pTHX_ register OP *o)
8223 {
8224     dVAR;
8225     register OP* oldop = NULL;
8226
8227     if (!o || o->op_opt)
8228         return;
8229     ENTER;
8230     SAVEOP();
8231     SAVEVPTR(PL_curcop);
8232     for (; o; o = o->op_next) {
8233         if (o->op_opt)
8234             break;
8235         /* By default, this op has now been optimised. A couple of cases below
8236            clear this again.  */
8237         o->op_opt = 1;
8238         PL_op = o;
8239         switch (o->op_type) {
8240         case OP_NEXTSTATE:
8241         case OP_DBSTATE:
8242             PL_curcop = ((COP*)o);              /* for warnings */
8243             break;
8244
8245         case OP_CONST:
8246             if (cSVOPo->op_private & OPpCONST_STRICT)
8247                 no_bareword_allowed(o);
8248 #ifdef USE_ITHREADS
8249         case OP_HINTSEVAL:
8250         case OP_METHOD_NAMED:
8251             /* Relocate sv to the pad for thread safety.
8252              * Despite being a "constant", the SV is written to,
8253              * for reference counts, sv_upgrade() etc. */
8254             if (cSVOP->op_sv) {
8255                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8256                 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8257                     /* If op_sv is already a PADTMP then it is being used by
8258                      * some pad, so make a copy. */
8259                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8260                     SvREADONLY_on(PAD_SVl(ix));
8261                     SvREFCNT_dec(cSVOPo->op_sv);
8262                 }
8263                 else if (o->op_type != OP_METHOD_NAMED
8264                          && cSVOPo->op_sv == &PL_sv_undef) {
8265                     /* PL_sv_undef is hack - it's unsafe to store it in the
8266                        AV that is the pad, because av_fetch treats values of
8267                        PL_sv_undef as a "free" AV entry and will merrily
8268                        replace them with a new SV, causing pad_alloc to think
8269                        that this pad slot is free. (When, clearly, it is not)
8270                     */
8271                     SvOK_off(PAD_SVl(ix));
8272                     SvPADTMP_on(PAD_SVl(ix));
8273                     SvREADONLY_on(PAD_SVl(ix));
8274                 }
8275                 else {
8276                     SvREFCNT_dec(PAD_SVl(ix));
8277                     SvPADTMP_on(cSVOPo->op_sv);
8278                     PAD_SETSV(ix, cSVOPo->op_sv);
8279                     /* XXX I don't know how this isn't readonly already. */
8280                     SvREADONLY_on(PAD_SVl(ix));
8281                 }
8282                 cSVOPo->op_sv = NULL;
8283                 o->op_targ = ix;
8284             }
8285 #endif
8286             break;
8287
8288         case OP_CONCAT:
8289             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8290                 if (o->op_next->op_private & OPpTARGET_MY) {
8291                     if (o->op_flags & OPf_STACKED) /* chained concats */
8292                         break; /* ignore_optimization */
8293                     else {
8294                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8295                         o->op_targ = o->op_next->op_targ;
8296                         o->op_next->op_targ = 0;
8297                         o->op_private |= OPpTARGET_MY;
8298                     }
8299                 }
8300                 op_null(o->op_next);
8301             }
8302             break;
8303         case OP_STUB:
8304             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8305                 break; /* Scalar stub must produce undef.  List stub is noop */
8306             }
8307             goto nothin;
8308         case OP_NULL:
8309             if (o->op_targ == OP_NEXTSTATE
8310                 || o->op_targ == OP_DBSTATE)
8311             {
8312                 PL_curcop = ((COP*)o);
8313             }
8314             /* XXX: We avoid setting op_seq here to prevent later calls
8315                to peep() from mistakenly concluding that optimisation
8316                has already occurred. This doesn't fix the real problem,
8317                though (See 20010220.007). AMS 20010719 */
8318             /* op_seq functionality is now replaced by op_opt */
8319             o->op_opt = 0;
8320             /* FALL THROUGH */
8321         case OP_SCALAR:
8322         case OP_LINESEQ:
8323         case OP_SCOPE:
8324         nothin:
8325             if (oldop && o->op_next) {
8326                 oldop->op_next = o->op_next;
8327                 o->op_opt = 0;
8328                 continue;
8329             }
8330             break;
8331
8332         case OP_PADAV:
8333         case OP_GV:
8334             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8335                 OP* const pop = (o->op_type == OP_PADAV) ?
8336                             o->op_next : o->op_next->op_next;
8337                 IV i;
8338                 if (pop && pop->op_type == OP_CONST &&
8339                     ((PL_op = pop->op_next)) &&
8340                     pop->op_next->op_type == OP_AELEM &&
8341                     !(pop->op_next->op_private &
8342                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8343                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8344                                 <= 255 &&
8345                     i >= 0)
8346                 {
8347                     GV *gv;
8348                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8349                         no_bareword_allowed(pop);
8350                     if (o->op_type == OP_GV)
8351                         op_null(o->op_next);
8352                     op_null(pop->op_next);
8353                     op_null(pop);
8354                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8355                     o->op_next = pop->op_next->op_next;
8356                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8357                     o->op_private = (U8)i;
8358                     if (o->op_type == OP_GV) {
8359                         gv = cGVOPo_gv;
8360                         GvAVn(gv);
8361                     }
8362                     else
8363                         o->op_flags |= OPf_SPECIAL;
8364                     o->op_type = OP_AELEMFAST;
8365                 }
8366                 break;
8367             }
8368
8369             if (o->op_next->op_type == OP_RV2SV) {
8370                 if (!(o->op_next->op_private & OPpDEREF)) {
8371                     op_null(o->op_next);
8372                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8373                                                                | OPpOUR_INTRO);
8374                     o->op_next = o->op_next->op_next;
8375                     o->op_type = OP_GVSV;
8376                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8377                 }
8378             }
8379             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8380                 GV * const gv = cGVOPo_gv;
8381                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8382                     /* XXX could check prototype here instead of just carping */
8383                     SV * const sv = sv_newmortal();
8384                     gv_efullname3(sv, gv, NULL);
8385                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8386                                 "%"SVf"() called too early to check prototype",
8387                                 SVfARG(sv));
8388                 }
8389             }
8390             else if (o->op_next->op_type == OP_READLINE
8391                     && o->op_next->op_next->op_type == OP_CONCAT
8392                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8393             {
8394                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8395                 o->op_type   = OP_RCATLINE;
8396                 o->op_flags |= OPf_STACKED;
8397                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8398                 op_null(o->op_next->op_next);
8399                 op_null(o->op_next);
8400             }
8401
8402             break;
8403
8404         case OP_MAPWHILE:
8405         case OP_GREPWHILE:
8406         case OP_AND:
8407         case OP_OR:
8408         case OP_DOR:
8409         case OP_ANDASSIGN:
8410         case OP_ORASSIGN:
8411         case OP_DORASSIGN:
8412         case OP_COND_EXPR:
8413         case OP_RANGE:
8414         case OP_ONCE:
8415             while (cLOGOP->op_other->op_type == OP_NULL)
8416                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8417             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8418             break;
8419
8420         case OP_ENTERLOOP:
8421         case OP_ENTERITER:
8422             while (cLOOP->op_redoop->op_type == OP_NULL)
8423                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8424             peep(cLOOP->op_redoop);
8425             while (cLOOP->op_nextop->op_type == OP_NULL)
8426                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8427             peep(cLOOP->op_nextop);
8428             while (cLOOP->op_lastop->op_type == OP_NULL)
8429                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8430             peep(cLOOP->op_lastop);
8431             break;
8432
8433         case OP_SUBST:
8434             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8435             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8436                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8437                 cPMOP->op_pmstashstartu.op_pmreplstart
8438                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8439             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8440             break;
8441
8442         case OP_EXEC:
8443             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8444                 && ckWARN(WARN_SYNTAX))
8445             {
8446                 if (o->op_next->op_sibling) {
8447                     const OPCODE type = o->op_next->op_sibling->op_type;
8448                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8449                         const line_t oldline = CopLINE(PL_curcop);
8450                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8451                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8452                                     "Statement unlikely to be reached");
8453                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8454                                     "\t(Maybe you meant system() when you said exec()?)\n");
8455                         CopLINE_set(PL_curcop, oldline);
8456                     }
8457                 }
8458             }
8459             break;
8460
8461         case OP_HELEM: {
8462             UNOP *rop;
8463             SV *lexname;
8464             GV **fields;
8465             SV **svp, *sv;
8466             const char *key = NULL;
8467             STRLEN keylen;
8468
8469             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8470                 break;
8471
8472             /* Make the CONST have a shared SV */
8473             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8474             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8475                 key = SvPV_const(sv, keylen);
8476                 lexname = newSVpvn_share(key,
8477                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8478                                          0);
8479                 SvREFCNT_dec(sv);
8480                 *svp = lexname;
8481             }
8482
8483             if ((o->op_private & (OPpLVAL_INTRO)))
8484                 break;
8485
8486             rop = (UNOP*)((BINOP*)o)->op_first;
8487             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8488                 break;
8489             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8490             if (!SvPAD_TYPED(lexname))
8491                 break;
8492             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8493             if (!fields || !GvHV(*fields))
8494                 break;
8495             key = SvPV_const(*svp, keylen);
8496             if (!hv_fetch(GvHV(*fields), key,
8497                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8498             {
8499                 Perl_croak(aTHX_ "No such class field \"%s\" "
8500                            "in variable %s of type %s",
8501                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8502             }
8503
8504             break;
8505         }
8506
8507         case OP_HSLICE: {
8508             UNOP *rop;
8509             SV *lexname;
8510             GV **fields;
8511             SV **svp;
8512             const char *key;
8513             STRLEN keylen;
8514             SVOP *first_key_op, *key_op;
8515
8516             if ((o->op_private & (OPpLVAL_INTRO))
8517                 /* I bet there's always a pushmark... */
8518                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8519                 /* hmmm, no optimization if list contains only one key. */
8520                 break;
8521             rop = (UNOP*)((LISTOP*)o)->op_last;
8522             if (rop->op_type != OP_RV2HV)
8523                 break;
8524             if (rop->op_first->op_type == OP_PADSV)
8525                 /* @$hash{qw(keys here)} */
8526                 rop = (UNOP*)rop->op_first;
8527             else {
8528                 /* @{$hash}{qw(keys here)} */
8529                 if (rop->op_first->op_type == OP_SCOPE
8530                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8531                 {
8532                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8533                 }
8534                 else
8535                     break;
8536             }
8537
8538             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8539             if (!SvPAD_TYPED(lexname))
8540                 break;
8541             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8542             if (!fields || !GvHV(*fields))
8543                 break;
8544             /* Again guessing that the pushmark can be jumped over.... */
8545             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8546                 ->op_first->op_sibling;
8547             for (key_op = first_key_op; key_op;
8548                  key_op = (SVOP*)key_op->op_sibling) {
8549                 if (key_op->op_type != OP_CONST)
8550                     continue;
8551                 svp = cSVOPx_svp(key_op);
8552                 key = SvPV_const(*svp, keylen);
8553                 if (!hv_fetch(GvHV(*fields), key,
8554                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8555                 {
8556                     Perl_croak(aTHX_ "No such class field \"%s\" "
8557                                "in variable %s of type %s",
8558                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8559                 }
8560             }
8561             break;
8562         }
8563
8564         case OP_SORT: {
8565             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8566             OP *oleft;
8567             OP *o2;
8568
8569             /* check that RHS of sort is a single plain array */
8570             OP *oright = cUNOPo->op_first;
8571             if (!oright || oright->op_type != OP_PUSHMARK)
8572                 break;
8573
8574             /* reverse sort ... can be optimised.  */
8575             if (!cUNOPo->op_sibling) {
8576                 /* Nothing follows us on the list. */
8577                 OP * const reverse = o->op_next;
8578
8579                 if (reverse->op_type == OP_REVERSE &&
8580                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8581                     OP * const pushmark = cUNOPx(reverse)->op_first;
8582                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8583                         && (cUNOPx(pushmark)->op_sibling == o)) {
8584                         /* reverse -> pushmark -> sort */
8585                         o->op_private |= OPpSORT_REVERSE;
8586                         op_null(reverse);
8587                         pushmark->op_next = oright->op_next;
8588                         op_null(oright);
8589                     }
8590                 }
8591             }
8592
8593             /* make @a = sort @a act in-place */
8594
8595             oright = cUNOPx(oright)->op_sibling;
8596             if (!oright)
8597                 break;
8598             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8599                 oright = cUNOPx(oright)->op_sibling;
8600             }
8601
8602             if (!oright ||
8603                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8604                 || oright->op_next != o
8605                 || (oright->op_private & OPpLVAL_INTRO)
8606             )
8607                 break;
8608
8609             /* o2 follows the chain of op_nexts through the LHS of the
8610              * assign (if any) to the aassign op itself */
8611             o2 = o->op_next;
8612             if (!o2 || o2->op_type != OP_NULL)
8613                 break;
8614             o2 = o2->op_next;
8615             if (!o2 || o2->op_type != OP_PUSHMARK)
8616                 break;
8617             o2 = o2->op_next;
8618             if (o2 && o2->op_type == OP_GV)
8619                 o2 = o2->op_next;
8620             if (!o2
8621                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8622                 || (o2->op_private & OPpLVAL_INTRO)
8623             )
8624                 break;
8625             oleft = o2;
8626             o2 = o2->op_next;
8627             if (!o2 || o2->op_type != OP_NULL)
8628                 break;
8629             o2 = o2->op_next;
8630             if (!o2 || o2->op_type != OP_AASSIGN
8631                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8632                 break;
8633
8634             /* check that the sort is the first arg on RHS of assign */
8635
8636             o2 = cUNOPx(o2)->op_first;
8637             if (!o2 || o2->op_type != OP_NULL)
8638                 break;
8639             o2 = cUNOPx(o2)->op_first;
8640             if (!o2 || o2->op_type != OP_PUSHMARK)
8641                 break;
8642             if (o2->op_sibling != o)
8643                 break;
8644
8645             /* check the array is the same on both sides */
8646             if (oleft->op_type == OP_RV2AV) {
8647                 if (oright->op_type != OP_RV2AV
8648                     || !cUNOPx(oright)->op_first
8649                     || cUNOPx(oright)->op_first->op_type != OP_GV
8650                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8651                         cGVOPx_gv(cUNOPx(oright)->op_first)
8652                 )
8653                     break;
8654             }
8655             else if (oright->op_type != OP_PADAV
8656                 || oright->op_targ != oleft->op_targ
8657             )
8658                 break;
8659
8660             /* transfer MODishness etc from LHS arg to RHS arg */
8661             oright->op_flags = oleft->op_flags;
8662             o->op_private |= OPpSORT_INPLACE;
8663
8664             /* excise push->gv->rv2av->null->aassign */
8665             o2 = o->op_next->op_next;
8666             op_null(o2); /* PUSHMARK */
8667             o2 = o2->op_next;
8668             if (o2->op_type == OP_GV) {
8669                 op_null(o2); /* GV */
8670                 o2 = o2->op_next;
8671             }
8672             op_null(o2); /* RV2AV or PADAV */
8673             o2 = o2->op_next->op_next;
8674             op_null(o2); /* AASSIGN */
8675
8676             o->op_next = o2->op_next;
8677
8678             break;
8679         }
8680
8681         case OP_REVERSE: {
8682             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8683             OP *gvop = NULL;
8684             LISTOP *enter, *exlist;
8685
8686             enter = (LISTOP *) o->op_next;
8687             if (!enter)
8688                 break;
8689             if (enter->op_type == OP_NULL) {
8690                 enter = (LISTOP *) enter->op_next;
8691                 if (!enter)
8692                     break;
8693             }
8694             /* for $a (...) will have OP_GV then OP_RV2GV here.
8695                for (...) just has an OP_GV.  */
8696             if (enter->op_type == OP_GV) {
8697                 gvop = (OP *) enter;
8698                 enter = (LISTOP *) enter->op_next;
8699                 if (!enter)
8700                     break;
8701                 if (enter->op_type == OP_RV2GV) {
8702                   enter = (LISTOP *) enter->op_next;
8703                   if (!enter)
8704                     break;
8705                 }
8706             }
8707
8708             if (enter->op_type != OP_ENTERITER)
8709                 break;
8710
8711             iter = enter->op_next;
8712             if (!iter || iter->op_type != OP_ITER)
8713                 break;
8714
8715             expushmark = enter->op_first;
8716             if (!expushmark || expushmark->op_type != OP_NULL
8717                 || expushmark->op_targ != OP_PUSHMARK)
8718                 break;
8719
8720             exlist = (LISTOP *) expushmark->op_sibling;
8721             if (!exlist || exlist->op_type != OP_NULL
8722                 || exlist->op_targ != OP_LIST)
8723                 break;
8724
8725             if (exlist->op_last != o) {
8726                 /* Mmm. Was expecting to point back to this op.  */
8727                 break;
8728             }
8729             theirmark = exlist->op_first;
8730             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8731                 break;
8732
8733             if (theirmark->op_sibling != o) {
8734                 /* There's something between the mark and the reverse, eg
8735                    for (1, reverse (...))
8736                    so no go.  */
8737                 break;
8738             }
8739
8740             ourmark = ((LISTOP *)o)->op_first;
8741             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8742                 break;
8743
8744             ourlast = ((LISTOP *)o)->op_last;
8745             if (!ourlast || ourlast->op_next != o)
8746                 break;
8747
8748             rv2av = ourmark->op_sibling;
8749             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8750                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8751                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8752                 /* We're just reversing a single array.  */
8753                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8754                 enter->op_flags |= OPf_STACKED;
8755             }
8756
8757             /* We don't have control over who points to theirmark, so sacrifice
8758                ours.  */
8759             theirmark->op_next = ourmark->op_next;
8760             theirmark->op_flags = ourmark->op_flags;
8761             ourlast->op_next = gvop ? gvop : (OP *) enter;
8762             op_null(ourmark);
8763             op_null(o);
8764             enter->op_private |= OPpITER_REVERSED;
8765             iter->op_private |= OPpITER_REVERSED;
8766
8767             break;
8768         }
8769
8770         case OP_SASSIGN: {
8771             OP *rv2gv;
8772             UNOP *refgen, *rv2cv;
8773             LISTOP *exlist;
8774
8775             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8776                 break;
8777
8778             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8779                 break;
8780
8781             rv2gv = ((BINOP *)o)->op_last;
8782             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8783                 break;
8784
8785             refgen = (UNOP *)((BINOP *)o)->op_first;
8786
8787             if (!refgen || refgen->op_type != OP_REFGEN)
8788                 break;
8789
8790             exlist = (LISTOP *)refgen->op_first;
8791             if (!exlist || exlist->op_type != OP_NULL
8792                 || exlist->op_targ != OP_LIST)
8793                 break;
8794
8795             if (exlist->op_first->op_type != OP_PUSHMARK)
8796                 break;
8797
8798             rv2cv = (UNOP*)exlist->op_last;
8799
8800             if (rv2cv->op_type != OP_RV2CV)
8801                 break;
8802
8803             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8804             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8805             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8806
8807             o->op_private |= OPpASSIGN_CV_TO_GV;
8808             rv2gv->op_private |= OPpDONT_INIT_GV;
8809             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8810
8811             break;
8812         }
8813
8814
8815         case OP_QR:
8816         case OP_MATCH:
8817             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8818                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8819             }
8820             break;
8821         }
8822         oldop = o;
8823     }
8824     LEAVE;
8825 }
8826
8827 const char*
8828 Perl_custom_op_name(pTHX_ const OP* o)
8829 {
8830     dVAR;
8831     const IV index = PTR2IV(o->op_ppaddr);
8832     SV* keysv;
8833     HE* he;
8834
8835     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8836
8837     if (!PL_custom_op_names) /* This probably shouldn't happen */
8838         return (char *)PL_op_name[OP_CUSTOM];
8839
8840     keysv = sv_2mortal(newSViv(index));
8841
8842     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8843     if (!he)
8844         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8845
8846     return SvPV_nolen(HeVAL(he));
8847 }
8848
8849 const char*
8850 Perl_custom_op_desc(pTHX_ const OP* o)
8851 {
8852     dVAR;
8853     const IV index = PTR2IV(o->op_ppaddr);
8854     SV* keysv;
8855     HE* he;
8856
8857     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8858
8859     if (!PL_custom_op_descs)
8860         return (char *)PL_op_desc[OP_CUSTOM];
8861
8862     keysv = sv_2mortal(newSViv(index));
8863
8864     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8865     if (!he)
8866         return (char *)PL_op_desc[OP_CUSTOM];
8867
8868     return SvPV_nolen(HeVAL(he));
8869 }
8870
8871 #include "XSUB.h"
8872
8873 /* Efficient sub that returns a constant scalar value. */
8874 static void
8875 const_sv_xsub(pTHX_ CV* cv)
8876 {
8877     dVAR;
8878     dXSARGS;
8879     if (items != 0) {
8880         NOOP;
8881 #if 0
8882         Perl_croak(aTHX_ "usage: %s::%s()",
8883                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8884 #endif
8885     }
8886     EXTEND(sp, 1);
8887     ST(0) = (SV*)XSANY.any_ptr;
8888     XSRETURN(1);
8889 }
8890
8891 /*
8892  * Local variables:
8893  * c-indentation-style: bsd
8894  * c-basic-offset: 4
8895  * indent-tabs-mode: t
8896  * End:
8897  *
8898  * ex: set ts=8 sts=4 sw=4 noet:
8899  */