op.c

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