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 *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             assert (SvUTF8(pat));
3443         } else if (SvUTF8(pat)) {
3444             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3445                trapped in use 'bytes'?  */
3446             /* Make a copy of the octet sequence, but without the flag on, as
3447                the compiler now honours the SvUTF8 flag on pat.  */
3448             STRLEN len;
3449             const char *const p = SvPV(pat, len);
3450             pat = newSVpvn_flags(p, len, SVs_TEMP);
3451         }
3452         assert(!(pm_flags & RXf_UTF8));
3453
3454         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3455
3456 #ifdef PERL_MAD
3457         op_getmad(expr,(OP*)pm,'e');
3458 #else
3459         op_free(expr);
3460 #endif
3461     }
3462     else {
3463         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3464             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3465                             ? OP_REGCRESET
3466                             : OP_REGCMAYBE),0,expr);
3467
3468         NewOp(1101, rcop, 1, LOGOP);
3469         rcop->op_type = OP_REGCOMP;
3470         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3471         rcop->op_first = scalar(expr);
3472         rcop->op_flags |= OPf_KIDS
3473                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3474                             | (reglist ? OPf_STACKED : 0);
3475         rcop->op_private = 1;
3476         rcop->op_other = o;
3477         if (reglist)
3478             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3479
3480         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3481         PL_cv_has_eval = 1;
3482
3483         /* establish postfix order */
3484         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3485             LINKLIST(expr);
3486             rcop->op_next = expr;
3487             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3488         }
3489         else {
3490             rcop->op_next = LINKLIST(expr);
3491             expr->op_next = (OP*)rcop;
3492         }
3493
3494         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3495     }
3496
3497     if (repl) {
3498         OP *curop;
3499         if (pm->op_pmflags & PMf_EVAL) {
3500             curop = NULL;
3501             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3502                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3503         }
3504         else if (repl->op_type == OP_CONST)
3505             curop = repl;
3506         else {
3507             OP *lastop = NULL;
3508             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3509                 if (curop->op_type == OP_SCOPE
3510                         || curop->op_type == OP_LEAVE
3511                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3512                     if (curop->op_type == OP_GV) {
3513                         GV * const gv = cGVOPx_gv(curop);
3514                         repl_has_vars = 1;
3515                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3516                             break;
3517                     }
3518                     else if (curop->op_type == OP_RV2CV)
3519                         break;
3520                     else if (curop->op_type == OP_RV2SV ||
3521                              curop->op_type == OP_RV2AV ||
3522                              curop->op_type == OP_RV2HV ||
3523                              curop->op_type == OP_RV2GV) {
3524                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3525                             break;
3526                     }
3527                     else if (curop->op_type == OP_PADSV ||
3528                              curop->op_type == OP_PADAV ||
3529                              curop->op_type == OP_PADHV ||
3530                              curop->op_type == OP_PADANY)
3531                     {
3532                         repl_has_vars = 1;
3533                     }
3534                     else if (curop->op_type == OP_PUSHRE)
3535                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3536                     else
3537                         break;
3538                 }
3539                 lastop = curop;
3540             }
3541         }
3542         if (curop == repl
3543             && !(repl_has_vars
3544                  && (!PM_GETRE(pm)
3545                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3546         {
3547             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3548             prepend_elem(o->op_type, scalar(repl), o);
3549         }
3550         else {
3551             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3552                 pm->op_pmflags |= PMf_MAYBE_CONST;
3553             }
3554             NewOp(1101, rcop, 1, LOGOP);
3555             rcop->op_type = OP_SUBSTCONT;
3556             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3557             rcop->op_first = scalar(repl);
3558             rcop->op_flags |= OPf_KIDS;
3559             rcop->op_private = 1;
3560             rcop->op_other = o;
3561
3562             /* establish postfix order */
3563             rcop->op_next = LINKLIST(repl);
3564             repl->op_next = (OP*)rcop;
3565
3566             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3567             assert(!(pm->op_pmflags & PMf_ONCE));
3568             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3569             rcop->op_next = 0;
3570         }
3571     }
3572
3573     return (OP*)pm;
3574 }
3575
3576 OP *
3577 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3578 {
3579     dVAR;
3580     SVOP *svop;
3581     NewOp(1101, svop, 1, SVOP);
3582     svop->op_type = (OPCODE)type;
3583     svop->op_ppaddr = PL_ppaddr[type];
3584     svop->op_sv = sv;
3585     svop->op_next = (OP*)svop;
3586     svop->op_flags = (U8)flags;
3587     if (PL_opargs[type] & OA_RETSCALAR)
3588         scalar((OP*)svop);
3589     if (PL_opargs[type] & OA_TARGET)
3590         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3591     return CHECKOP(type, svop);
3592 }
3593
3594 #ifdef USE_ITHREADS
3595 OP *
3596 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3597 {
3598     dVAR;
3599     PADOP *padop;
3600     NewOp(1101, padop, 1, PADOP);
3601     padop->op_type = (OPCODE)type;
3602     padop->op_ppaddr = PL_ppaddr[type];
3603     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3604     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3605     PAD_SETSV(padop->op_padix, sv);
3606     assert(sv);
3607     SvPADTMP_on(sv);
3608     padop->op_next = (OP*)padop;
3609     padop->op_flags = (U8)flags;
3610     if (PL_opargs[type] & OA_RETSCALAR)
3611         scalar((OP*)padop);
3612     if (PL_opargs[type] & OA_TARGET)
3613         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3614     return CHECKOP(type, padop);
3615 }
3616 #endif
3617
3618 OP *
3619 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3620 {
3621     dVAR;
3622     assert(gv);
3623 #ifdef USE_ITHREADS
3624     GvIN_PAD_on(gv);
3625     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3626 #else
3627     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3628 #endif
3629 }
3630
3631 OP *
3632 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3633 {
3634     dVAR;
3635     PVOP *pvop;
3636     NewOp(1101, pvop, 1, PVOP);
3637     pvop->op_type = (OPCODE)type;
3638     pvop->op_ppaddr = PL_ppaddr[type];
3639     pvop->op_pv = pv;
3640     pvop->op_next = (OP*)pvop;
3641     pvop->op_flags = (U8)flags;
3642     if (PL_opargs[type] & OA_RETSCALAR)
3643         scalar((OP*)pvop);
3644     if (PL_opargs[type] & OA_TARGET)
3645         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3646     return CHECKOP(type, pvop);
3647 }
3648
3649 #ifdef PERL_MAD
3650 OP*
3651 #else
3652 void
3653 #endif
3654 Perl_package(pTHX_ OP *o)
3655 {
3656     dVAR;
3657     SV *const sv = cSVOPo->op_sv;
3658 #ifdef PERL_MAD
3659     OP *pegop;
3660 #endif
3661
3662     save_hptr(&PL_curstash);
3663     save_item(PL_curstname);
3664
3665     PL_curstash = gv_stashsv(sv, GV_ADD);
3666
3667     sv_setsv(PL_curstname, sv);
3668
3669     PL_hints |= HINT_BLOCK_SCOPE;
3670     PL_parser->copline = NOLINE;
3671     PL_parser->expect = XSTATE;
3672
3673 #ifndef PERL_MAD
3674     op_free(o);
3675 #else
3676     if (!PL_madskills) {
3677         op_free(o);
3678         return NULL;
3679     }
3680
3681     pegop = newOP(OP_NULL,0);
3682     op_getmad(o,pegop,'P');
3683     return pegop;
3684 #endif
3685 }
3686
3687 #ifdef PERL_MAD
3688 OP*
3689 #else
3690 void
3691 #endif
3692 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3693 {
3694     dVAR;
3695     OP *pack;
3696     OP *imop;
3697     OP *veop;
3698 #ifdef PERL_MAD
3699     OP *pegop = newOP(OP_NULL,0);
3700 #endif
3701
3702     if (idop->op_type != OP_CONST)
3703         Perl_croak(aTHX_ "Module name must be constant");
3704
3705     if (PL_madskills)
3706         op_getmad(idop,pegop,'U');
3707
3708     veop = NULL;
3709
3710     if (version) {
3711         SV * const vesv = ((SVOP*)version)->op_sv;
3712
3713         if (PL_madskills)
3714             op_getmad(version,pegop,'V');
3715         if (!arg && !SvNIOKp(vesv)) {
3716             arg = version;
3717         }
3718         else {
3719             OP *pack;
3720             SV *meth;
3721
3722             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3723                 Perl_croak(aTHX_ "Version number must be constant number");
3724
3725             /* Make copy of idop so we don't free it twice */
3726             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3727
3728             /* Fake up a method call to VERSION */
3729             meth = newSVpvs_share("VERSION");
3730             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3731                             append_elem(OP_LIST,
3732                                         prepend_elem(OP_LIST, pack, list(version)),
3733                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3734         }
3735     }
3736
3737     /* Fake up an import/unimport */
3738     if (arg && arg->op_type == OP_STUB) {
3739         if (PL_madskills)
3740             op_getmad(arg,pegop,'S');
3741         imop = arg;             /* no import on explicit () */
3742     }
3743     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3744         imop = NULL;            /* use 5.0; */
3745         if (!aver)
3746             idop->op_private |= OPpCONST_NOVER;
3747     }
3748     else {
3749         SV *meth;
3750
3751         if (PL_madskills)
3752             op_getmad(arg,pegop,'A');
3753
3754         /* Make copy of idop so we don't free it twice */
3755         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3756
3757         /* Fake up a method call to import/unimport */
3758         meth = aver
3759             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3760         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3761                        append_elem(OP_LIST,
3762                                    prepend_elem(OP_LIST, pack, list(arg)),
3763                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3764     }
3765
3766     /* Fake up the BEGIN {}, which does its thing immediately. */
3767     newATTRSUB(floor,
3768         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3769         NULL,
3770         NULL,
3771         append_elem(OP_LINESEQ,
3772             append_elem(OP_LINESEQ,
3773                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3774                 newSTATEOP(0, NULL, veop)),
3775             newSTATEOP(0, NULL, imop) ));
3776
3777     /* The "did you use incorrect case?" warning used to be here.
3778      * The problem is that on case-insensitive filesystems one
3779      * might get false positives for "use" (and "require"):
3780      * "use Strict" or "require CARP" will work.  This causes
3781      * portability problems for the script: in case-strict
3782      * filesystems the script will stop working.
3783      *
3784      * The "incorrect case" warning checked whether "use Foo"
3785      * imported "Foo" to your namespace, but that is wrong, too:
3786      * there is no requirement nor promise in the language that
3787      * a Foo.pm should or would contain anything in package "Foo".
3788      *
3789      * There is very little Configure-wise that can be done, either:
3790      * the case-sensitivity of the build filesystem of Perl does not
3791      * help in guessing the case-sensitivity of the runtime environment.
3792      */
3793
3794     PL_hints |= HINT_BLOCK_SCOPE;
3795     PL_parser->copline = NOLINE;
3796     PL_parser->expect = XSTATE;
3797     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3798
3799 #ifdef PERL_MAD
3800     if (!PL_madskills) {
3801         /* FIXME - don't allocate pegop if !PL_madskills */
3802         op_free(pegop);
3803         return NULL;
3804     }
3805     return pegop;
3806 #endif
3807 }
3808
3809 /*
3810 =head1 Embedding Functions
3811
3812 =for apidoc load_module
3813
3814 Loads the module whose name is pointed to by the string part of name.
3815 Note that the actual module name, not its filename, should be given.
3816 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3817 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3818 (or 0 for no flags). ver, if specified, provides version semantics
3819 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3820 arguments can be used to specify arguments to the module's import()
3821 method, similar to C<use Foo::Bar VERSION LIST>.
3822
3823 =cut */
3824
3825 void
3826 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3827 {
3828     va_list args;
3829     va_start(args, ver);
3830     vload_module(flags, name, ver, &args);
3831     va_end(args);
3832 }
3833
3834 #ifdef PERL_IMPLICIT_CONTEXT
3835 void
3836 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3837 {
3838     dTHX;
3839     va_list args;
3840     va_start(args, ver);
3841     vload_module(flags, name, ver, &args);
3842     va_end(args);
3843 }
3844 #endif
3845
3846 void
3847 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3848 {
3849     dVAR;
3850     OP *veop, *imop;
3851
3852     OP * const modname = newSVOP(OP_CONST, 0, name);
3853     modname->op_private |= OPpCONST_BARE;
3854     if (ver) {
3855         veop = newSVOP(OP_CONST, 0, ver);
3856     }
3857     else
3858         veop = NULL;
3859     if (flags & PERL_LOADMOD_NOIMPORT) {
3860         imop = sawparens(newNULLLIST());
3861     }
3862     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3863         imop = va_arg(*args, OP*);
3864     }
3865     else {
3866         SV *sv;
3867         imop = NULL;
3868         sv = va_arg(*args, SV*);
3869         while (sv) {
3870             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3871             sv = va_arg(*args, SV*);
3872         }
3873     }
3874
3875     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3876      * that it has a PL_parser to play with while doing that, and also
3877      * that it doesn't mess with any existing parser, by creating a tmp
3878      * new parser with lex_start(). This won't actually be used for much,
3879      * since pp_require() will create another parser for the real work. */
3880
3881     ENTER;
3882     SAVEVPTR(PL_curcop);
3883     lex_start(NULL, NULL, FALSE);
3884     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3885             veop, modname, imop);
3886     LEAVE;
3887 }
3888
3889 OP *
3890 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3891 {
3892     dVAR;
3893     OP *doop;
3894     GV *gv = NULL;
3895
3896     if (!force_builtin) {
3897         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3898         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3899             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3900             gv = gvp ? *gvp : NULL;
3901         }
3902     }
3903
3904     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3905         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3906                                append_elem(OP_LIST, term,
3907                                            scalar(newUNOP(OP_RV2CV, 0,
3908                                                           newGVOP(OP_GV, 0, gv))))));
3909     }
3910     else {
3911         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3912     }
3913     return doop;
3914 }
3915
3916 OP *
3917 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3918 {
3919     return newBINOP(OP_LSLICE, flags,
3920             list(force_list(subscript)),
3921             list(force_list(listval)) );
3922 }
3923
3924 STATIC I32
3925 S_is_list_assignment(pTHX_ register const OP *o)
3926 {
3927     unsigned type;
3928     U8 flags;
3929
3930     if (!o)
3931         return TRUE;
3932
3933     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3934         o = cUNOPo->op_first;
3935
3936     flags = o->op_flags;
3937     type = o->op_type;
3938     if (type == OP_COND_EXPR) {
3939         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3940         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3941
3942         if (t && f)
3943             return TRUE;
3944         if (t || f)
3945             yyerror("Assignment to both a list and a scalar");
3946         return FALSE;
3947     }
3948
3949     if (type == OP_LIST &&
3950         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3951         o->op_private & OPpLVAL_INTRO)
3952         return FALSE;
3953
3954     if (type == OP_LIST || flags & OPf_PARENS ||
3955         type == OP_RV2AV || type == OP_RV2HV ||
3956         type == OP_ASLICE || type == OP_HSLICE)
3957         return TRUE;
3958
3959     if (type == OP_PADAV || type == OP_PADHV)
3960         return TRUE;
3961
3962     if (type == OP_RV2SV)
3963         return FALSE;
3964
3965     return FALSE;
3966 }
3967
3968 OP *
3969 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3970 {
3971     dVAR;
3972     OP *o;
3973
3974     if (optype) {
3975         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3976             return newLOGOP(optype, 0,
3977                 mod(scalar(left), optype),
3978                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3979         }
3980         else {
3981             return newBINOP(optype, OPf_STACKED,
3982                 mod(scalar(left), optype), scalar(right));
3983         }
3984     }
3985
3986     if (is_list_assignment(left)) {
3987         static const char no_list_state[] = "Initialization of state variables"
3988             " in list context currently forbidden";
3989         OP *curop;
3990
3991         PL_modcount = 0;
3992         /* Grandfathering $[ assignment here.  Bletch.*/
3993         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3994         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
3995         left = mod(left, OP_AASSIGN);
3996         if (PL_eval_start)
3997             PL_eval_start = 0;
3998         else if (left->op_type == OP_CONST) {
3999             /* FIXME for MAD */
4000             /* Result of assignment is always 1 (or we'd be dead already) */
4001             return newSVOP(OP_CONST, 0, newSViv(1));
4002         }
4003         curop = list(force_list(left));
4004         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4005         o->op_private = (U8)(0 | (flags >> 8));
4006
4007         /* PL_generation sorcery:
4008          * an assignment like ($a,$b) = ($c,$d) is easier than
4009          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4010          * To detect whether there are common vars, the global var
4011          * PL_generation is incremented for each assign op we compile.
4012          * Then, while compiling the assign op, we run through all the
4013          * variables on both sides of the assignment, setting a spare slot
4014          * in each of them to PL_generation. If any of them already have
4015          * that value, we know we've got commonality.  We could use a
4016          * single bit marker, but then we'd have to make 2 passes, first
4017          * to clear the flag, then to test and set it.  To find somewhere
4018          * to store these values, evil chicanery is done with SvUVX().
4019          */
4020
4021         {
4022             OP *lastop = o;
4023             PL_generation++;
4024             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4025                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4026                     if (curop->op_type == OP_GV) {
4027                         GV *gv = cGVOPx_gv(curop);
4028                         if (gv == PL_defgv
4029                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4030                             break;
4031                         GvASSIGN_GENERATION_set(gv, PL_generation);
4032                     }
4033                     else if (curop->op_type == OP_PADSV ||
4034                              curop->op_type == OP_PADAV ||
4035                              curop->op_type == OP_PADHV ||
4036                              curop->op_type == OP_PADANY)
4037                     {
4038                         if (PAD_COMPNAME_GEN(curop->op_targ)
4039                                                     == (STRLEN)PL_generation)
4040                             break;
4041                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4042
4043                     }
4044                     else if (curop->op_type == OP_RV2CV)
4045                         break;
4046                     else if (curop->op_type == OP_RV2SV ||
4047                              curop->op_type == OP_RV2AV ||
4048                              curop->op_type == OP_RV2HV ||
4049                              curop->op_type == OP_RV2GV) {
4050                         if (lastop->op_type != OP_GV)   /* funny deref? */
4051                             break;
4052                     }
4053                     else if (curop->op_type == OP_PUSHRE) {
4054 #ifdef USE_ITHREADS
4055                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4056                             GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4057                             if (gv == PL_defgv
4058                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4059                                 break;
4060                             GvASSIGN_GENERATION_set(gv, PL_generation);
4061                         }
4062 #else
4063                         GV *const gv
4064                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4065                         if (gv) {
4066                             if (gv == PL_defgv
4067                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4068                                 break;
4069                             GvASSIGN_GENERATION_set(gv, PL_generation);
4070                         }
4071 #endif
4072                     }
4073                     else
4074                         break;
4075                 }
4076                 lastop = curop;
4077             }
4078             if (curop != o)
4079                 o->op_private |= OPpASSIGN_COMMON;
4080         }
4081
4082         if ((left->op_type == OP_LIST
4083              || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4084             OP* lop = ((LISTOP*)left)->op_first;
4085             while (lop) {
4086                 if (lop->op_type == OP_PADSV ||
4087                     lop->op_type == OP_PADAV ||
4088                     lop->op_type == OP_PADHV ||
4089                     lop->op_type == OP_PADANY) {
4090                     if (lop->op_private & OPpPAD_STATE) {
4091                         if (left->op_private & OPpLVAL_INTRO) {
4092                             /* Each variable in state($a, $b, $c) = ... */
4093                         }
4094                         else {
4095                             /* Each state variable in
4096                                (state $a, my $b, our $c, $d, undef) = ... */
4097                         }
4098                         yyerror(no_list_state);
4099                     } else {
4100                         /* Each my variable in
4101                            (state $a, my $b, our $c, $d, undef) = ... */
4102                     }
4103                 } else {
4104                     /* Other ops in the list. undef may be interesting in
4105                        (state $a, undef, state $c) */
4106                 }
4107                 lop = lop->op_sibling;
4108             }
4109         }
4110         else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4111                     == (OPpLVAL_INTRO | OPpPAD_STATE))
4112                 && (   left->op_type == OP_PADSV
4113                     || left->op_type == OP_PADAV
4114                     || left->op_type == OP_PADHV
4115                     || left->op_type == OP_PADANY))
4116         {
4117             /* All single variable list context state assignments, hence
4118                state ($a) = ...
4119                (state $a) = ...
4120                state @a = ...
4121                state (@a) = ...
4122                (state @a) = ...
4123                state %a = ...
4124                state (%a) = ...
4125                (state %a) = ...
4126             */
4127             yyerror(no_list_state);
4128         }
4129
4130         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4131             OP* tmpop = ((LISTOP*)right)->op_first;
4132             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4133                 PMOP * const pm = (PMOP*)tmpop;
4134                 if (left->op_type == OP_RV2AV &&
4135                     !(left->op_private & OPpLVAL_INTRO) &&
4136                     !(o->op_private & OPpASSIGN_COMMON) )
4137                 {
4138                     tmpop = ((UNOP*)left)->op_first;
4139                     if (tmpop->op_type == OP_GV
4140 #ifdef USE_ITHREADS
4141                         && !pm->op_pmreplrootu.op_pmtargetoff
4142 #else
4143                         && !pm->op_pmreplrootu.op_pmtargetgv
4144 #endif
4145                         ) {
4146 #ifdef USE_ITHREADS
4147                         pm->op_pmreplrootu.op_pmtargetoff
4148                             = cPADOPx(tmpop)->op_padix;
4149                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4150 #else
4151                         pm->op_pmreplrootu.op_pmtargetgv
4152                             = (GV*)cSVOPx(tmpop)->op_sv;
4153                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4154 #endif
4155                         pm->op_pmflags |= PMf_ONCE;
4156                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4157                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4158                         tmpop->op_sibling = NULL;       /* don't free split */
4159                         right->op_next = tmpop->op_next;  /* fix starting loc */
4160                         op_free(o);                     /* blow off assign */
4161                         right->op_flags &= ~OPf_WANT;
4162                                 /* "I don't know and I don't care." */
4163                         return right;
4164                     }
4165                 }
4166                 else {
4167                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4168                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4169                     {
4170                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4171                         if (SvIVX(sv) == 0)
4172                             sv_setiv(sv, PL_modcount+1);
4173                     }
4174                 }
4175             }
4176         }
4177         return o;
4178     }
4179     if (!right)
4180         right = newOP(OP_UNDEF, 0);
4181     if (right->op_type == OP_READLINE) {
4182         right->op_flags |= OPf_STACKED;
4183         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4184     }
4185     else {
4186         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4187         o = newBINOP(OP_SASSIGN, flags,
4188             scalar(right), mod(scalar(left), OP_SASSIGN) );
4189         if (PL_eval_start)
4190             PL_eval_start = 0;
4191         else {
4192             /* FIXME for MAD */
4193             op_free(o);
4194             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4195             o->op_private |= OPpCONST_ARYBASE;
4196         }
4197     }
4198     return o;
4199 }
4200
4201 OP *
4202 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4203 {
4204     dVAR;
4205     const U32 seq = intro_my();
4206     register COP *cop;
4207
4208     NewOp(1101, cop, 1, COP);
4209     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4210         cop->op_type = OP_DBSTATE;
4211         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4212     }
4213     else {
4214         cop->op_type = OP_NEXTSTATE;
4215         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4216     }
4217     cop->op_flags = (U8)flags;
4218     CopHINTS_set(cop, PL_hints);
4219 #ifdef NATIVE_HINTS
4220     cop->op_private |= NATIVE_HINTS;
4221 #endif
4222     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4223     cop->op_next = (OP*)cop;
4224
4225     if (label) {
4226         CopLABEL_set(cop, label);
4227         PL_hints |= HINT_BLOCK_SCOPE;
4228     }
4229     cop->cop_seq = seq;
4230     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4231        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4232     */
4233     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4234     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4235     if (cop->cop_hints_hash) {
4236         HINTS_REFCNT_LOCK;
4237         cop->cop_hints_hash->refcounted_he_refcnt++;
4238         HINTS_REFCNT_UNLOCK;
4239     }
4240
4241     if (PL_parser && PL_parser->copline == NOLINE)
4242         CopLINE_set(cop, CopLINE(PL_curcop));
4243     else {
4244         CopLINE_set(cop, PL_parser->copline);
4245         if (PL_parser)
4246             PL_parser->copline = NOLINE;
4247     }
4248 #ifdef USE_ITHREADS
4249     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4250 #else
4251     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4252 #endif
4253     CopSTASH_set(cop, PL_curstash);
4254
4255     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4256         AV *av = CopFILEAVx(PL_curcop);
4257         if (av) {
4258             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4259             if (svp && *svp != &PL_sv_undef ) {
4260                 (void)SvIOK_on(*svp);
4261                 SvIV_set(*svp, PTR2IV(cop));
4262             }
4263         }
4264     }
4265
4266     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4267 }
4268
4269
4270 OP *
4271 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4272 {
4273     dVAR;
4274     return new_logop(type, flags, &first, &other);
4275 }
4276
4277 STATIC OP *
4278 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4279 {
4280     dVAR;
4281     LOGOP *logop;
4282     OP *o;
4283     OP *first = *firstp;
4284     OP * const other = *otherp;
4285
4286     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4287         return newBINOP(type, flags, scalar(first), scalar(other));
4288
4289     scalarboolean(first);
4290     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4291     if (first->op_type == OP_NOT
4292         && (first->op_flags & OPf_SPECIAL)
4293         && (first->op_flags & OPf_KIDS)
4294         && !PL_madskills) {
4295         if (type == OP_AND || type == OP_OR) {
4296             if (type == OP_AND)
4297                 type = OP_OR;
4298             else
4299                 type = OP_AND;
4300             o = first;
4301             first = *firstp = cUNOPo->op_first;
4302             if (o->op_next)
4303                 first->op_next = o->op_next;
4304             cUNOPo->op_first = NULL;
4305             op_free(o);
4306         }
4307     }
4308     if (first->op_type == OP_CONST) {
4309         if (first->op_private & OPpCONST_STRICT)
4310             no_bareword_allowed(first);
4311         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4312                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4313         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4314             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4315             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4316             *firstp = NULL;
4317             if (other->op_type == OP_CONST)
4318                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4319             if (PL_madskills) {
4320                 OP *newop = newUNOP(OP_NULL, 0, other);
4321                 op_getmad(first, newop, '1');
4322                 newop->op_targ = type;  /* set "was" field */
4323                 return newop;
4324             }
4325             op_free(first);
4326             return other;
4327         }
4328         else {
4329             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4330             const OP *o2 = other;
4331             if ( ! (o2->op_type == OP_LIST
4332                     && (( o2 = cUNOPx(o2)->op_first))
4333                     && o2->op_type == OP_PUSHMARK
4334                     && (( o2 = o2->op_sibling)) )
4335             )
4336                 o2 = other;
4337             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4338                         || o2->op_type == OP_PADHV)
4339                 && o2->op_private & OPpLVAL_INTRO
4340                 && !(o2->op_private & OPpPAD_STATE)
4341                 && ckWARN(WARN_DEPRECATED))
4342             {
4343                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4344                             "Deprecated use of my() in false conditional");
4345             }
4346
4347             *otherp = NULL;
4348             if (first->op_type == OP_CONST)
4349                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4350             if (PL_madskills) {
4351                 first = newUNOP(OP_NULL, 0, first);
4352                 op_getmad(other, first, '2');
4353                 first->op_targ = type;  /* set "was" field */
4354             }
4355             else
4356                 op_free(other);
4357             return first;
4358         }
4359     }
4360     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4361         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4362     {
4363         const OP * const k1 = ((UNOP*)first)->op_first;
4364         const OP * const k2 = k1->op_sibling;
4365         OPCODE warnop = 0;
4366         switch (first->op_type)
4367         {
4368         case OP_NULL:
4369             if (k2 && k2->op_type == OP_READLINE
4370                   && (k2->op_flags & OPf_STACKED)
4371                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4372             {
4373                 warnop = k2->op_type;
4374             }
4375             break;
4376
4377         case OP_SASSIGN:
4378             if (k1->op_type == OP_READDIR
4379                   || k1->op_type == OP_GLOB
4380                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4381                   || k1->op_type == OP_EACH)
4382             {
4383                 warnop = ((k1->op_type == OP_NULL)
4384                           ? (OPCODE)k1->op_targ : k1->op_type);
4385             }
4386             break;
4387         }
4388         if (warnop) {
4389             const line_t oldline = CopLINE(PL_curcop);
4390             CopLINE_set(PL_curcop, PL_parser->copline);
4391             Perl_warner(aTHX_ packWARN(WARN_MISC),
4392                  "Value of %s%s can be \"0\"; test with defined()",
4393                  PL_op_desc[warnop],
4394                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4395                   ? " construct" : "() operator"));
4396             CopLINE_set(PL_curcop, oldline);
4397         }
4398     }
4399
4400     if (!other)
4401         return first;
4402
4403     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4404         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4405
4406     NewOp(1101, logop, 1, LOGOP);
4407
4408     logop->op_type = (OPCODE)type;
4409     logop->op_ppaddr = PL_ppaddr[type];
4410     logop->op_first = first;
4411     logop->op_flags = (U8)(flags | OPf_KIDS);
4412     logop->op_other = LINKLIST(other);
4413     logop->op_private = (U8)(1 | (flags >> 8));
4414
4415     /* establish postfix order */
4416     logop->op_next = LINKLIST(first);
4417     first->op_next = (OP*)logop;
4418     first->op_sibling = other;
4419
4420     CHECKOP(type,logop);
4421
4422     o = newUNOP(OP_NULL, 0, (OP*)logop);
4423     other->op_next = o;
4424
4425     return o;
4426 }
4427
4428 OP *
4429 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4430 {
4431     dVAR;
4432     LOGOP *logop;
4433     OP *start;
4434     OP *o;
4435
4436     if (!falseop)
4437         return newLOGOP(OP_AND, 0, first, trueop);
4438     if (!trueop)
4439         return newLOGOP(OP_OR, 0, first, falseop);
4440
4441     scalarboolean(first);
4442     if (first->op_type == OP_CONST) {
4443         /* Left or right arm of the conditional?  */
4444         const bool left = SvTRUE(((SVOP*)first)->op_sv);
4445         OP *live = left ? trueop : falseop;
4446         OP *const dead = left ? falseop : trueop;
4447         if (first->op_private & OPpCONST_BARE &&
4448             first->op_private & OPpCONST_STRICT) {
4449             no_bareword_allowed(first);
4450         }
4451         if (PL_madskills) {
4452             /* This is all dead code when PERL_MAD is not defined.  */
4453             live = newUNOP(OP_NULL, 0, live);
4454             op_getmad(first, live, 'C');
4455             op_getmad(dead, live, left ? 'e' : 't');
4456         } else {
4457             op_free(first);
4458             op_free(dead);
4459         }
4460         return live;
4461     }
4462     NewOp(1101, logop, 1, LOGOP);
4463     logop->op_type = OP_COND_EXPR;
4464     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4465     logop->op_first = first;
4466     logop->op_flags = (U8)(flags | OPf_KIDS);
4467     logop->op_private = (U8)(1 | (flags >> 8));
4468     logop->op_other = LINKLIST(trueop);
4469     logop->op_next = LINKLIST(falseop);
4470
4471     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4472             logop);
4473
4474     /* establish postfix order */
4475     start = LINKLIST(first);
4476     first->op_next = (OP*)logop;
4477
4478     first->op_sibling = trueop;
4479     trueop->op_sibling = falseop;
4480     o = newUNOP(OP_NULL, 0, (OP*)logop);
4481
4482     trueop->op_next = falseop->op_next = o;
4483
4484     o->op_next = start;
4485     return o;
4486 }
4487
4488 OP *
4489 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4490 {
4491     dVAR;
4492     LOGOP *range;
4493     OP *flip;
4494     OP *flop;
4495     OP *leftstart;
4496     OP *o;
4497
4498     NewOp(1101, range, 1, LOGOP);
4499
4500     range->op_type = OP_RANGE;
4501     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4502     range->op_first = left;
4503     range->op_flags = OPf_KIDS;
4504     leftstart = LINKLIST(left);
4505     range->op_other = LINKLIST(right);
4506     range->op_private = (U8)(1 | (flags >> 8));
4507
4508     left->op_sibling = right;
4509
4510     range->op_next = (OP*)range;
4511     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4512     flop = newUNOP(OP_FLOP, 0, flip);
4513     o = newUNOP(OP_NULL, 0, flop);
4514     linklist(flop);
4515     range->op_next = leftstart;
4516
4517     left->op_next = flip;
4518     right->op_next = flop;
4519
4520     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4521     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4522     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4523     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4524
4525     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4526     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4527
4528     flip->op_next = o;
4529     if (!flip->op_private || !flop->op_private)
4530         linklist(o);            /* blow off optimizer unless constant */
4531
4532     return o;
4533 }
4534
4535 OP *
4536 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4537 {
4538     dVAR;
4539     OP* listop;
4540     OP* o;
4541     const bool once = block && block->op_flags & OPf_SPECIAL &&
4542       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4543
4544     PERL_UNUSED_ARG(debuggable);
4545
4546     if (expr) {
4547         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4548             return block;       /* do {} while 0 does once */
4549         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4550             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4551             expr = newUNOP(OP_DEFINED, 0,
4552                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4553         } else if (expr->op_flags & OPf_KIDS) {
4554             const OP * const k1 = ((UNOP*)expr)->op_first;
4555             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4556             switch (expr->op_type) {
4557               case OP_NULL:
4558                 if (k2 && k2->op_type == OP_READLINE
4559                       && (k2->op_flags & OPf_STACKED)
4560                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4561                     expr = newUNOP(OP_DEFINED, 0, expr);
4562                 break;
4563
4564               case OP_SASSIGN:
4565                 if (k1 && (k1->op_type == OP_READDIR
4566                       || k1->op_type == OP_GLOB
4567                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4568                       || k1->op_type == OP_EACH))
4569                     expr = newUNOP(OP_DEFINED, 0, expr);
4570                 break;
4571             }
4572         }
4573     }
4574
4575     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4576      * op, in listop. This is wrong. [perl #27024] */
4577     if (!block)
4578         block = newOP(OP_NULL, 0);
4579     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4580     o = new_logop(OP_AND, 0, &expr, &listop);
4581
4582     if (listop)
4583         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4584
4585     if (once && o != listop)
4586         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4587
4588     if (o == listop)
4589         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4590
4591     o->op_flags |= flags;
4592     o = scope(o);
4593     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4594     return o;
4595 }
4596
4597 OP *
4598 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4599 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4600 {
4601     dVAR;
4602     OP *redo;
4603     OP *next = NULL;
4604     OP *listop;
4605     OP *o;
4606     U8 loopflags = 0;
4607
4608     PERL_UNUSED_ARG(debuggable);
4609
4610     if (expr) {
4611         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4612                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4613             expr = newUNOP(OP_DEFINED, 0,
4614                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4615         } else if (expr->op_flags & OPf_KIDS) {
4616             const OP * const k1 = ((UNOP*)expr)->op_first;
4617             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4618             switch (expr->op_type) {
4619               case OP_NULL:
4620                 if (k2 && k2->op_type == OP_READLINE
4621                       && (k2->op_flags & OPf_STACKED)
4622                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4623                     expr = newUNOP(OP_DEFINED, 0, expr);
4624                 break;
4625
4626               case OP_SASSIGN:
4627                 if (k1 && (k1->op_type == OP_READDIR
4628                       || k1->op_type == OP_GLOB
4629                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4630                       || k1->op_type == OP_EACH))
4631                     expr = newUNOP(OP_DEFINED, 0, expr);
4632                 break;
4633             }
4634         }
4635     }
4636
4637     if (!block)
4638         block = newOP(OP_NULL, 0);
4639     else if (cont || has_my) {
4640         block = scope(block);
4641     }
4642
4643     if (cont) {
4644         next = LINKLIST(cont);
4645     }
4646     if (expr) {
4647         OP * const unstack = newOP(OP_UNSTACK, 0);
4648         if (!next)
4649             next = unstack;
4650         cont = append_elem(OP_LINESEQ, cont, unstack);
4651     }
4652
4653     assert(block);
4654     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4655     assert(listop);
4656     redo = LINKLIST(listop);
4657
4658     if (expr) {
4659         PL_parser->copline = (line_t)whileline;
4660         scalar(listop);
4661         o = new_logop(OP_AND, 0, &expr, &listop);
4662         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4663             op_free(expr);              /* oops, it's a while (0) */
4664             op_free((OP*)loop);
4665             return NULL;                /* listop already freed by new_logop */
4666         }
4667         if (listop)
4668             ((LISTOP*)listop)->op_last->op_next =
4669                 (o == listop ? redo : LINKLIST(o));
4670     }
4671     else
4672         o = listop;
4673
4674     if (!loop) {
4675         NewOp(1101,loop,1,LOOP);
4676         loop->op_type = OP_ENTERLOOP;
4677         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4678         loop->op_private = 0;
4679         loop->op_next = (OP*)loop;
4680     }
4681
4682     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4683
4684     loop->op_redoop = redo;
4685     loop->op_lastop = o;
4686     o->op_private |= loopflags;
4687
4688     if (next)
4689         loop->op_nextop = next;
4690     else
4691         loop->op_nextop = o;
4692
4693     o->op_flags |= flags;
4694     o->op_private |= (flags >> 8);
4695     return o;
4696 }
4697
4698 OP *
4699 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4700 {
4701     dVAR;
4702     LOOP *loop;
4703     OP *wop;
4704     PADOFFSET padoff = 0;
4705     I32 iterflags = 0;
4706     I32 iterpflags = 0;
4707     OP *madsv = NULL;
4708
4709     if (sv) {
4710         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4711             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4712             sv->op_type = OP_RV2GV;
4713             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4714
4715             /* The op_type check is needed to prevent a possible segfault
4716              * if the loop variable is undeclared and 'strict vars' is in
4717              * effect. This is illegal but is nonetheless parsed, so we
4718              * may reach this point with an OP_CONST where we're expecting
4719              * an OP_GV.
4720              */
4721             if (cUNOPx(sv)->op_first->op_type == OP_GV
4722              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4723                 iterpflags |= OPpITER_DEF;
4724         }
4725         else if (sv->op_type == OP_PADSV) { /* private variable */
4726             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4727             padoff = sv->op_targ;
4728             if (PL_madskills)
4729                 madsv = sv;
4730             else {
4731                 sv->op_targ = 0;
4732                 op_free(sv);
4733             }
4734             sv = NULL;
4735         }
4736         else
4737             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4738         if (padoff) {
4739             SV *const namesv = PAD_COMPNAME_SV(padoff);
4740             STRLEN len;
4741             const char *const name = SvPV_const(namesv, len);
4742
4743             if (len == 2 && name[0] == '$' && name[1] == '_')
4744                 iterpflags |= OPpITER_DEF;
4745         }
4746     }
4747     else {
4748         const PADOFFSET offset = pad_findmy("$_");
4749         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4750             sv = newGVOP(OP_GV, 0, PL_defgv);
4751         }
4752         else {
4753             padoff = offset;
4754         }
4755         iterpflags |= OPpITER_DEF;
4756     }
4757     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4758         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4759         iterflags |= OPf_STACKED;
4760     }
4761     else if (expr->op_type == OP_NULL &&
4762              (expr->op_flags & OPf_KIDS) &&
4763              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4764     {
4765         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4766          * set the STACKED flag to indicate that these values are to be
4767          * treated as min/max values by 'pp_iterinit'.
4768          */
4769         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4770         LOGOP* const range = (LOGOP*) flip->op_first;
4771         OP* const left  = range->op_first;
4772         OP* const right = left->op_sibling;
4773         LISTOP* listop;
4774
4775         range->op_flags &= ~OPf_KIDS;
4776         range->op_first = NULL;
4777
4778         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4779         listop->op_first->op_next = range->op_next;
4780         left->op_next = range->op_other;
4781         right->op_next = (OP*)listop;
4782         listop->op_next = listop->op_first;
4783
4784 #ifdef PERL_MAD
4785         op_getmad(expr,(OP*)listop,'O');
4786 #else
4787         op_free(expr);
4788 #endif
4789         expr = (OP*)(listop);
4790         op_null(expr);
4791         iterflags |= OPf_STACKED;
4792     }
4793     else {
4794         expr = mod(force_list(expr), OP_GREPSTART);
4795     }
4796
4797     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4798                                append_elem(OP_LIST, expr, scalar(sv))));
4799     assert(!loop->op_next);
4800     /* for my  $x () sets OPpLVAL_INTRO;
4801      * for our $x () sets OPpOUR_INTRO */
4802     loop->op_private = (U8)iterpflags;
4803 #ifdef PL_OP_SLAB_ALLOC
4804     {
4805         LOOP *tmp;
4806         NewOp(1234,tmp,1,LOOP);
4807         Copy(loop,tmp,1,LISTOP);
4808         S_op_destroy(aTHX_ (OP*)loop);
4809         loop = tmp;
4810     }
4811 #else
4812     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4813 #endif
4814     loop->op_targ = padoff;
4815     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4816     if (madsv)
4817         op_getmad(madsv, (OP*)loop, 'v');
4818     PL_parser->copline = forline;
4819     return newSTATEOP(0, label, wop);
4820 }
4821
4822 OP*
4823 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4824 {
4825     dVAR;
4826     OP *o;
4827
4828     if (type != OP_GOTO || label->op_type == OP_CONST) {
4829         /* "last()" means "last" */
4830         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4831             o = newOP(type, OPf_SPECIAL);
4832         else {
4833             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4834                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4835                                         : ""));
4836         }
4837 #ifdef PERL_MAD
4838         op_getmad(label,o,'L');
4839 #else
4840         op_free(label);
4841 #endif
4842     }
4843     else {
4844         /* Check whether it's going to be a goto &function */
4845         if (label->op_type == OP_ENTERSUB
4846                 && !(label->op_flags & OPf_STACKED))
4847             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4848         o = newUNOP(type, OPf_STACKED, label);
4849     }
4850     PL_hints |= HINT_BLOCK_SCOPE;
4851     return o;
4852 }
4853
4854 /* if the condition is a literal array or hash
4855    (or @{ ... } etc), make a reference to it.
4856  */
4857 STATIC OP *
4858 S_ref_array_or_hash(pTHX_ OP *cond)
4859 {
4860     if (cond
4861     && (cond->op_type == OP_RV2AV
4862     ||  cond->op_type == OP_PADAV
4863     ||  cond->op_type == OP_RV2HV
4864     ||  cond->op_type == OP_PADHV))
4865
4866         return newUNOP(OP_REFGEN,
4867             0, mod(cond, OP_REFGEN));
4868
4869     else
4870         return cond;
4871 }
4872
4873 /* These construct the optree fragments representing given()
4874    and when() blocks.
4875
4876    entergiven and enterwhen are LOGOPs; the op_other pointer
4877    points up to the associated leave op. We need this so we
4878    can put it in the context and make break/continue work.
4879    (Also, of course, pp_enterwhen will jump straight to
4880    op_other if the match fails.)
4881  */
4882
4883 STATIC OP *
4884 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4885                    I32 enter_opcode, I32 leave_opcode,
4886                    PADOFFSET entertarg)
4887 {
4888     dVAR;
4889     LOGOP *enterop;
4890     OP *o;
4891
4892     NewOp(1101, enterop, 1, LOGOP);
4893     enterop->op_type = enter_opcode;
4894     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4895     enterop->op_flags =  (U8) OPf_KIDS;
4896     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4897     enterop->op_private = 0;
4898
4899     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4900
4901     if (cond) {
4902         enterop->op_first = scalar(cond);
4903         cond->op_sibling = block;
4904
4905         o->op_next = LINKLIST(cond);
4906         cond->op_next = (OP *) enterop;
4907     }
4908     else {
4909         /* This is a default {} block */
4910         enterop->op_first = block;
4911         enterop->op_flags |= OPf_SPECIAL;
4912
4913         o->op_next = (OP *) enterop;
4914     }
4915
4916     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4917                                        entergiven and enterwhen both
4918                                        use ck_null() */
4919
4920     enterop->op_next = LINKLIST(block);
4921     block->op_next = enterop->op_other = o;
4922
4923     return o;
4924 }
4925
4926 /* Does this look like a boolean operation? For these purposes
4927    a boolean operation is:
4928      - a subroutine call [*]
4929      - a logical connective
4930      - a comparison operator
4931      - a filetest operator, with the exception of -s -M -A -C
4932      - defined(), exists() or eof()
4933      - /$re/ or $foo =~ /$re/
4934
4935    [*] possibly surprising
4936  */
4937 STATIC bool
4938 S_looks_like_bool(pTHX_ const OP *o)
4939 {
4940     dVAR;
4941     switch(o->op_type) {
4942         case OP_OR:
4943             return looks_like_bool(cLOGOPo->op_first);
4944
4945         case OP_AND:
4946             return (
4947                 looks_like_bool(cLOGOPo->op_first)
4948              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4949
4950         case OP_NULL:
4951             return (
4952                 o->op_flags & OPf_KIDS
4953             && looks_like_bool(cUNOPo->op_first));
4954
4955         case OP_ENTERSUB:
4956
4957         case OP_NOT:    case OP_XOR:
4958         /* Note that OP_DOR is not here */
4959
4960         case OP_EQ:     case OP_NE:     case OP_LT:
4961         case OP_GT:     case OP_LE:     case OP_GE:
4962
4963         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4964         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4965
4966         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4967         case OP_SGT:    case OP_SLE:    case OP_SGE:
4968
4969         case OP_SMARTMATCH:
4970
4971         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4972         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4973         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4974         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4975         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4976         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4977         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4978         case OP_FTTEXT:   case OP_FTBINARY:
4979
4980         case OP_DEFINED: case OP_EXISTS:
4981         case OP_MATCH:   case OP_EOF:
4982
4983             return TRUE;
4984
4985         case OP_CONST:
4986             /* Detect comparisons that have been optimized away */
4987             if (cSVOPo->op_sv == &PL_sv_yes
4988             ||  cSVOPo->op_sv == &PL_sv_no)
4989
4990                 return TRUE;
4991
4992         /* FALL THROUGH */
4993         default:
4994             return FALSE;
4995     }
4996 }
4997
4998 OP *
4999 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5000 {
5001     dVAR;
5002     assert( cond );
5003     return newGIVWHENOP(
5004         ref_array_or_hash(cond),
5005         block,
5006         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5007         defsv_off);
5008 }
5009
5010 /* If cond is null, this is a default {} block */
5011 OP *
5012 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5013 {
5014     const bool cond_llb = (!cond || looks_like_bool(cond));
5015     OP *cond_op;
5016
5017     if (cond_llb)
5018         cond_op = cond;
5019     else {
5020         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5021                 newDEFSVOP(),
5022                 scalar(ref_array_or_hash(cond)));
5023     }
5024
5025     return newGIVWHENOP(
5026         cond_op,
5027         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5028         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5029 }
5030
5031 /*
5032 =for apidoc cv_undef
5033
5034 Clear out all the active components of a CV. This can happen either
5035 by an explicit C<undef &foo>, or by the reference count going to zero.
5036 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5037 children can still follow the full lexical scope chain.
5038
5039 =cut
5040 */
5041
5042 void
5043 Perl_cv_undef(pTHX_ CV *cv)
5044 {
5045     dVAR;
5046
5047     DEBUG_X(PerlIO_printf(Perl_debug_log,
5048           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5049             PTR2UV(cv), PTR2UV(PL_comppad))
5050     );
5051
5052 #ifdef USE_ITHREADS
5053     if (CvFILE(cv) && !CvISXSUB(cv)) {
5054         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5055         Safefree(CvFILE(cv));
5056     }
5057     CvFILE(cv) = NULL;
5058 #endif
5059
5060     if (!CvISXSUB(cv) && CvROOT(cv)) {
5061         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5062             Perl_croak(aTHX_ "Can't undef active subroutine");
5063         ENTER;
5064
5065         PAD_SAVE_SETNULLPAD();
5066
5067         op_free(CvROOT(cv));
5068         CvROOT(cv) = NULL;
5069         CvSTART(cv) = NULL;
5070         LEAVE;
5071     }
5072     SvPOK_off((SV*)cv);         /* forget prototype */
5073     CvGV(cv) = NULL;
5074
5075     pad_undef(cv);
5076
5077     /* remove CvOUTSIDE unless this is an undef rather than a free */
5078     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5079         if (!CvWEAKOUTSIDE(cv))
5080             SvREFCNT_dec(CvOUTSIDE(cv));
5081         CvOUTSIDE(cv) = NULL;
5082     }
5083     if (CvCONST(cv)) {
5084         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5085         CvCONST_off(cv);
5086     }
5087     if (CvISXSUB(cv) && CvXSUB(cv)) {
5088         CvXSUB(cv) = NULL;
5089     }
5090     /* delete all flags except WEAKOUTSIDE */
5091     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5092 }
5093
5094 void
5095 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5096                     const STRLEN len)
5097 {
5098     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5099        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5100     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5101          || (p && (len != SvCUR(cv) /* Not the same length.  */
5102                    || memNE(p, SvPVX_const(cv), len))))
5103          && ckWARN_d(WARN_PROTOTYPE)) {
5104         SV* const msg = sv_newmortal();
5105         SV* name = NULL;
5106
5107         if (gv)
5108             gv_efullname3(name = sv_newmortal(), gv, NULL);
5109         sv_setpvs(msg, "Prototype mismatch:");
5110         if (name)
5111             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5112         if (SvPOK(cv))
5113             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5114         else
5115             sv_catpvs(msg, ": none");
5116         sv_catpvs(msg, " vs ");
5117         if (p)
5118             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5119         else
5120             sv_catpvs(msg, "none");
5121         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5122     }
5123 }
5124
5125 static void const_sv_xsub(pTHX_ CV* cv);
5126
5127 /*
5128
5129 =head1 Optree Manipulation Functions
5130
5131 =for apidoc cv_const_sv
5132
5133 If C<cv> is a constant sub eligible for inlining. returns the constant
5134 value returned by the sub.  Otherwise, returns NULL.
5135
5136 Constant subs can be created with C<newCONSTSUB> or as described in
5137 L<perlsub/"Constant Functions">.
5138
5139 =cut
5140 */
5141 SV *
5142 Perl_cv_const_sv(pTHX_ CV *cv)
5143 {
5144     PERL_UNUSED_CONTEXT;
5145     if (!cv)
5146         return NULL;
5147     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5148         return NULL;
5149     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5150 }
5151
5152 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5153  * Can be called in 3 ways:
5154  *
5155  * !cv
5156  *      look for a single OP_CONST with attached value: return the value
5157  *
5158  * cv && CvCLONE(cv) && !CvCONST(cv)
5159  *
5160  *      examine the clone prototype, and if contains only a single
5161  *      OP_CONST referencing a pad const, or a single PADSV referencing
5162  *      an outer lexical, return a non-zero value to indicate the CV is
5163  *      a candidate for "constizing" at clone time
5164  *
5165  * cv && CvCONST(cv)
5166  *
5167  *      We have just cloned an anon prototype that was marked as a const
5168  *      candidiate. Try to grab the current value, and in the case of
5169  *      PADSV, ignore it if it has multiple references. Return the value.
5170  */
5171
5172 SV *
5173 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5174 {
5175     dVAR;
5176     SV *sv = NULL;
5177
5178     if (PL_madskills)
5179         return NULL;
5180
5181     if (!o)
5182         return NULL;
5183
5184     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5185         o = cLISTOPo->op_first->op_sibling;
5186
5187     for (; o; o = o->op_next) {
5188         const OPCODE type = o->op_type;
5189
5190         if (sv && o->op_next == o)
5191             return sv;
5192         if (o->op_next != o) {
5193             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5194                 continue;
5195             if (type == OP_DBSTATE)
5196                 continue;
5197         }
5198         if (type == OP_LEAVESUB || type == OP_RETURN)
5199             break;
5200         if (sv)
5201             return NULL;
5202         if (type == OP_CONST && cSVOPo->op_sv)
5203             sv = cSVOPo->op_sv;
5204         else if (cv && type == OP_CONST) {
5205             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5206             if (!sv)
5207                 return NULL;
5208         }
5209         else if (cv && type == OP_PADSV) {
5210             if (CvCONST(cv)) { /* newly cloned anon */
5211                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5212                 /* the candidate should have 1 ref from this pad and 1 ref
5213                  * from the parent */
5214                 if (!sv || SvREFCNT(sv) != 2)
5215                     return NULL;
5216                 sv = newSVsv(sv);
5217                 SvREADONLY_on(sv);
5218                 return sv;
5219             }
5220             else {
5221                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5222                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5223             }
5224         }
5225         else {
5226             return NULL;
5227         }
5228     }
5229     return sv;
5230 }
5231
5232 #ifdef PERL_MAD
5233 OP *
5234 #else
5235 void
5236 #endif
5237 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5238 {
5239 #if 0
5240     /* This would be the return value, but the return cannot be reached.  */
5241     OP* pegop = newOP(OP_NULL, 0);
5242 #endif
5243
5244     PERL_UNUSED_ARG(floor);
5245
5246     if (o)
5247         SAVEFREEOP(o);
5248     if (proto)
5249         SAVEFREEOP(proto);
5250     if (attrs)
5251         SAVEFREEOP(attrs);
5252     if (block)
5253         SAVEFREEOP(block);
5254     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5255 #ifdef PERL_MAD
5256     NORETURN_FUNCTION_END;
5257 #endif
5258 }
5259
5260 CV *
5261 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5262 {
5263     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5264 }
5265
5266 CV *
5267 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5268 {
5269     dVAR;
5270     const char *aname;
5271     GV *gv;
5272     const char *ps;
5273     STRLEN ps_len;
5274     register CV *cv = NULL;
5275     SV *const_sv;
5276     /* If the subroutine has no body, no attributes, and no builtin attributes
5277        then it's just a sub declaration, and we may be able to get away with
5278        storing with a placeholder scalar in the symbol table, rather than a
5279        full GV and CV.  If anything is present then it will take a full CV to
5280        store it.  */
5281     const I32 gv_fetch_flags
5282         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5283            || PL_madskills)
5284         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5285     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5286
5287     if (proto) {
5288         assert(proto->op_type == OP_CONST);
5289         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5290     }
5291     else
5292         ps = NULL;
5293
5294     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5295         SV * const sv = sv_newmortal();
5296         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5297                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5298                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5299         aname = SvPVX_const(sv);
5300     }
5301     else
5302         aname = NULL;
5303
5304     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5305         : gv_fetchpv(aname ? aname
5306                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5307                      gv_fetch_flags, SVt_PVCV);
5308
5309     if (!PL_madskills) {
5310         if (o)
5311             SAVEFREEOP(o);
5312         if (proto)
5313             SAVEFREEOP(proto);
5314         if (attrs)
5315             SAVEFREEOP(attrs);
5316     }
5317
5318     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5319                                            maximum a prototype before. */
5320         if (SvTYPE(gv) > SVt_NULL) {
5321             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5322                 && ckWARN_d(WARN_PROTOTYPE))
5323             {
5324                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5325             }
5326             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5327         }
5328         if (ps)
5329             sv_setpvn((SV*)gv, ps, ps_len);
5330         else
5331             sv_setiv((SV*)gv, -1);
5332
5333         SvREFCNT_dec(PL_compcv);
5334         cv = PL_compcv = NULL;
5335         goto done;
5336     }
5337
5338     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5339
5340 #ifdef GV_UNIQUE_CHECK
5341     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5342         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5343     }
5344 #endif
5345
5346     if (!block || !ps || *ps || attrs
5347         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5348 #ifdef PERL_MAD
5349         || block->op_type == OP_NULL
5350 #endif
5351         )
5352         const_sv = NULL;
5353     else
5354         const_sv = op_const_sv(block, NULL);
5355
5356     if (cv) {
5357         const bool exists = CvROOT(cv) || CvXSUB(cv);
5358
5359 #ifdef GV_UNIQUE_CHECK
5360         if (exists && GvUNIQUE(gv)) {
5361             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5362         }
5363 #endif
5364
5365         /* if the subroutine doesn't exist and wasn't pre-declared
5366          * with a prototype, assume it will be AUTOLOADed,
5367          * skipping the prototype check
5368          */
5369         if (exists || SvPOK(cv))
5370             cv_ckproto_len(cv, gv, ps, ps_len);
5371         /* already defined (or promised)? */
5372         if (exists || GvASSUMECV(gv)) {
5373             if ((!block
5374 #ifdef PERL_MAD
5375                  || block->op_type == OP_NULL
5376 #endif
5377                  )&& !attrs) {
5378                 if (CvFLAGS(PL_compcv)) {
5379                     /* might have had built-in attrs applied */
5380                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5381                 }
5382                 /* just a "sub foo;" when &foo is already defined */
5383                 SAVEFREESV(PL_compcv);
5384                 goto done;
5385             }
5386             if (block
5387 #ifdef PERL_MAD
5388                 && block->op_type != OP_NULL
5389 #endif
5390                 ) {
5391                 if (ckWARN(WARN_REDEFINE)
5392                     || (CvCONST(cv)
5393                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5394                 {
5395                     const line_t oldline = CopLINE(PL_curcop);
5396                     if (PL_parser && PL_parser->copline != NOLINE)
5397                         CopLINE_set(PL_curcop, PL_parser->copline);
5398                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5399                         CvCONST(cv) ? "Constant subroutine %s redefined"
5400                                     : "Subroutine %s redefined", name);
5401                     CopLINE_set(PL_curcop, oldline);
5402                 }
5403 #ifdef PERL_MAD
5404                 if (!PL_minus_c)        /* keep old one around for madskills */
5405 #endif
5406                     {
5407                         /* (PL_madskills unset in used file.) */
5408                         SvREFCNT_dec(cv);
5409                     }
5410                 cv = NULL;
5411             }
5412         }
5413     }
5414     if (const_sv) {
5415         SvREFCNT_inc_simple_void_NN(const_sv);
5416         if (cv) {
5417             assert(!CvROOT(cv) && !CvCONST(cv));
5418             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5419             CvXSUBANY(cv).any_ptr = const_sv;
5420             CvXSUB(cv) = const_sv_xsub;
5421             CvCONST_on(cv);
5422             CvISXSUB_on(cv);
5423         }
5424         else {
5425             GvCV(gv) = NULL;
5426             cv = newCONSTSUB(NULL, name, const_sv);
5427         }
5428         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5429             (CvGV(cv) && GvSTASH(CvGV(cv)))
5430                 ? GvSTASH(CvGV(cv))
5431                 : CvSTASH(cv)
5432                     ? CvSTASH(cv)
5433                     : PL_curstash
5434         );
5435         if (PL_madskills)
5436             goto install_block;
5437         op_free(block);
5438         SvREFCNT_dec(PL_compcv);
5439         PL_compcv = NULL;
5440         goto done;
5441     }
5442     if (attrs) {
5443         HV *stash;
5444         SV *rcv;
5445
5446         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5447          * before we clobber PL_compcv.
5448          */
5449         if (cv && (!block
5450 #ifdef PERL_MAD
5451                     || block->op_type == OP_NULL
5452 #endif
5453                     )) {
5454             rcv = (SV*)cv;
5455             /* Might have had built-in attributes applied -- propagate them. */
5456             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5457             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5458                 stash = GvSTASH(CvGV(cv));
5459             else if (CvSTASH(cv))
5460                 stash = CvSTASH(cv);
5461             else
5462                 stash = PL_curstash;
5463         }
5464         else {
5465             /* possibly about to re-define existing subr -- ignore old cv */
5466             rcv = (SV*)PL_compcv;
5467             if (name && GvSTASH(gv))
5468                 stash = GvSTASH(gv);
5469             else
5470                 stash = PL_curstash;
5471         }
5472         apply_attrs(stash, rcv, attrs, FALSE);
5473     }
5474     if (cv) {                           /* must reuse cv if autoloaded */
5475         if (
5476 #ifdef PERL_MAD
5477             (
5478 #endif
5479              !block
5480 #ifdef PERL_MAD
5481              || block->op_type == OP_NULL) && !PL_madskills
5482 #endif
5483              ) {
5484             /* got here with just attrs -- work done, so bug out */
5485             SAVEFREESV(PL_compcv);
5486             goto done;
5487         }
5488         /* transfer PL_compcv to cv */
5489         cv_undef(cv);
5490         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5491         if (!CvWEAKOUTSIDE(cv))
5492             SvREFCNT_dec(CvOUTSIDE(cv));
5493         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5494         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5495         CvOUTSIDE(PL_compcv) = 0;
5496         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5497         CvPADLIST(PL_compcv) = 0;
5498         /* inner references to PL_compcv must be fixed up ... */
5499         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5500         /* ... before we throw it away */
5501         SvREFCNT_dec(PL_compcv);
5502         PL_compcv = cv;
5503         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5504           ++PL_sub_generation;
5505     }
5506     else {
5507         cv = PL_compcv;
5508         if (name) {
5509             GvCV(gv) = cv;
5510             if (PL_madskills) {
5511                 if (strEQ(name, "import")) {
5512                     PL_formfeed = (SV*)cv;
5513                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5514                 }
5515             }
5516             GvCVGEN(gv) = 0;
5517             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5518         }
5519     }
5520     CvGV(cv) = gv;
5521     CvFILE_set_from_cop(cv, PL_curcop);
5522     CvSTASH(cv) = PL_curstash;
5523
5524     if (ps)
5525         sv_setpvn((SV*)cv, ps, ps_len);
5526
5527     if (PL_parser && PL_parser->error_count) {
5528         op_free(block);
5529         block = NULL;
5530         if (name) {
5531             const char *s = strrchr(name, ':');
5532             s = s ? s+1 : name;
5533             if (strEQ(s, "BEGIN")) {
5534                 const char not_safe[] =
5535                     "BEGIN not safe after errors--compilation aborted";
5536                 if (PL_in_eval & EVAL_KEEPERR)
5537                     Perl_croak(aTHX_ not_safe);
5538                 else {
5539                     /* force display of errors found but not reported */
5540                     sv_catpv(ERRSV, not_safe);
5541                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5542                 }
5543             }
5544         }
5545     }
5546  install_block:
5547     if (!block)
5548         goto done;
5549
5550     if (CvLVALUE(cv)) {
5551         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5552                              mod(scalarseq(block), OP_LEAVESUBLV));
5553         block->op_attached = 1;
5554     }
5555     else {
5556         /* This makes sub {}; work as expected.  */
5557         if (block->op_type == OP_STUB) {
5558             OP* const newblock = newSTATEOP(0, NULL, 0);
5559 #ifdef PERL_MAD
5560             op_getmad(block,newblock,'B');
5561 #else
5562             op_free(block);
5563 #endif
5564             block = newblock;
5565         }
5566         else
5567             block->op_attached = 1;
5568         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5569     }
5570     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5571     OpREFCNT_set(CvROOT(cv), 1);
5572     CvSTART(cv) = LINKLIST(CvROOT(cv));
5573     CvROOT(cv)->op_next = 0;
5574     CALL_PEEP(CvSTART(cv));
5575
5576     /* now that optimizer has done its work, adjust pad values */
5577
5578     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5579
5580     if (CvCLONE(cv)) {
5581         assert(!CvCONST(cv));
5582         if (ps && !*ps && op_const_sv(block, cv))
5583             CvCONST_on(cv);
5584     }
5585
5586     if (name || aname) {
5587         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5588             SV * const sv = newSV(0);
5589             SV * const tmpstr = sv_newmortal();
5590             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5591                                                   GV_ADDMULTI, SVt_PVHV);
5592             HV *hv;
5593
5594             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5595                            CopFILE(PL_curcop),
5596                            (long)PL_subline, (long)CopLINE(PL_curcop));
5597             gv_efullname3(tmpstr, gv, NULL);
5598             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5599                     SvCUR(tmpstr), sv, 0);
5600             hv = GvHVn(db_postponed);
5601             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5602                 CV * const pcv = GvCV(db_postponed);
5603                 if (pcv) {
5604                     dSP;
5605                     PUSHMARK(SP);
5606                     XPUSHs(tmpstr);
5607                     PUTBACK;
5608                     call_sv((SV*)pcv, G_DISCARD);
5609                 }
5610             }
5611         }
5612
5613         if (name && ! (PL_parser && PL_parser->error_count))
5614             process_special_blocks(name, gv, cv);
5615     }
5616
5617   done:
5618     if (PL_parser)
5619         PL_parser->copline = NOLINE;
5620     LEAVE_SCOPE(floor);
5621     return cv;
5622 }
5623
5624 STATIC void
5625 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5626                          CV *const cv)
5627 {
5628     const char *const colon = strrchr(fullname,':');
5629     const char *const name = colon ? colon + 1 : fullname;
5630
5631     if (*name == 'B') {
5632         if (strEQ(name, "BEGIN")) {
5633             const I32 oldscope = PL_scopestack_ix;
5634             ENTER;
5635             SAVECOPFILE(&PL_compiling);
5636             SAVECOPLINE(&PL_compiling);
5637
5638             DEBUG_x( dump_sub(gv) );
5639             Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5640             GvCV(gv) = 0;               /* cv has been hijacked */
5641             call_list(oldscope, PL_beginav);
5642
5643             PL_curcop = &PL_compiling;
5644             CopHINTS_set(&PL_compiling, PL_hints);
5645             LEAVE;
5646         }
5647         else
5648             return;
5649     } else {
5650         if (*name == 'E') {
5651             if strEQ(name, "END") {
5652                 DEBUG_x( dump_sub(gv) );
5653                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5654             } else
5655                 return;
5656         } else if (*name == 'U') {
5657             if (strEQ(name, "UNITCHECK")) {
5658                 /* It's never too late to run a unitcheck block */
5659                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5660             }
5661             else
5662                 return;
5663         } else if (*name == 'C') {
5664             if (strEQ(name, "CHECK")) {
5665                 if (PL_main_start && ckWARN(WARN_VOID))
5666                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5667                                 "Too late to run CHECK block");
5668                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5669             }
5670             else
5671                 return;
5672         } else if (*name == 'I') {
5673             if (strEQ(name, "INIT")) {
5674                 if (PL_main_start && ckWARN(WARN_VOID))
5675                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5676                                 "Too late to run INIT block");
5677                 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5678             }
5679             else
5680                 return;
5681         } else
5682             return;
5683         DEBUG_x( dump_sub(gv) );
5684         GvCV(gv) = 0;           /* cv has been hijacked */
5685     }
5686 }
5687
5688 /*
5689 =for apidoc newCONSTSUB
5690
5691 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5692 eligible for inlining at compile-time.
5693
5694 =cut
5695 */
5696
5697 CV *
5698 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5699 {
5700     dVAR;
5701     CV* cv;
5702 #ifdef USE_ITHREADS
5703     const char *const temp_p = CopFILE(PL_curcop);
5704     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5705 #else
5706     SV *const temp_sv = CopFILESV(PL_curcop);
5707     STRLEN len;
5708     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5709 #endif
5710     char *const file = savepvn(temp_p, temp_p ? len : 0);
5711
5712     ENTER;
5713
5714     if (IN_PERL_RUNTIME) {
5715         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5716          * an op shared between threads. Use a non-shared COP for our
5717          * dirty work */
5718          SAVEVPTR(PL_curcop);
5719          PL_curcop = &PL_compiling;
5720     }
5721     SAVECOPLINE(PL_curcop);
5722     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5723
5724     SAVEHINTS();
5725     PL_hints &= ~HINT_BLOCK_SCOPE;
5726
5727     if (stash) {
5728         SAVESPTR(PL_curstash);
5729         SAVECOPSTASH(PL_curcop);
5730         PL_curstash = stash;
5731         CopSTASH_set(PL_curcop,stash);
5732     }
5733
5734     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5735        and so doesn't get free()d.  (It's expected to be from the C pre-
5736        processor __FILE__ directive). But we need a dynamically allocated one,
5737        and we need it to get freed.  */
5738     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5739     CvXSUBANY(cv).any_ptr = sv;
5740     CvCONST_on(cv);
5741     Safefree(file);
5742
5743 #ifdef USE_ITHREADS
5744     if (stash)
5745         CopSTASH_free(PL_curcop);
5746 #endif
5747     LEAVE;
5748
5749     return cv;
5750 }
5751
5752 CV *
5753 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5754                  const char *const filename, const char *const proto,
5755                  U32 flags)
5756 {
5757     CV *cv = newXS(name, subaddr, filename);
5758
5759     if (flags & XS_DYNAMIC_FILENAME) {
5760         /* We need to "make arrangements" (ie cheat) to ensure that the
5761            filename lasts as long as the PVCV we just created, but also doesn't
5762            leak  */
5763         STRLEN filename_len = strlen(filename);
5764         STRLEN proto_and_file_len = filename_len;
5765         char *proto_and_file;
5766         STRLEN proto_len;
5767
5768         if (proto) {
5769             proto_len = strlen(proto);
5770             proto_and_file_len += proto_len;
5771
5772             Newx(proto_and_file, proto_and_file_len + 1, char);
5773             Copy(proto, proto_and_file, proto_len, char);
5774             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5775         } else {
5776             proto_len = 0;
5777             proto_and_file = savepvn(filename, filename_len);
5778         }
5779
5780         /* This gets free()d.  :-)  */
5781         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5782                         SV_HAS_TRAILING_NUL);
5783         if (proto) {
5784             /* This gives us the correct prototype, rather than one with the
5785                file name appended.  */
5786             SvCUR_set(cv, proto_len);
5787         } else {
5788             SvPOK_off(cv);
5789         }
5790         CvFILE(cv) = proto_and_file + proto_len;
5791     } else {
5792         sv_setpv((SV *)cv, proto);
5793     }
5794     return cv;
5795 }
5796
5797 /*
5798 =for apidoc U||newXS
5799
5800 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5801 static storage, as it is used directly as CvFILE(), without a copy being made.
5802
5803 =cut
5804 */
5805
5806 CV *
5807 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5808 {
5809     dVAR;
5810     GV * const gv = gv_fetchpv(name ? name :
5811                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5812                         GV_ADDMULTI, SVt_PVCV);
5813     register CV *cv;
5814
5815     if (!subaddr)
5816         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5817
5818     if ((cv = (name ? GvCV(gv) : NULL))) {
5819         if (GvCVGEN(gv)) {
5820             /* just a cached method */
5821             SvREFCNT_dec(cv);
5822             cv = NULL;
5823         }
5824         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5825             /* already defined (or promised) */
5826             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5827             if (ckWARN(WARN_REDEFINE)) {
5828                 GV * const gvcv = CvGV(cv);
5829                 if (gvcv) {
5830                     HV * const stash = GvSTASH(gvcv);
5831                     if (stash) {
5832                         const char *redefined_name = HvNAME_get(stash);
5833                         if ( strEQ(redefined_name,"autouse") ) {
5834                             const line_t oldline = CopLINE(PL_curcop);
5835                             if (PL_parser && PL_parser->copline != NOLINE)
5836                                 CopLINE_set(PL_curcop, PL_parser->copline);
5837                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5838                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5839                                                     : "Subroutine %s redefined"
5840                                         ,name);
5841                             CopLINE_set(PL_curcop, oldline);
5842                         }
5843                     }
5844                 }
5845             }
5846             SvREFCNT_dec(cv);
5847             cv = NULL;
5848         }
5849     }
5850
5851     if (cv)                             /* must reuse cv if autoloaded */
5852         cv_undef(cv);
5853     else {
5854         cv = (CV*)newSV_type(SVt_PVCV);
5855         if (name) {
5856             GvCV(gv) = cv;
5857             GvCVGEN(gv) = 0;
5858             mro_method_changed_in(GvSTASH(gv)); /* newXS */
5859         }
5860     }
5861     CvGV(cv) = gv;
5862     (void)gv_fetchfile(filename);
5863     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5864                                    an external constant string */
5865     CvISXSUB_on(cv);
5866     CvXSUB(cv) = subaddr;
5867
5868     if (name)
5869         process_special_blocks(name, gv, cv);
5870     else
5871         CvANON_on(cv);
5872
5873     return cv;
5874 }
5875
5876 #ifdef PERL_MAD
5877 OP *
5878 #else
5879 void
5880 #endif
5881 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5882 {
5883     dVAR;
5884     register CV *cv;
5885 #ifdef PERL_MAD
5886     OP* pegop = newOP(OP_NULL, 0);
5887 #endif
5888
5889     GV * const gv = o
5890         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5891         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5892
5893 #ifdef GV_UNIQUE_CHECK
5894     if (GvUNIQUE(gv)) {
5895         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5896     }
5897 #endif
5898     GvMULTI_on(gv);
5899     if ((cv = GvFORM(gv))) {
5900         if (ckWARN(WARN_REDEFINE)) {
5901             const line_t oldline = CopLINE(PL_curcop);
5902             if (PL_parser && PL_parser->copline != NOLINE)
5903                 CopLINE_set(PL_curcop, PL_parser->copline);
5904             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5905                         o ? "Format %"SVf" redefined"
5906                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5907             CopLINE_set(PL_curcop, oldline);
5908         }
5909         SvREFCNT_dec(cv);
5910     }
5911     cv = PL_compcv;
5912     GvFORM(gv) = cv;
5913     CvGV(cv) = gv;
5914     CvFILE_set_from_cop(cv, PL_curcop);
5915
5916
5917     pad_tidy(padtidy_FORMAT);
5918     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5919     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5920     OpREFCNT_set(CvROOT(cv), 1);
5921     CvSTART(cv) = LINKLIST(CvROOT(cv));
5922     CvROOT(cv)->op_next = 0;
5923     CALL_PEEP(CvSTART(cv));
5924 #ifdef PERL_MAD
5925     op_getmad(o,pegop,'n');
5926     op_getmad_weak(block, pegop, 'b');
5927 #else
5928     op_free(o);
5929 #endif
5930     if (PL_parser)
5931         PL_parser->copline = NOLINE;
5932     LEAVE_SCOPE(floor);
5933 #ifdef PERL_MAD
5934     return pegop;
5935 #endif
5936 }
5937
5938 OP *
5939 Perl_newANONLIST(pTHX_ OP *o)
5940 {
5941     return convert(OP_ANONLIST, OPf_SPECIAL, o);
5942 }
5943
5944 OP *
5945 Perl_newANONHASH(pTHX_ OP *o)
5946 {
5947     return convert(OP_ANONHASH, OPf_SPECIAL, o);
5948 }
5949
5950 OP *
5951 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5952 {
5953     return newANONATTRSUB(floor, proto, NULL, block);
5954 }
5955
5956 OP *
5957 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5958 {
5959     return newUNOP(OP_REFGEN, 0,
5960         newSVOP(OP_ANONCODE, 0,
5961                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5962 }
5963
5964 OP *
5965 Perl_oopsAV(pTHX_ OP *o)
5966 {
5967     dVAR;
5968     switch (o->op_type) {
5969     case OP_PADSV:
5970         o->op_type = OP_PADAV;
5971         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5972         return ref(o, OP_RV2AV);
5973
5974     case OP_RV2SV:
5975         o->op_type = OP_RV2AV;
5976         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5977         ref(o, OP_RV2AV);
5978         break;
5979
5980     default:
5981         if (ckWARN_d(WARN_INTERNAL))
5982             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5983         break;
5984     }
5985     return o;
5986 }
5987
5988 OP *
5989 Perl_oopsHV(pTHX_ OP *o)
5990 {
5991     dVAR;
5992     switch (o->op_type) {
5993     case OP_PADSV:
5994     case OP_PADAV:
5995         o->op_type = OP_PADHV;
5996         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5997         return ref(o, OP_RV2HV);
5998
5999     case OP_RV2SV:
6000     case OP_RV2AV:
6001         o->op_type = OP_RV2HV;
6002         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6003         ref(o, OP_RV2HV);
6004         break;
6005
6006     default:
6007         if (ckWARN_d(WARN_INTERNAL))
6008             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6009         break;
6010     }
6011     return o;
6012 }
6013
6014 OP *
6015 Perl_newAVREF(pTHX_ OP *o)
6016 {
6017     dVAR;
6018     if (o->op_type == OP_PADANY) {
6019         o->op_type = OP_PADAV;
6020         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6021         return o;
6022     }
6023     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6024                 && ckWARN(WARN_DEPRECATED)) {
6025         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6026                 "Using an array as a reference is deprecated");
6027     }
6028     return newUNOP(OP_RV2AV, 0, scalar(o));
6029 }
6030
6031 OP *
6032 Perl_newGVREF(pTHX_ I32 type, OP *o)
6033 {
6034     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6035         return newUNOP(OP_NULL, 0, o);
6036     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6037 }
6038
6039 OP *
6040 Perl_newHVREF(pTHX_ OP *o)
6041 {
6042     dVAR;
6043     if (o->op_type == OP_PADANY) {
6044         o->op_type = OP_PADHV;
6045         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6046         return o;
6047     }
6048     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6049                 && ckWARN(WARN_DEPRECATED)) {
6050         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6051                 "Using a hash as a reference is deprecated");
6052     }
6053     return newUNOP(OP_RV2HV, 0, scalar(o));
6054 }
6055
6056 OP *
6057 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6058 {
6059     return newUNOP(OP_RV2CV, flags, scalar(o));
6060 }
6061
6062 OP *
6063 Perl_newSVREF(pTHX_ OP *o)
6064 {
6065     dVAR;
6066     if (o->op_type == OP_PADANY) {
6067         o->op_type = OP_PADSV;
6068         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6069         return o;
6070     }
6071     return newUNOP(OP_RV2SV, 0, scalar(o));
6072 }
6073
6074 /* Check routines. See the comments at the top of this file for details
6075  * on when these are called */
6076
6077 OP *
6078 Perl_ck_anoncode(pTHX_ OP *o)
6079 {
6080     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6081     if (!PL_madskills)
6082         cSVOPo->op_sv = NULL;
6083     return o;
6084 }
6085
6086 OP *
6087 Perl_ck_bitop(pTHX_ OP *o)
6088 {
6089     dVAR;
6090 #define OP_IS_NUMCOMPARE(op) \
6091         ((op) == OP_LT   || (op) == OP_I_LT || \
6092          (op) == OP_GT   || (op) == OP_I_GT || \
6093          (op) == OP_LE   || (op) == OP_I_LE || \
6094          (op) == OP_GE   || (op) == OP_I_GE || \
6095          (op) == OP_EQ   || (op) == OP_I_EQ || \
6096          (op) == OP_NE   || (op) == OP_I_NE || \
6097          (op) == OP_NCMP || (op) == OP_I_NCMP)
6098     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6099     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6100             && (o->op_type == OP_BIT_OR
6101              || o->op_type == OP_BIT_AND
6102              || o->op_type == OP_BIT_XOR))
6103     {
6104         const OP * const left = cBINOPo->op_first;
6105         const OP * const right = left->op_sibling;
6106         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6107                 (left->op_flags & OPf_PARENS) == 0) ||
6108             (OP_IS_NUMCOMPARE(right->op_type) &&
6109                 (right->op_flags & OPf_PARENS) == 0))
6110             if (ckWARN(WARN_PRECEDENCE))
6111                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6112                         "Possible precedence problem on bitwise %c operator",
6113                         o->op_type == OP_BIT_OR ? '|'
6114                             : o->op_type == OP_BIT_AND ? '&' : '^'
6115                         );
6116     }
6117     return o;
6118 }
6119
6120 OP *
6121 Perl_ck_concat(pTHX_ OP *o)
6122 {
6123     const OP * const kid = cUNOPo->op_first;
6124     PERL_UNUSED_CONTEXT;
6125     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6126             !(kUNOP->op_first->op_flags & OPf_MOD))
6127         o->op_flags |= OPf_STACKED;
6128     return o;
6129 }
6130
6131 OP *
6132 Perl_ck_spair(pTHX_ OP *o)
6133 {
6134     dVAR;
6135     if (o->op_flags & OPf_KIDS) {
6136         OP* newop;
6137         OP* kid;
6138         const OPCODE type = o->op_type;
6139         o = modkids(ck_fun(o), type);
6140         kid = cUNOPo->op_first;
6141         newop = kUNOP->op_first->op_sibling;
6142         if (newop) {
6143             const OPCODE type = newop->op_type;
6144             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6145                     type == OP_PADAV || type == OP_PADHV ||
6146                     type == OP_RV2AV || type == OP_RV2HV)
6147                 return o;
6148         }
6149 #ifdef PERL_MAD
6150         op_getmad(kUNOP->op_first,newop,'K');
6151 #else
6152         op_free(kUNOP->op_first);
6153 #endif
6154         kUNOP->op_first = newop;
6155     }
6156     o->op_ppaddr = PL_ppaddr[++o->op_type];
6157     return ck_fun(o);
6158 }
6159
6160 OP *
6161 Perl_ck_delete(pTHX_ OP *o)
6162 {
6163     o = ck_fun(o);
6164     o->op_private = 0;
6165     if (o->op_flags & OPf_KIDS) {
6166         OP * const kid = cUNOPo->op_first;
6167         switch (kid->op_type) {
6168         case OP_ASLICE:
6169             o->op_flags |= OPf_SPECIAL;
6170             /* FALL THROUGH */
6171         case OP_HSLICE:
6172             o->op_private |= OPpSLICE;
6173             break;
6174         case OP_AELEM:
6175             o->op_flags |= OPf_SPECIAL;
6176             /* FALL THROUGH */
6177         case OP_HELEM:
6178             break;
6179         default:
6180             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6181                   OP_DESC(o));
6182         }
6183         op_null(kid);
6184     }
6185     return o;
6186 }
6187
6188 OP *
6189 Perl_ck_die(pTHX_ OP *o)
6190 {
6191 #ifdef VMS
6192     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6193 #endif
6194     return ck_fun(o);
6195 }
6196
6197 OP *
6198 Perl_ck_eof(pTHX_ OP *o)
6199 {
6200     dVAR;
6201
6202     if (o->op_flags & OPf_KIDS) {
6203         if (cLISTOPo->op_first->op_type == OP_STUB) {
6204             OP * const newop
6205                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6206 #ifdef PERL_MAD
6207             op_getmad(o,newop,'O');
6208 #else
6209             op_free(o);
6210 #endif
6211             o = newop;
6212         }
6213         return ck_fun(o);
6214     }
6215     return o;
6216 }
6217
6218 OP *
6219 Perl_ck_eval(pTHX_ OP *o)
6220 {
6221     dVAR;
6222     PL_hints |= HINT_BLOCK_SCOPE;
6223     if (o->op_flags & OPf_KIDS) {
6224         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6225
6226         if (!kid) {
6227             o->op_flags &= ~OPf_KIDS;
6228             op_null(o);
6229         }
6230         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6231             LOGOP *enter;
6232 #ifdef PERL_MAD
6233             OP* const oldo = o;
6234 #endif
6235
6236             cUNOPo->op_first = 0;
6237 #ifndef PERL_MAD
6238             op_free(o);
6239 #endif
6240
6241             NewOp(1101, enter, 1, LOGOP);
6242             enter->op_type = OP_ENTERTRY;
6243             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6244             enter->op_private = 0;
6245
6246             /* establish postfix order */
6247             enter->op_next = (OP*)enter;
6248
6249             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6250             o->op_type = OP_LEAVETRY;
6251             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6252             enter->op_other = o;
6253             op_getmad(oldo,o,'O');
6254             return o;
6255         }
6256         else {
6257             scalar((OP*)kid);
6258             PL_cv_has_eval = 1;
6259         }
6260     }
6261     else {
6262 #ifdef PERL_MAD
6263         OP* const oldo = o;
6264 #else
6265         op_free(o);
6266 #endif
6267         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6268         op_getmad(oldo,o,'O');
6269     }
6270     o->op_targ = (PADOFFSET)PL_hints;
6271     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6272         /* Store a copy of %^H that pp_entereval can pick up.
6273            OPf_SPECIAL flags the opcode as being for this purpose,
6274            so that it in turn will return a copy at every
6275            eval.*/
6276         OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6277                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6278         cUNOPo->op_first->op_sibling = hhop;
6279         o->op_private |= OPpEVAL_HAS_HH;
6280     }
6281     return o;
6282 }
6283
6284 OP *
6285 Perl_ck_exit(pTHX_ OP *o)
6286 {
6287 #ifdef VMS
6288     HV * const table = GvHV(PL_hintgv);
6289     if (table) {
6290        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6291        if (svp && *svp && SvTRUE(*svp))
6292            o->op_private |= OPpEXIT_VMSISH;
6293     }
6294     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6295 #endif
6296     return ck_fun(o);
6297 }
6298
6299 OP *
6300 Perl_ck_exec(pTHX_ OP *o)
6301 {
6302     if (o->op_flags & OPf_STACKED) {
6303         OP *kid;
6304         o = ck_fun(o);
6305         kid = cUNOPo->op_first->op_sibling;
6306         if (kid->op_type == OP_RV2GV)
6307             op_null(kid);
6308     }
6309     else
6310         o = listkids(o);
6311     return o;
6312 }
6313
6314 OP *
6315 Perl_ck_exists(pTHX_ OP *o)
6316 {
6317     dVAR;
6318     o = ck_fun(o);
6319     if (o->op_flags & OPf_KIDS) {
6320         OP * const kid = cUNOPo->op_first;
6321         if (kid->op_type == OP_ENTERSUB) {
6322             (void) ref(kid, o->op_type);
6323             if (kid->op_type != OP_RV2CV
6324                         && !(PL_parser && PL_parser->error_count))
6325                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6326                             OP_DESC(o));
6327             o->op_private |= OPpEXISTS_SUB;
6328         }
6329         else if (kid->op_type == OP_AELEM)
6330             o->op_flags |= OPf_SPECIAL;
6331         else if (kid->op_type != OP_HELEM)
6332             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6333                         OP_DESC(o));
6334         op_null(kid);
6335     }
6336     return o;
6337 }
6338
6339 OP *
6340 Perl_ck_rvconst(pTHX_ register OP *o)
6341 {
6342     dVAR;
6343     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6344
6345     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6346     if (o->op_type == OP_RV2CV)
6347         o->op_private &= ~1;
6348
6349     if (kid->op_type == OP_CONST) {
6350         int iscv;
6351         GV *gv;
6352         SV * const kidsv = kid->op_sv;
6353
6354         /* Is it a constant from cv_const_sv()? */
6355         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6356             SV * const rsv = SvRV(kidsv);
6357             const svtype type = SvTYPE(rsv);
6358             const char *badtype = NULL;
6359
6360             switch (o->op_type) {
6361             case OP_RV2SV:
6362                 if (type > SVt_PVMG)
6363                     badtype = "a SCALAR";
6364                 break;
6365             case OP_RV2AV:
6366                 if (type != SVt_PVAV)
6367                     badtype = "an ARRAY";
6368                 break;
6369             case OP_RV2HV:
6370                 if (type != SVt_PVHV)
6371                     badtype = "a HASH";
6372                 break;
6373             case OP_RV2CV:
6374                 if (type != SVt_PVCV)
6375                     badtype = "a CODE";
6376                 break;
6377             }
6378             if (badtype)
6379                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6380             return o;
6381         }
6382         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6383                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6384             /* If this is an access to a stash, disable "strict refs", because
6385              * stashes aren't auto-vivified at compile-time (unless we store
6386              * symbols in them), and we don't want to produce a run-time
6387              * stricture error when auto-vivifying the stash. */
6388             const char *s = SvPV_nolen(kidsv);
6389             const STRLEN l = SvCUR(kidsv);
6390             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6391                 o->op_private &= ~HINT_STRICT_REFS;
6392         }
6393         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6394             const char *badthing;
6395             switch (o->op_type) {
6396             case OP_RV2SV:
6397                 badthing = "a SCALAR";
6398                 break;
6399             case OP_RV2AV:
6400                 badthing = "an ARRAY";
6401                 break;
6402             case OP_RV2HV:
6403                 badthing = "a HASH";
6404                 break;
6405             default:
6406                 badthing = NULL;
6407                 break;
6408             }
6409             if (badthing)
6410                 Perl_croak(aTHX_
6411                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6412                            SVfARG(kidsv), badthing);
6413         }
6414         /*
6415          * This is a little tricky.  We only want to add the symbol if we
6416          * didn't add it in the lexer.  Otherwise we get duplicate strict
6417          * warnings.  But if we didn't add it in the lexer, we must at
6418          * least pretend like we wanted to add it even if it existed before,
6419          * or we get possible typo warnings.  OPpCONST_ENTERED says
6420          * whether the lexer already added THIS instance of this symbol.
6421          */
6422         iscv = (o->op_type == OP_RV2CV) * 2;
6423         do {
6424             gv = gv_fetchsv(kidsv,
6425                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6426                 iscv
6427                     ? SVt_PVCV
6428                     : o->op_type == OP_RV2SV
6429                         ? SVt_PV
6430                         : o->op_type == OP_RV2AV
6431                             ? SVt_PVAV
6432                             : o->op_type == OP_RV2HV
6433                                 ? SVt_PVHV
6434                                 : SVt_PVGV);
6435         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6436         if (gv) {
6437             kid->op_type = OP_GV;
6438             SvREFCNT_dec(kid->op_sv);
6439 #ifdef USE_ITHREADS
6440             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6441             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6442             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6443             GvIN_PAD_on(gv);
6444             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6445 #else
6446             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6447 #endif
6448             kid->op_private = 0;
6449             kid->op_ppaddr = PL_ppaddr[OP_GV];
6450         }
6451     }
6452     return o;
6453 }
6454
6455 OP *
6456 Perl_ck_ftst(pTHX_ OP *o)
6457 {
6458     dVAR;
6459     const I32 type = o->op_type;
6460
6461     if (o->op_flags & OPf_REF) {
6462         NOOP;
6463     }
6464     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6465         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6466         const OPCODE kidtype = kid->op_type;
6467
6468         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6469             OP * const newop = newGVOP(type, OPf_REF,
6470                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6471 #ifdef PERL_MAD
6472             op_getmad(o,newop,'O');
6473 #else
6474             op_free(o);
6475 #endif
6476             return newop;
6477         }
6478         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6479             o->op_private |= OPpFT_ACCESS;
6480         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6481                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6482             o->op_private |= OPpFT_STACKED;
6483     }
6484     else {
6485 #ifdef PERL_MAD
6486         OP* const oldo = o;
6487 #else
6488         op_free(o);
6489 #endif
6490         if (type == OP_FTTTY)
6491             o = newGVOP(type, OPf_REF, PL_stdingv);
6492         else
6493             o = newUNOP(type, 0, newDEFSVOP());
6494         op_getmad(oldo,o,'O');
6495     }
6496     return o;
6497 }
6498
6499 OP *
6500 Perl_ck_fun(pTHX_ OP *o)
6501 {
6502     dVAR;
6503     const int type = o->op_type;
6504     register I32 oa = PL_opargs[type] >> OASHIFT;
6505
6506     if (o->op_flags & OPf_STACKED) {
6507         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6508             oa &= ~OA_OPTIONAL;
6509         else
6510             return no_fh_allowed(o);
6511     }
6512
6513     if (o->op_flags & OPf_KIDS) {
6514         OP **tokid = &cLISTOPo->op_first;
6515         register OP *kid = cLISTOPo->op_first;
6516         OP *sibl;
6517         I32 numargs = 0;
6518
6519         if (kid->op_type == OP_PUSHMARK ||
6520             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6521         {
6522             tokid = &kid->op_sibling;
6523             kid = kid->op_sibling;
6524         }
6525         if (!kid && PL_opargs[type] & OA_DEFGV)
6526             *tokid = kid = newDEFSVOP();
6527
6528         while (oa && kid) {
6529             numargs++;
6530             sibl = kid->op_sibling;
6531 #ifdef PERL_MAD
6532             if (!sibl && kid->op_type == OP_STUB) {
6533                 numargs--;
6534                 break;
6535             }
6536 #endif
6537             switch (oa & 7) {
6538             case OA_SCALAR:
6539                 /* list seen where single (scalar) arg expected? */
6540                 if (numargs == 1 && !(oa >> 4)
6541                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6542                 {
6543                     return too_many_arguments(o,PL_op_desc[type]);
6544                 }
6545                 scalar(kid);
6546                 break;
6547             case OA_LIST:
6548                 if (oa < 16) {
6549                     kid = 0;
6550                     continue;
6551                 }
6552                 else
6553                     list(kid);
6554                 break;
6555             case OA_AVREF:
6556                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6557                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6558                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6559                         "Useless use of %s with no values",
6560                         PL_op_desc[type]);
6561
6562                 if (kid->op_type == OP_CONST &&
6563                     (kid->op_private & OPpCONST_BARE))
6564                 {
6565                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6566                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6567                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6568                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6569                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6570                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6571 #ifdef PERL_MAD
6572                     op_getmad(kid,newop,'K');
6573 #else
6574                     op_free(kid);
6575 #endif
6576                     kid = newop;
6577                     kid->op_sibling = sibl;
6578                     *tokid = kid;
6579                 }
6580                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6581                     bad_type(numargs, "array", PL_op_desc[type], kid);
6582                 mod(kid, type);
6583                 break;
6584             case OA_HVREF:
6585                 if (kid->op_type == OP_CONST &&
6586                     (kid->op_private & OPpCONST_BARE))
6587                 {
6588                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6589                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6590                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6591                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6592                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6593                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6594 #ifdef PERL_MAD
6595                     op_getmad(kid,newop,'K');
6596 #else
6597                     op_free(kid);
6598 #endif
6599                     kid = newop;
6600                     kid->op_sibling = sibl;
6601                     *tokid = kid;
6602                 }
6603                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6604                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6605                 mod(kid, type);
6606                 break;
6607             case OA_CVREF:
6608                 {
6609                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6610                     kid->op_sibling = 0;
6611                     linklist(kid);
6612                     newop->op_next = newop;
6613                     kid = newop;
6614                     kid->op_sibling = sibl;
6615                     *tokid = kid;
6616                 }
6617                 break;
6618             case OA_FILEREF:
6619                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6620                     if (kid->op_type == OP_CONST &&
6621                         (kid->op_private & OPpCONST_BARE))
6622                     {
6623                         OP * const newop = newGVOP(OP_GV, 0,
6624                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6625                         if (!(o->op_private & 1) && /* if not unop */
6626                             kid == cLISTOPo->op_last)
6627                             cLISTOPo->op_last = newop;
6628 #ifdef PERL_MAD
6629                         op_getmad(kid,newop,'K');
6630 #else
6631                         op_free(kid);
6632 #endif
6633                         kid = newop;
6634                     }
6635                     else if (kid->op_type == OP_READLINE) {
6636                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6637                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6638                     }
6639                     else {
6640                         I32 flags = OPf_SPECIAL;
6641                         I32 priv = 0;
6642                         PADOFFSET targ = 0;
6643
6644                         /* is this op a FH constructor? */
6645                         if (is_handle_constructor(o,numargs)) {
6646                             const char *name = NULL;
6647                             STRLEN len = 0;
6648
6649                             flags = 0;
6650                             /* Set a flag to tell rv2gv to vivify
6651                              * need to "prove" flag does not mean something
6652                              * else already - NI-S 1999/05/07
6653                              */
6654                             priv = OPpDEREF;
6655                             if (kid->op_type == OP_PADSV) {
6656                                 SV *const namesv
6657                                     = PAD_COMPNAME_SV(kid->op_targ);
6658                                 name = SvPV_const(namesv, len);
6659                             }
6660                             else if (kid->op_type == OP_RV2SV
6661                                      && kUNOP->op_first->op_type == OP_GV)
6662                             {
6663                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6664                                 name = GvNAME(gv);
6665                                 len = GvNAMELEN(gv);
6666                             }
6667                             else if (kid->op_type == OP_AELEM
6668                                      || kid->op_type == OP_HELEM)
6669                             {
6670                                  OP *firstop;
6671                                  OP *op = ((BINOP*)kid)->op_first;
6672                                  name = NULL;
6673                                  if (op) {
6674                                       SV *tmpstr = NULL;
6675                                       const char * const a =
6676                                            kid->op_type == OP_AELEM ?
6677                                            "[]" : "{}";
6678                                       if (((op->op_type == OP_RV2AV) ||
6679                                            (op->op_type == OP_RV2HV)) &&
6680                                           (firstop = ((UNOP*)op)->op_first) &&
6681                                           (firstop->op_type == OP_GV)) {
6682                                            /* packagevar $a[] or $h{} */
6683                                            GV * const gv = cGVOPx_gv(firstop);
6684                                            if (gv)
6685                                                 tmpstr =
6686                                                      Perl_newSVpvf(aTHX_
6687                                                                    "%s%c...%c",
6688                                                                    GvNAME(gv),
6689                                                                    a[0], a[1]);
6690                                       }
6691                                       else if (op->op_type == OP_PADAV
6692                                                || op->op_type == OP_PADHV) {
6693                                            /* lexicalvar $a[] or $h{} */
6694                                            const char * const padname =
6695                                                 PAD_COMPNAME_PV(op->op_targ);
6696                                            if (padname)
6697                                                 tmpstr =
6698                                                      Perl_newSVpvf(aTHX_
6699                                                                    "%s%c...%c",
6700                                                                    padname + 1,
6701                                                                    a[0], a[1]);
6702                                       }
6703                                       if (tmpstr) {
6704                                            name = SvPV_const(tmpstr, len);
6705                                            sv_2mortal(tmpstr);
6706                                       }
6707                                  }
6708                                  if (!name) {
6709                                       name = "__ANONIO__";
6710                                       len = 10;
6711                                  }
6712                                  mod(kid, type);
6713                             }
6714                             if (name) {
6715                                 SV *namesv;
6716                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6717                                 namesv = PAD_SVl(targ);
6718                                 SvUPGRADE(namesv, SVt_PV);
6719                                 if (*name != '$')
6720                                     sv_setpvn(namesv, "$", 1);
6721                                 sv_catpvn(namesv, name, len);
6722                             }
6723                         }
6724                         kid->op_sibling = 0;
6725                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6726                         kid->op_targ = targ;
6727                         kid->op_private |= priv;
6728                     }
6729                     kid->op_sibling = sibl;
6730                     *tokid = kid;
6731                 }
6732                 scalar(kid);
6733                 break;
6734             case OA_SCALARREF:
6735                 mod(scalar(kid), type);
6736                 break;
6737             }
6738             oa >>= 4;
6739             tokid = &kid->op_sibling;
6740             kid = kid->op_sibling;
6741         }
6742 #ifdef PERL_MAD
6743         if (kid && kid->op_type != OP_STUB)
6744             return too_many_arguments(o,OP_DESC(o));
6745         o->op_private |= numargs;
6746 #else
6747         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6748         o->op_private |= numargs;
6749         if (kid)
6750             return too_many_arguments(o,OP_DESC(o));
6751 #endif
6752         listkids(o);
6753     }
6754     else if (PL_opargs[type] & OA_DEFGV) {
6755 #ifdef PERL_MAD
6756         OP *newop = newUNOP(type, 0, newDEFSVOP());
6757         op_getmad(o,newop,'O');
6758         return newop;
6759 #else
6760         /* Ordering of these two is important to keep f_map.t passing.  */
6761         op_free(o);
6762         return newUNOP(type, 0, newDEFSVOP());
6763 #endif
6764     }
6765
6766     if (oa) {
6767         while (oa & OA_OPTIONAL)
6768             oa >>= 4;
6769         if (oa && oa != OA_LIST)
6770             return too_few_arguments(o,OP_DESC(o));
6771     }
6772     return o;
6773 }
6774
6775 OP *
6776 Perl_ck_glob(pTHX_ OP *o)
6777 {
6778     dVAR;
6779     GV *gv;
6780
6781     o = ck_fun(o);
6782     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6783         append_elem(OP_GLOB, o, newDEFSVOP());
6784
6785     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6786           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6787     {
6788         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6789     }
6790
6791 #if !defined(PERL_EXTERNAL_GLOB)
6792     /* XXX this can be tightened up and made more failsafe. */
6793     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6794         GV *glob_gv;
6795         ENTER;
6796         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6797                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6798         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6799         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6800         GvCV(gv) = GvCV(glob_gv);
6801         SvREFCNT_inc_void((SV*)GvCV(gv));
6802         GvIMPORTED_CV_on(gv);
6803         LEAVE;
6804     }
6805 #endif /* PERL_EXTERNAL_GLOB */
6806
6807     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6808         append_elem(OP_GLOB, o,
6809                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6810         o->op_type = OP_LIST;
6811         o->op_ppaddr = PL_ppaddr[OP_LIST];
6812         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6813         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6814         cLISTOPo->op_first->op_targ = 0;
6815         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6816                     append_elem(OP_LIST, o,
6817                                 scalar(newUNOP(OP_RV2CV, 0,
6818                                                newGVOP(OP_GV, 0, gv)))));
6819         o = newUNOP(OP_NULL, 0, ck_subr(o));
6820         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6821         return o;
6822     }
6823     gv = newGVgen("main");
6824     gv_IOadd(gv);
6825     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6826     scalarkids(o);
6827     return o;
6828 }
6829
6830 OP *
6831 Perl_ck_grep(pTHX_ OP *o)
6832 {
6833     dVAR;
6834     LOGOP *gwop = NULL;
6835     OP *kid;
6836     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6837     PADOFFSET offset;
6838
6839     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6840     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6841
6842     if (o->op_flags & OPf_STACKED) {
6843         OP* k;
6844         o = ck_sort(o);
6845         kid = cLISTOPo->op_first->op_sibling;
6846         if (!cUNOPx(kid)->op_next)
6847             Perl_croak(aTHX_ "panic: ck_grep");
6848         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6849             kid = k;
6850         }
6851         NewOp(1101, gwop, 1, LOGOP);
6852         kid->op_next = (OP*)gwop;
6853         o->op_flags &= ~OPf_STACKED;
6854     }
6855     kid = cLISTOPo->op_first->op_sibling;
6856     if (type == OP_MAPWHILE)
6857         list(kid);
6858     else
6859         scalar(kid);
6860     o = ck_fun(o);
6861     if (PL_parser && PL_parser->error_count)
6862         return o;
6863     kid = cLISTOPo->op_first->op_sibling;
6864     if (kid->op_type != OP_NULL)
6865         Perl_croak(aTHX_ "panic: ck_grep");
6866     kid = kUNOP->op_first;
6867
6868     if (!gwop)
6869         NewOp(1101, gwop, 1, LOGOP);
6870     gwop->op_type = type;
6871     gwop->op_ppaddr = PL_ppaddr[type];
6872     gwop->op_first = listkids(o);
6873     gwop->op_flags |= OPf_KIDS;
6874     gwop->op_other = LINKLIST(kid);
6875     kid->op_next = (OP*)gwop;
6876     offset = pad_findmy("$_");
6877     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6878         o->op_private = gwop->op_private = 0;
6879         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6880     }
6881     else {
6882         o->op_private = gwop->op_private = OPpGREP_LEX;
6883         gwop->op_targ = o->op_targ = offset;
6884     }
6885
6886     kid = cLISTOPo->op_first->op_sibling;
6887     if (!kid || !kid->op_sibling)
6888         return too_few_arguments(o,OP_DESC(o));
6889     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6890         mod(kid, OP_GREPSTART);
6891
6892     return (OP*)gwop;
6893 }
6894
6895 OP *
6896 Perl_ck_index(pTHX_ OP *o)
6897 {
6898     if (o->op_flags & OPf_KIDS) {
6899         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6900         if (kid)
6901             kid = kid->op_sibling;                      /* get past "big" */
6902         if (kid && kid->op_type == OP_CONST)
6903             fbm_compile(((SVOP*)kid)->op_sv, 0);
6904     }
6905     return ck_fun(o);
6906 }
6907
6908 OP *
6909 Perl_ck_lengthconst(pTHX_ OP *o)
6910 {
6911     /* XXX length optimization goes here */
6912     return ck_fun(o);
6913 }
6914
6915 OP *
6916 Perl_ck_lfun(pTHX_ OP *o)
6917 {
6918     const OPCODE type = o->op_type;
6919     return modkids(ck_fun(o), type);
6920 }
6921
6922 OP *
6923 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6924 {
6925     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6926         switch (cUNOPo->op_first->op_type) {
6927         case OP_RV2AV:
6928             /* This is needed for
6929                if (defined %stash::)
6930                to work.   Do not break Tk.
6931                */
6932             break;                      /* Globals via GV can be undef */
6933         case OP_PADAV:
6934         case OP_AASSIGN:                /* Is this a good idea? */
6935             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6936                         "defined(@array) is deprecated");
6937             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6938                         "\t(Maybe you should just omit the defined()?)\n");
6939         break;
6940         case OP_RV2HV:
6941             /* This is needed for
6942                if (defined %stash::)
6943                to work.   Do not break Tk.
6944                */
6945             break;                      /* Globals via GV can be undef */
6946         case OP_PADHV:
6947             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6948                         "defined(%%hash) is deprecated");
6949             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6950                         "\t(Maybe you should just omit the defined()?)\n");
6951             break;
6952         default:
6953             /* no warning */
6954             break;
6955         }
6956     }
6957     return ck_rfun(o);
6958 }
6959
6960 OP *
6961 Perl_ck_readline(pTHX_ OP *o)
6962 {
6963     if (!(o->op_flags & OPf_KIDS)) {
6964         OP * const newop
6965             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6966 #ifdef PERL_MAD
6967         op_getmad(o,newop,'O');
6968 #else
6969         op_free(o);
6970 #endif
6971         return newop;
6972     }
6973     return o;
6974 }
6975
6976 OP *
6977 Perl_ck_rfun(pTHX_ OP *o)
6978 {
6979     const OPCODE type = o->op_type;
6980     return refkids(ck_fun(o), type);
6981 }
6982
6983 OP *
6984 Perl_ck_listiob(pTHX_ OP *o)
6985 {
6986     register OP *kid;
6987
6988     kid = cLISTOPo->op_first;
6989     if (!kid) {
6990         o = force_list(o);
6991         kid = cLISTOPo->op_first;
6992     }
6993     if (kid->op_type == OP_PUSHMARK)
6994         kid = kid->op_sibling;
6995     if (kid && o->op_flags & OPf_STACKED)
6996         kid = kid->op_sibling;
6997     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6998         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6999             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7000             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7001             cLISTOPo->op_first->op_sibling = kid;
7002             cLISTOPo->op_last = kid;
7003             kid = kid->op_sibling;
7004         }
7005     }
7006
7007     if (!kid)
7008         append_elem(o->op_type, o, newDEFSVOP());
7009
7010     return listkids(o);
7011 }
7012
7013 OP *
7014 Perl_ck_smartmatch(pTHX_ OP *o)
7015 {
7016     dVAR;
7017     if (0 == (o->op_flags & OPf_SPECIAL)) {
7018         OP *first  = cBINOPo->op_first;
7019         OP *second = first->op_sibling;
7020
7021         /* Implicitly take a reference to an array or hash */
7022         first->op_sibling = NULL;
7023         first = cBINOPo->op_first = ref_array_or_hash(first);
7024         second = first->op_sibling = ref_array_or_hash(second);
7025
7026         /* Implicitly take a reference to a regular expression */
7027         if (first->op_type == OP_MATCH) {
7028             first->op_type = OP_QR;
7029             first->op_ppaddr = PL_ppaddr[OP_QR];
7030         }
7031         if (second->op_type == OP_MATCH) {
7032             second->op_type = OP_QR;
7033             second->op_ppaddr = PL_ppaddr[OP_QR];
7034         }
7035     }
7036
7037     return o;
7038 }
7039
7040
7041 OP *
7042 Perl_ck_sassign(pTHX_ OP *o)
7043 {
7044     dVAR;
7045     OP * const kid = cLISTOPo->op_first;
7046     /* has a disposable target? */
7047     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7048         && !(kid->op_flags & OPf_STACKED)
7049         /* Cannot steal the second time! */
7050         && !(kid->op_private & OPpTARGET_MY)
7051         /* Keep the full thing for madskills */
7052         && !PL_madskills
7053         )
7054     {
7055         OP * const kkid = kid->op_sibling;
7056
7057         /* Can just relocate the target. */
7058         if (kkid && kkid->op_type == OP_PADSV
7059             && !(kkid->op_private & OPpLVAL_INTRO))
7060         {
7061             kid->op_targ = kkid->op_targ;
7062             kkid->op_targ = 0;
7063             /* Now we do not need PADSV and SASSIGN. */
7064             kid->op_sibling = o->op_sibling;    /* NULL */
7065             cLISTOPo->op_first = NULL;
7066             op_free(o);
7067             op_free(kkid);
7068             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7069             return kid;
7070         }
7071     }
7072     if (kid->op_sibling) {
7073         OP *kkid = kid->op_sibling;
7074         if (kkid->op_type == OP_PADSV
7075                 && (kkid->op_private & OPpLVAL_INTRO)
7076                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7077             const PADOFFSET target = kkid->op_targ;
7078             OP *const other = newOP(OP_PADSV,
7079                                     kkid->op_flags
7080                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7081             OP *const first = newOP(OP_NULL, 0);
7082             OP *const nullop = newCONDOP(0, first, o, other);
7083             OP *const condop = first->op_next;
7084             /* hijacking PADSTALE for uninitialized state variables */
7085             SvPADSTALE_on(PAD_SVl(target));
7086
7087             condop->op_type = OP_ONCE;
7088             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7089             condop->op_targ = target;
7090             other->op_targ = target;
7091
7092             /* Because we change the type of the op here, we will skip the
7093                assinment binop->op_last = binop->op_first->op_sibling; at the
7094                end of Perl_newBINOP(). So need to do it here. */
7095             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7096
7097             return nullop;
7098         }
7099     }
7100     return o;
7101 }
7102
7103 OP *
7104 Perl_ck_match(pTHX_ OP *o)
7105 {
7106     dVAR;
7107     if (o->op_type != OP_QR && PL_compcv) {
7108         const PADOFFSET offset = pad_findmy("$_");
7109         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7110             o->op_targ = offset;
7111             o->op_private |= OPpTARGET_MY;
7112         }
7113     }
7114     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7115         o->op_private |= OPpRUNTIME;
7116     return o;
7117 }
7118
7119 OP *
7120 Perl_ck_method(pTHX_ OP *o)
7121 {
7122     OP * const kid = cUNOPo->op_first;
7123     if (kid->op_type == OP_CONST) {
7124         SV* sv = kSVOP->op_sv;
7125         const char * const method = SvPVX_const(sv);
7126         if (!(strchr(method, ':') || strchr(method, '\''))) {
7127             OP *cmop;
7128             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7129                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7130             }
7131             else {
7132                 kSVOP->op_sv = NULL;
7133             }
7134             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7135 #ifdef PERL_MAD
7136             op_getmad(o,cmop,'O');
7137 #else
7138             op_free(o);
7139 #endif
7140             return cmop;
7141         }
7142     }
7143     return o;
7144 }
7145
7146 OP *
7147 Perl_ck_null(pTHX_ OP *o)
7148 {
7149     PERL_UNUSED_CONTEXT;
7150     return o;
7151 }
7152
7153 OP *
7154 Perl_ck_open(pTHX_ OP *o)
7155 {
7156     dVAR;
7157     HV * const table = GvHV(PL_hintgv);
7158     if (table) {
7159         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7160         if (svp && *svp) {
7161             const I32 mode = mode_from_discipline(*svp);
7162             if (mode & O_BINARY)
7163                 o->op_private |= OPpOPEN_IN_RAW;
7164             else if (mode & O_TEXT)
7165                 o->op_private |= OPpOPEN_IN_CRLF;
7166         }
7167
7168         svp = hv_fetchs(table, "open_OUT", FALSE);
7169         if (svp && *svp) {
7170             const I32 mode = mode_from_discipline(*svp);
7171             if (mode & O_BINARY)
7172                 o->op_private |= OPpOPEN_OUT_RAW;
7173             else if (mode & O_TEXT)
7174                 o->op_private |= OPpOPEN_OUT_CRLF;
7175         }
7176     }
7177     if (o->op_type == OP_BACKTICK) {
7178         if (!(o->op_flags & OPf_KIDS)) {
7179             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7180 #ifdef PERL_MAD
7181             op_getmad(o,newop,'O');
7182 #else
7183             op_free(o);
7184 #endif
7185             return newop;
7186         }
7187         return o;
7188     }
7189     {
7190          /* In case of three-arg dup open remove strictness
7191           * from the last arg if it is a bareword. */
7192          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7193          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7194          OP *oa;
7195          const char *mode;
7196
7197          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7198              (last->op_private & OPpCONST_BARE) &&
7199              (last->op_private & OPpCONST_STRICT) &&
7200              (oa = first->op_sibling) &&                /* The fh. */
7201              (oa = oa->op_sibling) &&                   /* The mode. */
7202              (oa->op_type == OP_CONST) &&
7203              SvPOK(((SVOP*)oa)->op_sv) &&
7204              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7205              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7206              (last == oa->op_sibling))                  /* The bareword. */
7207               last->op_private &= ~OPpCONST_STRICT;
7208     }
7209     return ck_fun(o);
7210 }
7211
7212 OP *
7213 Perl_ck_repeat(pTHX_ OP *o)
7214 {
7215     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7216         o->op_private |= OPpREPEAT_DOLIST;
7217         cBINOPo->op_first = force_list(cBINOPo->op_first);
7218     }
7219     else
7220         scalar(o);
7221     return o;
7222 }
7223
7224 OP *
7225 Perl_ck_require(pTHX_ OP *o)
7226 {
7227     dVAR;
7228     GV* gv = NULL;
7229
7230     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7231         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7232
7233         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7234             SV * const sv = kid->op_sv;
7235             U32 was_readonly = SvREADONLY(sv);
7236             char *s;
7237             STRLEN len;
7238             const char *end;
7239
7240             if (was_readonly) {
7241                 if (SvFAKE(sv)) {
7242                     sv_force_normal_flags(sv, 0);
7243                     assert(!SvREADONLY(sv));
7244                     was_readonly = 0;
7245                 } else {
7246                     SvREADONLY_off(sv);
7247                 }
7248             }
7249
7250             s = SvPVX(sv);
7251             len = SvCUR(sv);
7252             end = s + len;
7253             for (; s < end; s++) {
7254                 if (*s == ':' && s[1] == ':') {
7255                     *s = '/';
7256                     Move(s+2, s+1, end - s - 1, char);
7257                     --end;
7258                 }
7259             }
7260             SvEND_set(sv, end);
7261             sv_catpvs(sv, ".pm");
7262             SvFLAGS(sv) |= was_readonly;
7263         }
7264     }
7265
7266     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7267         /* handle override, if any */
7268         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7269         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7270             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7271             gv = gvp ? *gvp : NULL;
7272         }
7273     }
7274
7275     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7276         OP * const kid = cUNOPo->op_first;
7277         OP * newop;
7278
7279         cUNOPo->op_first = 0;
7280 #ifndef PERL_MAD
7281         op_free(o);
7282 #endif
7283         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7284                                 append_elem(OP_LIST, kid,
7285                                             scalar(newUNOP(OP_RV2CV, 0,
7286                                                            newGVOP(OP_GV, 0,
7287                                                                    gv))))));
7288         op_getmad(o,newop,'O');
7289         return newop;
7290     }
7291
7292     return ck_fun(o);
7293 }
7294
7295 OP *
7296 Perl_ck_return(pTHX_ OP *o)
7297 {
7298     dVAR;
7299     if (CvLVALUE(PL_compcv)) {
7300         OP *kid;
7301         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7302             mod(kid, OP_LEAVESUBLV);
7303     }
7304     return o;
7305 }
7306
7307 OP *
7308 Perl_ck_select(pTHX_ OP *o)
7309 {
7310     dVAR;
7311     OP* kid;
7312     if (o->op_flags & OPf_KIDS) {
7313         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7314         if (kid && kid->op_sibling) {
7315             o->op_type = OP_SSELECT;
7316             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7317             o = ck_fun(o);
7318             return fold_constants(o);
7319         }
7320     }
7321     o = ck_fun(o);
7322     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7323     if (kid && kid->op_type == OP_RV2GV)
7324         kid->op_private &= ~HINT_STRICT_REFS;
7325     return o;
7326 }
7327
7328 OP *
7329 Perl_ck_shift(pTHX_ OP *o)
7330 {
7331     dVAR;
7332     const I32 type = o->op_type;
7333
7334     if (!(o->op_flags & OPf_KIDS)) {
7335         OP *argop;
7336         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7337 #ifdef PERL_MAD
7338         OP * const oldo = o;
7339 #else
7340         op_free(o);
7341 #endif
7342         argop = newUNOP(OP_RV2AV, 0,
7343             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7344 #ifdef PERL_MAD
7345         o = newUNOP(type, 0, scalar(argop));
7346         op_getmad(oldo,o,'O');
7347         return o;
7348 #else
7349         return newUNOP(type, 0, scalar(argop));
7350 #endif
7351     }
7352     return scalar(modkids(ck_fun(o), type));
7353 }
7354
7355 OP *
7356 Perl_ck_sort(pTHX_ OP *o)
7357 {
7358     dVAR;
7359     OP *firstkid;
7360
7361     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7362         HV * const hinthv = GvHV(PL_hintgv);
7363         if (hinthv) {
7364             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7365             if (svp) {
7366                 const I32 sorthints = (I32)SvIV(*svp);
7367                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7368                     o->op_private |= OPpSORT_QSORT;
7369                 if ((sorthints & HINT_SORT_STABLE) != 0)
7370                     o->op_private |= OPpSORT_STABLE;
7371             }
7372         }
7373     }
7374
7375     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7376         simplify_sort(o);
7377     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7378     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7379         OP *k = NULL;
7380         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7381
7382         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7383             linklist(kid);
7384             if (kid->op_type == OP_SCOPE) {
7385                 k = kid->op_next;
7386                 kid->op_next = 0;
7387             }
7388             else if (kid->op_type == OP_LEAVE) {
7389                 if (o->op_type == OP_SORT) {
7390                     op_null(kid);                       /* wipe out leave */
7391                     kid->op_next = kid;
7392
7393                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7394                         if (k->op_next == kid)
7395                             k->op_next = 0;
7396                         /* don't descend into loops */
7397                         else if (k->op_type == OP_ENTERLOOP
7398                                  || k->op_type == OP_ENTERITER)
7399                         {
7400                             k = cLOOPx(k)->op_lastop;
7401                         }
7402                     }
7403                 }
7404                 else
7405                     kid->op_next = 0;           /* just disconnect the leave */
7406                 k = kLISTOP->op_first;
7407             }
7408             CALL_PEEP(k);
7409
7410             kid = firstkid;
7411             if (o->op_type == OP_SORT) {
7412                 /* provide scalar context for comparison function/block */
7413                 kid = scalar(kid);
7414                 kid->op_next = kid;
7415             }
7416             else
7417                 kid->op_next = k;
7418             o->op_flags |= OPf_SPECIAL;
7419         }
7420         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7421             op_null(firstkid);
7422
7423         firstkid = firstkid->op_sibling;
7424     }
7425
7426     /* provide list context for arguments */
7427     if (o->op_type == OP_SORT)
7428         list(firstkid);
7429
7430     return o;
7431 }
7432
7433 STATIC void
7434 S_simplify_sort(pTHX_ OP *o)
7435 {
7436     dVAR;
7437     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7438     OP *k;
7439     int descending;
7440     GV *gv;
7441     const char *gvname;
7442     if (!(o->op_flags & OPf_STACKED))
7443         return;
7444     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7445     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7446     kid = kUNOP->op_first;                              /* get past null */
7447     if (kid->op_type != OP_SCOPE)
7448         return;
7449     kid = kLISTOP->op_last;                             /* get past scope */
7450     switch(kid->op_type) {
7451         case OP_NCMP:
7452         case OP_I_NCMP:
7453         case OP_SCMP:
7454             break;
7455         default:
7456             return;
7457     }
7458     k = kid;                                            /* remember this node*/
7459     if (kBINOP->op_first->op_type != OP_RV2SV)
7460         return;
7461     kid = kBINOP->op_first;                             /* get past cmp */
7462     if (kUNOP->op_first->op_type != OP_GV)
7463         return;
7464     kid = kUNOP->op_first;                              /* get past rv2sv */
7465     gv = kGVOP_gv;
7466     if (GvSTASH(gv) != PL_curstash)
7467         return;
7468     gvname = GvNAME(gv);
7469     if (*gvname == 'a' && gvname[1] == '\0')
7470         descending = 0;
7471     else if (*gvname == 'b' && gvname[1] == '\0')
7472         descending = 1;
7473     else
7474         return;
7475
7476     kid = k;                                            /* back to cmp */
7477     if (kBINOP->op_last->op_type != OP_RV2SV)
7478         return;
7479     kid = kBINOP->op_last;                              /* down to 2nd arg */
7480     if (kUNOP->op_first->op_type != OP_GV)
7481         return;
7482     kid = kUNOP->op_first;                              /* get past rv2sv */
7483     gv = kGVOP_gv;
7484     if (GvSTASH(gv) != PL_curstash)
7485         return;
7486     gvname = GvNAME(gv);
7487     if ( descending
7488          ? !(*gvname == 'a' && gvname[1] == '\0')
7489          : !(*gvname == 'b' && gvname[1] == '\0'))
7490         return;
7491     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7492     if (descending)
7493         o->op_private |= OPpSORT_DESCEND;
7494     if (k->op_type == OP_NCMP)
7495         o->op_private |= OPpSORT_NUMERIC;
7496     if (k->op_type == OP_I_NCMP)
7497         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7498     kid = cLISTOPo->op_first->op_sibling;
7499     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7500 #ifdef PERL_MAD
7501     op_getmad(kid,o,'S');                             /* then delete it */
7502 #else
7503     op_free(kid);                                     /* then delete it */
7504 #endif
7505 }
7506
7507 OP *
7508 Perl_ck_split(pTHX_ OP *o)
7509 {
7510     dVAR;
7511     register OP *kid;
7512
7513     if (o->op_flags & OPf_STACKED)
7514         return no_fh_allowed(o);
7515
7516     kid = cLISTOPo->op_first;
7517     if (kid->op_type != OP_NULL)
7518         Perl_croak(aTHX_ "panic: ck_split");
7519     kid = kid->op_sibling;
7520     op_free(cLISTOPo->op_first);
7521     cLISTOPo->op_first = kid;
7522     if (!kid) {
7523         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7524         cLISTOPo->op_last = kid; /* There was only one element previously */
7525     }
7526
7527     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7528         OP * const sibl = kid->op_sibling;
7529         kid->op_sibling = 0;
7530         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7531         if (cLISTOPo->op_first == cLISTOPo->op_last)
7532             cLISTOPo->op_last = kid;
7533         cLISTOPo->op_first = kid;
7534         kid->op_sibling = sibl;
7535     }
7536
7537     kid->op_type = OP_PUSHRE;
7538     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7539     scalar(kid);
7540     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7541       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7542                   "Use of /g modifier is meaningless in split");
7543     }
7544
7545     if (!kid->op_sibling)
7546         append_elem(OP_SPLIT, o, newDEFSVOP());
7547
7548     kid = kid->op_sibling;
7549     scalar(kid);
7550
7551     if (!kid->op_sibling)
7552         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7553     assert(kid->op_sibling);
7554
7555     kid = kid->op_sibling;
7556     scalar(kid);
7557
7558     if (kid->op_sibling)
7559         return too_many_arguments(o,OP_DESC(o));
7560
7561     return o;
7562 }
7563
7564 OP *
7565 Perl_ck_join(pTHX_ OP *o)
7566 {
7567     const OP * const kid = cLISTOPo->op_first->op_sibling;
7568     if (kid && kid->op_type == OP_MATCH) {
7569         if (ckWARN(WARN_SYNTAX)) {
7570             const REGEXP *re = PM_GETRE(kPMOP);
7571             const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7572             const STRLEN len = re ? RX_PRELEN(re) : 6;
7573             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7574                         "/%.*s/ should probably be written as \"%.*s\"",
7575                         (int)len, pmstr, (int)len, pmstr);
7576         }
7577     }
7578     return ck_fun(o);
7579 }
7580
7581 OP *
7582 Perl_ck_subr(pTHX_ OP *o)
7583 {
7584     dVAR;
7585     OP *prev = ((cUNOPo->op_first->op_sibling)
7586              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7587     OP *o2 = prev->op_sibling;
7588     OP *cvop;
7589     const char *proto = NULL;
7590     const char *proto_end = NULL;
7591     CV *cv = NULL;
7592     GV *namegv = NULL;
7593     int optional = 0;
7594     I32 arg = 0;
7595     I32 contextclass = 0;
7596     const char *e = NULL;
7597     bool delete_op = 0;
7598
7599     o->op_private |= OPpENTERSUB_HASTARG;
7600     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7601     if (cvop->op_type == OP_RV2CV) {
7602         SVOP* tmpop;
7603         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7604         op_null(cvop);          /* disable rv2cv */
7605         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7606         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7607             GV *gv = cGVOPx_gv(tmpop);
7608             cv = GvCVu(gv);
7609             if (!cv)
7610                 tmpop->op_private |= OPpEARLY_CV;
7611             else {
7612                 if (SvPOK(cv)) {
7613                     STRLEN len;
7614                     namegv = CvANON(cv) ? gv : CvGV(cv);
7615                     proto = SvPV((SV*)cv, len);
7616                     proto_end = proto + len;
7617                 }
7618             }
7619         }
7620     }
7621     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7622         if (o2->op_type == OP_CONST)
7623             o2->op_private &= ~OPpCONST_STRICT;
7624         else if (o2->op_type == OP_LIST) {
7625             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7626             if (sib && sib->op_type == OP_CONST)
7627                 sib->op_private &= ~OPpCONST_STRICT;
7628         }
7629     }
7630     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7631     if (PERLDB_SUB && PL_curstash != PL_debstash)
7632         o->op_private |= OPpENTERSUB_DB;
7633     while (o2 != cvop) {
7634         OP* o3;
7635         if (PL_madskills && o2->op_type == OP_STUB) {
7636             o2 = o2->op_sibling;
7637             continue;
7638         }
7639         if (PL_madskills && o2->op_type == OP_NULL)
7640             o3 = ((UNOP*)o2)->op_first;
7641         else
7642             o3 = o2;
7643         if (proto) {
7644             if (proto >= proto_end)
7645                 return too_many_arguments(o, gv_ename(namegv));
7646
7647             switch (*proto) {
7648             case ';':
7649                 optional = 1;
7650                 proto++;
7651                 continue;
7652             case '_':
7653                 /* _ must be at the end */
7654                 if (proto[1] && proto[1] != ';')
7655                     goto oops;
7656             case '$':
7657                 proto++;
7658                 arg++;
7659                 scalar(o2);
7660                 break;
7661             case '%':
7662             case '@':
7663                 list(o2);
7664                 arg++;
7665                 break;
7666             case '&':
7667                 proto++;
7668                 arg++;
7669                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7670                     bad_type(arg,
7671                         arg == 1 ? "block or sub {}" : "sub {}",
7672                         gv_ename(namegv), o3);
7673                 break;
7674             case '*':
7675                 /* '*' allows any scalar type, including bareword */
7676                 proto++;
7677                 arg++;
7678                 if (o3->op_type == OP_RV2GV)
7679                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7680                 else if (o3->op_type == OP_CONST)
7681                     o3->op_private &= ~OPpCONST_STRICT;
7682                 else if (o3->op_type == OP_ENTERSUB) {
7683                     /* accidental subroutine, revert to bareword */
7684                     OP *gvop = ((UNOP*)o3)->op_first;
7685                     if (gvop && gvop->op_type == OP_NULL) {
7686                         gvop = ((UNOP*)gvop)->op_first;
7687                         if (gvop) {
7688                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7689                                 ;
7690                             if (gvop &&
7691                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7692                                 (gvop = ((UNOP*)gvop)->op_first) &&
7693                                 gvop->op_type == OP_GV)
7694                             {
7695                                 GV * const gv = cGVOPx_gv(gvop);
7696                                 OP * const sibling = o2->op_sibling;
7697                                 SV * const n = newSVpvs("");
7698 #ifdef PERL_MAD
7699                                 OP * const oldo2 = o2;
7700 #else
7701                                 op_free(o2);
7702 #endif
7703                                 gv_fullname4(n, gv, "", FALSE);
7704                                 o2 = newSVOP(OP_CONST, 0, n);
7705                                 op_getmad(oldo2,o2,'O');
7706                                 prev->op_sibling = o2;
7707                                 o2->op_sibling = sibling;
7708                             }
7709                         }
7710                     }
7711                 }
7712                 scalar(o2);
7713                 break;
7714             case '[': case ']':
7715                  goto oops;
7716                  break;
7717             case '\\':
7718                 proto++;
7719                 arg++;
7720             again:
7721                 switch (*proto++) {
7722                 case '[':
7723                      if (contextclass++ == 0) {
7724                           e = strchr(proto, ']');
7725                           if (!e || e == proto)
7726                                goto oops;
7727                      }
7728                      else
7729                           goto oops;
7730                      goto again;
7731                      break;
7732                 case ']':
7733                      if (contextclass) {
7734                          const char *p = proto;
7735                          const char *const end = proto;
7736                          contextclass = 0;
7737                          while (*--p != '[');
7738                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7739                                                  (int)(end - p), p),
7740                                   gv_ename(namegv), o3);
7741                      } else
7742                           goto oops;
7743                      break;
7744                 case '*':
7745                      if (o3->op_type == OP_RV2GV)
7746                           goto wrapref;
7747                      if (!contextclass)
7748                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7749                      break;
7750                 case '&':
7751                      if (o3->op_type == OP_ENTERSUB)
7752                           goto wrapref;
7753                      if (!contextclass)
7754                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7755                                    o3);
7756                      break;
7757                 case '$':
7758                     if (o3->op_type == OP_RV2SV ||
7759                         o3->op_type == OP_PADSV ||
7760                         o3->op_type == OP_HELEM ||
7761                         o3->op_type == OP_AELEM)
7762                          goto wrapref;
7763                     if (!contextclass)
7764                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7765                      break;
7766                 case '@':
7767                     if (o3->op_type == OP_RV2AV ||
7768                         o3->op_type == OP_PADAV)
7769                          goto wrapref;
7770                     if (!contextclass)
7771                         bad_type(arg, "array", gv_ename(namegv), o3);
7772                     break;
7773                 case '%':
7774                     if (o3->op_type == OP_RV2HV ||
7775                         o3->op_type == OP_PADHV)
7776                          goto wrapref;
7777                     if (!contextclass)
7778                          bad_type(arg, "hash", gv_ename(namegv), o3);
7779                     break;
7780                 wrapref:
7781                     {
7782                         OP* const kid = o2;
7783                         OP* const sib = kid->op_sibling;
7784                         kid->op_sibling = 0;
7785                         o2 = newUNOP(OP_REFGEN, 0, kid);
7786                         o2->op_sibling = sib;
7787                         prev->op_sibling = o2;
7788                     }
7789                     if (contextclass && e) {
7790                          proto = e + 1;
7791                          contextclass = 0;
7792                     }
7793                     break;
7794                 default: goto oops;
7795                 }
7796                 if (contextclass)
7797                      goto again;
7798                 break;
7799             case ' ':
7800                 proto++;
7801                 continue;
7802             default:
7803               oops:
7804                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7805                            gv_ename(namegv), SVfARG(cv));
7806             }
7807         }
7808         else
7809             list(o2);
7810         mod(o2, OP_ENTERSUB);
7811         prev = o2;
7812         o2 = o2->op_sibling;
7813     } /* while */
7814     if (o2 == cvop && proto && *proto == '_') {
7815         /* generate an access to $_ */
7816         o2 = newDEFSVOP();
7817         o2->op_sibling = prev->op_sibling;
7818         prev->op_sibling = o2; /* instead of cvop */
7819     }
7820     if (proto && !optional && proto_end > proto &&
7821         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7822         return too_few_arguments(o, gv_ename(namegv));
7823     if(delete_op) {
7824 #ifdef PERL_MAD
7825         OP * const oldo = o;
7826 #else
7827         op_free(o);
7828 #endif
7829         o=newSVOP(OP_CONST, 0, newSViv(0));
7830         op_getmad(oldo,o,'O');
7831     }
7832     return o;
7833 }
7834
7835 OP *
7836 Perl_ck_svconst(pTHX_ OP *o)
7837 {
7838     PERL_UNUSED_CONTEXT;
7839     SvREADONLY_on(cSVOPo->op_sv);
7840     return o;
7841 }
7842
7843 OP *
7844 Perl_ck_chdir(pTHX_ OP *o)
7845 {
7846     if (o->op_flags & OPf_KIDS) {
7847         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7848
7849         if (kid && kid->op_type == OP_CONST &&
7850             (kid->op_private & OPpCONST_BARE))
7851         {
7852             o->op_flags |= OPf_SPECIAL;
7853             kid->op_private &= ~OPpCONST_STRICT;
7854         }
7855     }
7856     return ck_fun(o);
7857 }
7858
7859 OP *
7860 Perl_ck_trunc(pTHX_ OP *o)
7861 {
7862     if (o->op_flags & OPf_KIDS) {
7863         SVOP *kid = (SVOP*)cUNOPo->op_first;
7864
7865         if (kid->op_type == OP_NULL)
7866             kid = (SVOP*)kid->op_sibling;
7867         if (kid && kid->op_type == OP_CONST &&
7868             (kid->op_private & OPpCONST_BARE))
7869         {
7870             o->op_flags |= OPf_SPECIAL;
7871             kid->op_private &= ~OPpCONST_STRICT;
7872         }
7873     }
7874     return ck_fun(o);
7875 }
7876
7877 OP *
7878 Perl_ck_unpack(pTHX_ OP *o)
7879 {
7880     OP *kid = cLISTOPo->op_first;
7881     if (kid->op_sibling) {
7882         kid = kid->op_sibling;
7883         if (!kid->op_sibling)
7884             kid->op_sibling = newDEFSVOP();
7885     }
7886     return ck_fun(o);
7887 }
7888
7889 OP *
7890 Perl_ck_substr(pTHX_ OP *o)
7891 {
7892     o = ck_fun(o);
7893     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7894         OP *kid = cLISTOPo->op_first;
7895
7896         if (kid->op_type == OP_NULL)
7897             kid = kid->op_sibling;
7898         if (kid)
7899             kid->op_flags |= OPf_MOD;
7900
7901     }
7902     return o;
7903 }
7904
7905 OP *
7906 Perl_ck_each(pTHX_ OP *o)
7907 {
7908     dVAR;
7909     OP *kid = cLISTOPo->op_first;
7910
7911     if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7912         const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7913             : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7914         o->op_type = new_type;
7915         o->op_ppaddr = PL_ppaddr[new_type];
7916     }
7917     else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7918                || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7919                )) {
7920         bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7921         return o;
7922     }
7923     return ck_fun(o);
7924 }
7925
7926 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7927  * See the comments at the top of this file for more details about when
7928  * peep() is called */
7929
7930 void
7931 Perl_peep(pTHX_ register OP *o)
7932 {
7933     dVAR;
7934     register OP* oldop = NULL;
7935
7936     if (!o || o->op_opt)
7937         return;
7938     ENTER;
7939     SAVEOP();
7940     SAVEVPTR(PL_curcop);
7941     for (; o; o = o->op_next) {
7942         if (o->op_opt)
7943             break;
7944         /* By default, this op has now been optimised. A couple of cases below
7945            clear this again.  */
7946         o->op_opt = 1;
7947         PL_op = o;
7948         switch (o->op_type) {
7949         case OP_SETSTATE:
7950         case OP_NEXTSTATE:
7951         case OP_DBSTATE:
7952             PL_curcop = ((COP*)o);              /* for warnings */
7953             break;
7954
7955         case OP_CONST:
7956             if (cSVOPo->op_private & OPpCONST_STRICT)
7957                 no_bareword_allowed(o);
7958 #ifdef USE_ITHREADS
7959         case OP_METHOD_NAMED:
7960             /* Relocate sv to the pad for thread safety.
7961              * Despite being a "constant", the SV is written to,
7962              * for reference counts, sv_upgrade() etc. */
7963             if (cSVOP->op_sv) {
7964                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7965                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7966                     /* If op_sv is already a PADTMP then it is being used by
7967                      * some pad, so make a copy. */
7968                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7969                     SvREADONLY_on(PAD_SVl(ix));
7970                     SvREFCNT_dec(cSVOPo->op_sv);
7971                 }
7972                 else if (o->op_type == OP_CONST
7973                          && cSVOPo->op_sv == &PL_sv_undef) {
7974                     /* PL_sv_undef is hack - it's unsafe to store it in the
7975                        AV that is the pad, because av_fetch treats values of
7976                        PL_sv_undef as a "free" AV entry and will merrily
7977                        replace them with a new SV, causing pad_alloc to think
7978                        that this pad slot is free. (When, clearly, it is not)
7979                     */
7980                     SvOK_off(PAD_SVl(ix));
7981                     SvPADTMP_on(PAD_SVl(ix));
7982                     SvREADONLY_on(PAD_SVl(ix));
7983                 }
7984                 else {
7985                     SvREFCNT_dec(PAD_SVl(ix));
7986                     SvPADTMP_on(cSVOPo->op_sv);
7987                     PAD_SETSV(ix, cSVOPo->op_sv);
7988                     /* XXX I don't know how this isn't readonly already. */
7989                     SvREADONLY_on(PAD_SVl(ix));
7990                 }
7991                 cSVOPo->op_sv = NULL;
7992                 o->op_targ = ix;
7993             }
7994 #endif
7995             break;
7996
7997         case OP_CONCAT:
7998             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7999                 if (o->op_next->op_private & OPpTARGET_MY) {
8000                     if (o->op_flags & OPf_STACKED) /* chained concats */
8001                         break; /* ignore_optimization */
8002                     else {
8003                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8004                         o->op_targ = o->op_next->op_targ;
8005                         o->op_next->op_targ = 0;
8006                         o->op_private |= OPpTARGET_MY;
8007                     }
8008                 }
8009                 op_null(o->op_next);
8010             }
8011             break;
8012         case OP_STUB:
8013             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8014                 break; /* Scalar stub must produce undef.  List stub is noop */
8015             }
8016             goto nothin;
8017         case OP_NULL:
8018             if (o->op_targ == OP_NEXTSTATE
8019                 || o->op_targ == OP_DBSTATE
8020                 || o->op_targ == OP_SETSTATE)
8021             {
8022                 PL_curcop = ((COP*)o);
8023             }
8024             /* XXX: We avoid setting op_seq here to prevent later calls
8025                to peep() from mistakenly concluding that optimisation
8026                has already occurred. This doesn't fix the real problem,
8027                though (See 20010220.007). AMS 20010719 */
8028             /* op_seq functionality is now replaced by op_opt */
8029             o->op_opt = 0;
8030             /* FALL THROUGH */
8031         case OP_SCALAR:
8032         case OP_LINESEQ:
8033         case OP_SCOPE:
8034         nothin:
8035             if (oldop && o->op_next) {
8036                 oldop->op_next = o->op_next;
8037                 o->op_opt = 0;
8038                 continue;
8039             }
8040             break;
8041
8042         case OP_PADAV:
8043         case OP_GV:
8044             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8045                 OP* const pop = (o->op_type == OP_PADAV) ?
8046                             o->op_next : o->op_next->op_next;
8047                 IV i;
8048                 if (pop && pop->op_type == OP_CONST &&
8049                     ((PL_op = pop->op_next)) &&
8050                     pop->op_next->op_type == OP_AELEM &&
8051                     !(pop->op_next->op_private &
8052                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8053                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8054                                 <= 255 &&
8055                     i >= 0)
8056                 {
8057                     GV *gv;
8058                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8059                         no_bareword_allowed(pop);
8060                     if (o->op_type == OP_GV)
8061                         op_null(o->op_next);
8062                     op_null(pop->op_next);
8063                     op_null(pop);
8064                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8065                     o->op_next = pop->op_next->op_next;
8066                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8067                     o->op_private = (U8)i;
8068                     if (o->op_type == OP_GV) {
8069                         gv = cGVOPo_gv;
8070                         GvAVn(gv);
8071                     }
8072                     else
8073                         o->op_flags |= OPf_SPECIAL;
8074                     o->op_type = OP_AELEMFAST;
8075                 }
8076                 break;
8077             }
8078
8079             if (o->op_next->op_type == OP_RV2SV) {
8080                 if (!(o->op_next->op_private & OPpDEREF)) {
8081                     op_null(o->op_next);
8082                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8083                                                                | OPpOUR_INTRO);
8084                     o->op_next = o->op_next->op_next;
8085                     o->op_type = OP_GVSV;
8086                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8087                 }
8088             }
8089             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8090                 GV * const gv = cGVOPo_gv;
8091                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8092                     /* XXX could check prototype here instead of just carping */
8093                     SV * const sv = sv_newmortal();
8094                     gv_efullname3(sv, gv, NULL);
8095                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8096                                 "%"SVf"() called too early to check prototype",
8097                                 SVfARG(sv));
8098                 }
8099             }
8100             else if (o->op_next->op_type == OP_READLINE
8101                     && o->op_next->op_next->op_type == OP_CONCAT
8102                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8103             {
8104                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8105                 o->op_type   = OP_RCATLINE;
8106                 o->op_flags |= OPf_STACKED;
8107                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8108                 op_null(o->op_next->op_next);
8109                 op_null(o->op_next);
8110             }
8111
8112             break;
8113
8114         case OP_MAPWHILE:
8115         case OP_GREPWHILE:
8116         case OP_AND:
8117         case OP_OR:
8118         case OP_DOR:
8119         case OP_ANDASSIGN:
8120         case OP_ORASSIGN:
8121         case OP_DORASSIGN:
8122         case OP_COND_EXPR:
8123         case OP_RANGE:
8124         case OP_ONCE:
8125             while (cLOGOP->op_other->op_type == OP_NULL)
8126                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8127             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8128             break;
8129
8130         case OP_ENTERLOOP:
8131         case OP_ENTERITER:
8132             while (cLOOP->op_redoop->op_type == OP_NULL)
8133                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8134             peep(cLOOP->op_redoop);
8135             while (cLOOP->op_nextop->op_type == OP_NULL)
8136                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8137             peep(cLOOP->op_nextop);
8138             while (cLOOP->op_lastop->op_type == OP_NULL)
8139                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8140             peep(cLOOP->op_lastop);
8141             break;
8142
8143         case OP_SUBST:
8144             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8145             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8146                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8147                 cPMOP->op_pmstashstartu.op_pmreplstart
8148                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8149             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8150             break;
8151
8152         case OP_EXEC:
8153             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8154                 && ckWARN(WARN_SYNTAX))
8155             {
8156                 if (o->op_next->op_sibling) {
8157                     const OPCODE type = o->op_next->op_sibling->op_type;
8158                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8159                         const line_t oldline = CopLINE(PL_curcop);
8160                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8161                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8162                                     "Statement unlikely to be reached");
8163                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8164                                     "\t(Maybe you meant system() when you said exec()?)\n");
8165                         CopLINE_set(PL_curcop, oldline);
8166                     }
8167                 }
8168             }
8169             break;
8170
8171         case OP_HELEM: {
8172             UNOP *rop;
8173             SV *lexname;
8174             GV **fields;
8175             SV **svp, *sv;
8176             const char *key = NULL;
8177             STRLEN keylen;
8178
8179             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8180                 break;
8181
8182             /* Make the CONST have a shared SV */
8183             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8184             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8185                 key = SvPV_const(sv, keylen);
8186                 lexname = newSVpvn_share(key,
8187                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8188                                          0);
8189                 SvREFCNT_dec(sv);
8190                 *svp = lexname;
8191             }
8192
8193             if ((o->op_private & (OPpLVAL_INTRO)))
8194                 break;
8195
8196             rop = (UNOP*)((BINOP*)o)->op_first;
8197             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8198                 break;
8199             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8200             if (!SvPAD_TYPED(lexname))
8201                 break;
8202             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8203             if (!fields || !GvHV(*fields))
8204                 break;
8205             key = SvPV_const(*svp, keylen);
8206             if (!hv_fetch(GvHV(*fields), key,
8207                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8208             {
8209                 Perl_croak(aTHX_ "No such class field \"%s\" "
8210                            "in variable %s of type %s",
8211                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8212             }
8213
8214             break;
8215         }
8216
8217         case OP_HSLICE: {
8218             UNOP *rop;
8219             SV *lexname;
8220             GV **fields;
8221             SV **svp;
8222             const char *key;
8223             STRLEN keylen;
8224             SVOP *first_key_op, *key_op;
8225
8226             if ((o->op_private & (OPpLVAL_INTRO))
8227                 /* I bet there's always a pushmark... */
8228                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8229                 /* hmmm, no optimization if list contains only one key. */
8230                 break;
8231             rop = (UNOP*)((LISTOP*)o)->op_last;
8232             if (rop->op_type != OP_RV2HV)
8233                 break;
8234             if (rop->op_first->op_type == OP_PADSV)
8235                 /* @$hash{qw(keys here)} */
8236                 rop = (UNOP*)rop->op_first;
8237             else {
8238                 /* @{$hash}{qw(keys here)} */
8239                 if (rop->op_first->op_type == OP_SCOPE
8240                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8241                 {
8242                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8243                 }
8244                 else
8245                     break;
8246             }
8247
8248             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8249             if (!SvPAD_TYPED(lexname))
8250                 break;
8251             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8252             if (!fields || !GvHV(*fields))
8253                 break;
8254             /* Again guessing that the pushmark can be jumped over.... */
8255             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8256                 ->op_first->op_sibling;
8257             for (key_op = first_key_op; key_op;
8258                  key_op = (SVOP*)key_op->op_sibling) {
8259                 if (key_op->op_type != OP_CONST)
8260                     continue;
8261                 svp = cSVOPx_svp(key_op);
8262                 key = SvPV_const(*svp, keylen);
8263                 if (!hv_fetch(GvHV(*fields), key,
8264                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8265                 {
8266                     Perl_croak(aTHX_ "No such class field \"%s\" "
8267                                "in variable %s of type %s",
8268                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8269                 }
8270             }
8271             break;
8272         }
8273
8274         case OP_SORT: {
8275             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8276             OP *oleft;
8277             OP *o2;
8278
8279             /* check that RHS of sort is a single plain array */
8280             OP *oright = cUNOPo->op_first;
8281             if (!oright || oright->op_type != OP_PUSHMARK)
8282                 break;
8283
8284             /* reverse sort ... can be optimised.  */
8285             if (!cUNOPo->op_sibling) {
8286                 /* Nothing follows us on the list. */
8287                 OP * const reverse = o->op_next;
8288
8289                 if (reverse->op_type == OP_REVERSE &&
8290                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8291                     OP * const pushmark = cUNOPx(reverse)->op_first;
8292                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8293                         && (cUNOPx(pushmark)->op_sibling == o)) {
8294                         /* reverse -> pushmark -> sort */
8295                         o->op_private |= OPpSORT_REVERSE;
8296                         op_null(reverse);
8297                         pushmark->op_next = oright->op_next;
8298                         op_null(oright);
8299                     }
8300                 }
8301             }
8302
8303             /* make @a = sort @a act in-place */
8304
8305             oright = cUNOPx(oright)->op_sibling;
8306             if (!oright)
8307                 break;
8308             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8309                 oright = cUNOPx(oright)->op_sibling;
8310             }
8311
8312             if (!oright ||
8313                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8314                 || oright->op_next != o
8315                 || (oright->op_private & OPpLVAL_INTRO)
8316             )
8317                 break;
8318
8319             /* o2 follows the chain of op_nexts through the LHS of the
8320              * assign (if any) to the aassign op itself */
8321             o2 = o->op_next;
8322             if (!o2 || o2->op_type != OP_NULL)
8323                 break;
8324             o2 = o2->op_next;
8325             if (!o2 || o2->op_type != OP_PUSHMARK)
8326                 break;
8327             o2 = o2->op_next;
8328             if (o2 && o2->op_type == OP_GV)
8329                 o2 = o2->op_next;
8330             if (!o2
8331                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8332                 || (o2->op_private & OPpLVAL_INTRO)
8333             )
8334                 break;
8335             oleft = o2;
8336             o2 = o2->op_next;
8337             if (!o2 || o2->op_type != OP_NULL)
8338                 break;
8339             o2 = o2->op_next;
8340             if (!o2 || o2->op_type != OP_AASSIGN
8341                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8342                 break;
8343
8344             /* check that the sort is the first arg on RHS of assign */
8345
8346             o2 = cUNOPx(o2)->op_first;
8347             if (!o2 || o2->op_type != OP_NULL)
8348                 break;
8349             o2 = cUNOPx(o2)->op_first;
8350             if (!o2 || o2->op_type != OP_PUSHMARK)
8351                 break;
8352             if (o2->op_sibling != o)
8353                 break;
8354
8355             /* check the array is the same on both sides */
8356             if (oleft->op_type == OP_RV2AV) {
8357                 if (oright->op_type != OP_RV2AV
8358                     || !cUNOPx(oright)->op_first
8359                     || cUNOPx(oright)->op_first->op_type != OP_GV
8360                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8361                         cGVOPx_gv(cUNOPx(oright)->op_first)
8362                 )
8363                     break;
8364             }
8365             else if (oright->op_type != OP_PADAV
8366                 || oright->op_targ != oleft->op_targ
8367             )
8368                 break;
8369
8370             /* transfer MODishness etc from LHS arg to RHS arg */
8371             oright->op_flags = oleft->op_flags;
8372             o->op_private |= OPpSORT_INPLACE;
8373
8374             /* excise push->gv->rv2av->null->aassign */
8375             o2 = o->op_next->op_next;
8376             op_null(o2); /* PUSHMARK */
8377             o2 = o2->op_next;
8378             if (o2->op_type == OP_GV) {
8379                 op_null(o2); /* GV */
8380                 o2 = o2->op_next;
8381             }
8382             op_null(o2); /* RV2AV or PADAV */
8383             o2 = o2->op_next->op_next;
8384             op_null(o2); /* AASSIGN */
8385
8386             o->op_next = o2->op_next;
8387
8388             break;
8389         }
8390
8391         case OP_REVERSE: {
8392             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8393             OP *gvop = NULL;
8394             LISTOP *enter, *exlist;
8395
8396             enter = (LISTOP *) o->op_next;
8397             if (!enter)
8398                 break;
8399             if (enter->op_type == OP_NULL) {
8400                 enter = (LISTOP *) enter->op_next;
8401                 if (!enter)
8402                     break;
8403             }
8404             /* for $a (...) will have OP_GV then OP_RV2GV here.
8405                for (...) just has an OP_GV.  */
8406             if (enter->op_type == OP_GV) {
8407                 gvop = (OP *) enter;
8408                 enter = (LISTOP *) enter->op_next;
8409                 if (!enter)
8410                     break;
8411                 if (enter->op_type == OP_RV2GV) {
8412                   enter = (LISTOP *) enter->op_next;
8413                   if (!enter)
8414                     break;
8415                 }
8416             }
8417
8418             if (enter->op_type != OP_ENTERITER)
8419                 break;
8420
8421             iter = enter->op_next;
8422             if (!iter || iter->op_type != OP_ITER)
8423                 break;
8424
8425             expushmark = enter->op_first;
8426             if (!expushmark || expushmark->op_type != OP_NULL
8427                 || expushmark->op_targ != OP_PUSHMARK)
8428                 break;
8429
8430             exlist = (LISTOP *) expushmark->op_sibling;
8431             if (!exlist || exlist->op_type != OP_NULL
8432                 || exlist->op_targ != OP_LIST)
8433                 break;
8434
8435             if (exlist->op_last != o) {
8436                 /* Mmm. Was expecting to point back to this op.  */
8437                 break;
8438             }
8439             theirmark = exlist->op_first;
8440             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8441                 break;
8442
8443             if (theirmark->op_sibling != o) {
8444                 /* There's something between the mark and the reverse, eg
8445                    for (1, reverse (...))
8446                    so no go.  */
8447                 break;
8448             }
8449
8450             ourmark = ((LISTOP *)o)->op_first;
8451             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8452                 break;
8453
8454             ourlast = ((LISTOP *)o)->op_last;
8455             if (!ourlast || ourlast->op_next != o)
8456                 break;
8457
8458             rv2av = ourmark->op_sibling;
8459             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8460                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8461                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8462                 /* We're just reversing a single array.  */
8463                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8464                 enter->op_flags |= OPf_STACKED;
8465             }
8466
8467             /* We don't have control over who points to theirmark, so sacrifice
8468                ours.  */
8469             theirmark->op_next = ourmark->op_next;
8470             theirmark->op_flags = ourmark->op_flags;
8471             ourlast->op_next = gvop ? gvop : (OP *) enter;
8472             op_null(ourmark);
8473             op_null(o);
8474             enter->op_private |= OPpITER_REVERSED;
8475             iter->op_private |= OPpITER_REVERSED;
8476
8477             break;
8478         }
8479
8480         case OP_SASSIGN: {
8481             OP *rv2gv;
8482             UNOP *refgen, *rv2cv;
8483             LISTOP *exlist;
8484
8485             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8486                 break;
8487
8488             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8489                 break;
8490
8491             rv2gv = ((BINOP *)o)->op_last;
8492             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8493                 break;
8494
8495             refgen = (UNOP *)((BINOP *)o)->op_first;
8496
8497             if (!refgen || refgen->op_type != OP_REFGEN)
8498                 break;
8499
8500             exlist = (LISTOP *)refgen->op_first;
8501             if (!exlist || exlist->op_type != OP_NULL
8502                 || exlist->op_targ != OP_LIST)
8503                 break;
8504
8505             if (exlist->op_first->op_type != OP_PUSHMARK)
8506                 break;
8507
8508             rv2cv = (UNOP*)exlist->op_last;
8509
8510             if (rv2cv->op_type != OP_RV2CV)
8511                 break;
8512
8513             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8514             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8515             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8516
8517             o->op_private |= OPpASSIGN_CV_TO_GV;
8518             rv2gv->op_private |= OPpDONT_INIT_GV;
8519             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8520
8521             break;
8522         }
8523
8524
8525         case OP_QR:
8526         case OP_MATCH:
8527             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8528                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8529             }
8530             break;
8531         }
8532         oldop = o;
8533     }
8534     LEAVE;
8535 }
8536
8537 const char*
8538 Perl_custom_op_name(pTHX_ const OP* o)
8539 {
8540     dVAR;
8541     const IV index = PTR2IV(o->op_ppaddr);
8542     SV* keysv;
8543     HE* he;
8544
8545     if (!PL_custom_op_names) /* This probably shouldn't happen */
8546         return (char *)PL_op_name[OP_CUSTOM];
8547
8548     keysv = sv_2mortal(newSViv(index));
8549
8550     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8551     if (!he)
8552         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8553
8554     return SvPV_nolen(HeVAL(he));
8555 }
8556
8557 const char*
8558 Perl_custom_op_desc(pTHX_ const OP* o)
8559 {
8560     dVAR;
8561     const IV index = PTR2IV(o->op_ppaddr);
8562     SV* keysv;
8563     HE* he;
8564
8565     if (!PL_custom_op_descs)
8566         return (char *)PL_op_desc[OP_CUSTOM];
8567
8568     keysv = sv_2mortal(newSViv(index));
8569
8570     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8571     if (!he)
8572         return (char *)PL_op_desc[OP_CUSTOM];
8573
8574     return SvPV_nolen(HeVAL(he));
8575 }
8576
8577 #include "XSUB.h"
8578
8579 /* Efficient sub that returns a constant scalar value. */
8580 static void
8581 const_sv_xsub(pTHX_ CV* cv)
8582 {
8583     dVAR;
8584     dXSARGS;
8585     if (items != 0) {
8586         NOOP;
8587 #if 0
8588         Perl_croak(aTHX_ "usage: %s::%s()",
8589                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8590 #endif
8591     }
8592     EXTEND(sp, 1);
8593     ST(0) = (SV*)XSANY.any_ptr;
8594     XSRETURN(1);
8595 }
8596
8597 /*
8598  * Local variables:
8599  * c-indentation-style: bsd
8600  * c-basic-offset: 4
8601  * indent-tabs-mode: t
8602  * End:
8603  *
8604  * ex: set ts=8 sts=4 sw=4 noet:
8605  */