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