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