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