op.c

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