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