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