op.c

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