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