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 = get_cv("DB::postponed", FALSE);
2067             if (cv) {
2068                 dSP;
2069                 PUSHMARK(SP);
2070                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2071                 PUTBACK;
2072                 call_sv((SV*)cv, G_DISCARD);
2073             }
2074         }
2075     }
2076 }
2077
2078 OP *
2079 Perl_localize(pTHX_ OP *o, I32 lex)
2080 {
2081     dVAR;
2082     if (o->op_flags & OPf_PARENS)
2083 /* [perl #17376]: this appears to be premature, and results in code such as
2084    C< our(%x); > executing in list mode rather than void mode */
2085 #if 0
2086         list(o);
2087 #else
2088         NOOP;
2089 #endif
2090     else {
2091         if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2092             && ckWARN(WARN_PARENTHESIS))
2093         {
2094             char *s = PL_bufptr;
2095             bool sigil = FALSE;
2096
2097             /* some heuristics to detect a potential error */
2098             while (*s && (strchr(", \t\n", *s)))
2099                 s++;
2100
2101             while (1) {
2102                 if (*s && strchr("@$%*", *s) && *++s
2103                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2104                     s++;
2105                     sigil = TRUE;
2106                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2107                         s++;
2108                     while (*s && (strchr(", \t\n", *s)))
2109                         s++;
2110                 }
2111                 else
2112                     break;
2113             }
2114             if (sigil && (*s == ';' || *s == '=')) {
2115                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2116                                 "Parentheses missing around \"%s\" list",
2117                                 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2118                                 : "local");
2119             }
2120         }
2121     }
2122     if (lex)
2123         o = my(o);
2124     else
2125         o = mod(o, OP_NULL);            /* a bit kludgey */
2126     PL_in_my = FALSE;
2127     PL_in_my_stash = NULL;
2128     return o;
2129 }
2130
2131 OP *
2132 Perl_jmaybe(pTHX_ OP *o)
2133 {
2134     if (o->op_type == OP_LIST) {
2135         OP * const o2
2136             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2137         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2138     }
2139     return o;
2140 }
2141
2142 OP *
2143 Perl_fold_constants(pTHX_ register OP *o)
2144 {
2145     dVAR;
2146     register OP *curop;
2147     OP *newop;
2148     VOL I32 type = o->op_type;
2149     SV * VOL sv = NULL;
2150     int ret = 0;
2151     I32 oldscope;
2152     OP *old_next;
2153     SV * const oldwarnhook = PL_warnhook;
2154     SV * const olddiehook  = PL_diehook;
2155     dJMPENV;
2156
2157     if (PL_opargs[type] & OA_RETSCALAR)
2158         scalar(o);
2159     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2160         o->op_targ = pad_alloc(type, SVs_PADTMP);
2161
2162     /* integerize op, unless it happens to be C<-foo>.
2163      * XXX should pp_i_negate() do magic string negation instead? */
2164     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2165         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2166              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2167     {
2168         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2169     }
2170
2171     if (!(PL_opargs[type] & OA_FOLDCONST))
2172         goto nope;
2173
2174     switch (type) {
2175     case OP_NEGATE:
2176         /* XXX might want a ck_negate() for this */
2177         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2178         break;
2179     case OP_UCFIRST:
2180     case OP_LCFIRST:
2181     case OP_UC:
2182     case OP_LC:
2183     case OP_SLT:
2184     case OP_SGT:
2185     case OP_SLE:
2186     case OP_SGE:
2187     case OP_SCMP:
2188         /* XXX what about the numeric ops? */
2189         if (PL_hints & HINT_LOCALE)
2190             goto nope;
2191     }
2192
2193     if (PL_error_count)
2194         goto nope;              /* Don't try to run w/ errors */
2195
2196     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2197         const OPCODE type = curop->op_type;
2198         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2199             type != OP_LIST &&
2200             type != OP_SCALAR &&
2201             type != OP_NULL &&
2202             type != OP_PUSHMARK)
2203         {
2204             goto nope;
2205         }
2206     }
2207
2208     curop = LINKLIST(o);
2209     old_next = o->op_next;
2210     o->op_next = 0;
2211     PL_op = curop;
2212
2213     oldscope = PL_scopestack_ix;
2214     create_eval_scope(G_FAKINGEVAL);
2215
2216     PL_warnhook = PERL_WARNHOOK_FATAL;
2217     PL_diehook  = NULL;
2218     JMPENV_PUSH(ret);
2219
2220     switch (ret) {
2221     case 0:
2222         CALLRUNOPS(aTHX);
2223         sv = *(PL_stack_sp--);
2224         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2225             pad_swipe(o->op_targ,  FALSE);
2226         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2227             SvREFCNT_inc_simple_void(sv);
2228             SvTEMP_off(sv);
2229         }
2230         break;
2231     case 3:
2232         /* Something tried to die.  Abandon constant folding.  */
2233         /* Pretend the error never happened.  */
2234         sv_setpvn(ERRSV,"",0);
2235         o->op_next = old_next;
2236         break;
2237     default:
2238         JMPENV_POP;
2239         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2240         PL_warnhook = oldwarnhook;
2241         PL_diehook  = olddiehook;
2242         /* XXX note that this croak may fail as we've already blown away
2243          * the stack - eg any nested evals */
2244         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2245     }
2246     JMPENV_POP;
2247     PL_warnhook = oldwarnhook;
2248     PL_diehook  = olddiehook;
2249
2250     if (PL_scopestack_ix > oldscope)
2251         delete_eval_scope();
2252
2253     if (ret)
2254         goto nope;
2255
2256 #ifndef PERL_MAD
2257     op_free(o);
2258 #endif
2259     assert(sv);
2260     if (type == OP_RV2GV)
2261         newop = newGVOP(OP_GV, 0, (GV*)sv);
2262     else
2263         newop = newSVOP(OP_CONST, 0, (SV*)sv);
2264     op_getmad(o,newop,'f');
2265     return newop;
2266
2267  nope:
2268     return o;
2269 }
2270
2271 OP *
2272 Perl_gen_constant_list(pTHX_ register OP *o)
2273 {
2274     dVAR;
2275     register OP *curop;
2276     const I32 oldtmps_floor = PL_tmps_floor;
2277
2278     list(o);
2279     if (PL_error_count)
2280         return o;               /* Don't attempt to run with errors */
2281
2282     PL_op = curop = LINKLIST(o);
2283     o->op_next = 0;
2284     CALL_PEEP(curop);
2285     pp_pushmark();
2286     CALLRUNOPS(aTHX);
2287     PL_op = curop;
2288     assert (!(curop->op_flags & OPf_SPECIAL));
2289     assert(curop->op_type == OP_RANGE);
2290     pp_anonlist();
2291     PL_tmps_floor = oldtmps_floor;
2292
2293     o->op_type = OP_RV2AV;
2294     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2295     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2296     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2297     o->op_opt = 0;              /* needs to be revisited in peep() */
2298     curop = ((UNOP*)o)->op_first;
2299     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2300 #ifdef PERL_MAD
2301     op_getmad(curop,o,'O');
2302 #else
2303     op_free(curop);
2304 #endif
2305     linklist(o);
2306     return list(o);
2307 }
2308
2309 OP *
2310 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2311 {
2312     dVAR;
2313     if (!o || o->op_type != OP_LIST)
2314         o = newLISTOP(OP_LIST, 0, o, NULL);
2315     else
2316         o->op_flags &= ~OPf_WANT;
2317
2318     if (!(PL_opargs[type] & OA_MARK))
2319         op_null(cLISTOPo->op_first);
2320
2321     o->op_type = (OPCODE)type;
2322     o->op_ppaddr = PL_ppaddr[type];
2323     o->op_flags |= flags;
2324
2325     o = CHECKOP(type, o);
2326     if (o->op_type != (unsigned)type)
2327         return o;
2328
2329     return fold_constants(o);
2330 }
2331
2332 /* List constructors */
2333
2334 OP *
2335 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2336 {
2337     if (!first)
2338         return last;
2339
2340     if (!last)
2341         return first;
2342
2343     if (first->op_type != (unsigned)type
2344         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2345     {
2346         return newLISTOP(type, 0, first, last);
2347     }
2348
2349     if (first->op_flags & OPf_KIDS)
2350         ((LISTOP*)first)->op_last->op_sibling = last;
2351     else {
2352         first->op_flags |= OPf_KIDS;
2353         ((LISTOP*)first)->op_first = last;
2354     }
2355     ((LISTOP*)first)->op_last = last;
2356     return first;
2357 }
2358
2359 OP *
2360 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2361 {
2362     if (!first)
2363         return (OP*)last;
2364
2365     if (!last)
2366         return (OP*)first;
2367
2368     if (first->op_type != (unsigned)type)
2369         return prepend_elem(type, (OP*)first, (OP*)last);
2370
2371     if (last->op_type != (unsigned)type)
2372         return append_elem(type, (OP*)first, (OP*)last);
2373
2374     first->op_last->op_sibling = last->op_first;
2375     first->op_last = last->op_last;
2376     first->op_flags |= (last->op_flags & OPf_KIDS);
2377
2378 #ifdef PERL_MAD
2379     if (last->op_first && first->op_madprop) {
2380         MADPROP *mp = last->op_first->op_madprop;
2381         if (mp) {
2382             while (mp->mad_next)
2383                 mp = mp->mad_next;
2384             mp->mad_next = first->op_madprop;
2385         }
2386         else {
2387             last->op_first->op_madprop = first->op_madprop;
2388         }
2389     }
2390     first->op_madprop = last->op_madprop;
2391     last->op_madprop = 0;
2392 #endif
2393
2394     S_op_destroy(aTHX_ (OP*)last);
2395
2396     return (OP*)first;
2397 }
2398
2399 OP *
2400 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2401 {
2402     if (!first)
2403         return last;
2404
2405     if (!last)
2406         return first;
2407
2408     if (last->op_type == (unsigned)type) {
2409         if (type == OP_LIST) {  /* already a PUSHMARK there */
2410             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2411             ((LISTOP*)last)->op_first->op_sibling = first;
2412             if (!(first->op_flags & OPf_PARENS))
2413                 last->op_flags &= ~OPf_PARENS;
2414         }
2415         else {
2416             if (!(last->op_flags & OPf_KIDS)) {
2417                 ((LISTOP*)last)->op_last = first;
2418                 last->op_flags |= OPf_KIDS;
2419             }
2420             first->op_sibling = ((LISTOP*)last)->op_first;
2421             ((LISTOP*)last)->op_first = first;
2422         }
2423         last->op_flags |= OPf_KIDS;
2424         return last;
2425     }
2426
2427     return newLISTOP(type, 0, first, last);
2428 }
2429
2430 /* Constructors */
2431
2432 #ifdef PERL_MAD
2433
2434 TOKEN *
2435 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2436 {
2437     TOKEN *tk;
2438     Newxz(tk, 1, TOKEN);
2439     tk->tk_type = (OPCODE)optype;
2440     tk->tk_type = 12345;
2441     tk->tk_lval = lval;
2442     tk->tk_mad = madprop;
2443     return tk;
2444 }
2445
2446 void
2447 Perl_token_free(pTHX_ TOKEN* tk)
2448 {
2449     if (tk->tk_type != 12345)
2450         return;
2451     mad_free(tk->tk_mad);
2452     Safefree(tk);
2453 }
2454
2455 void
2456 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2457 {
2458     MADPROP* mp;
2459     MADPROP* tm;
2460     if (tk->tk_type != 12345) {
2461         Perl_warner(aTHX_ packWARN(WARN_MISC),
2462              "Invalid TOKEN object ignored");
2463         return;
2464     }
2465     tm = tk->tk_mad;
2466     if (!tm)
2467         return;
2468
2469     /* faked up qw list? */
2470     if (slot == '(' &&
2471         tm->mad_type == MAD_SV &&
2472         SvPVX((SV*)tm->mad_val)[0] == 'q')
2473             slot = 'x';
2474
2475     if (o) {
2476         mp = o->op_madprop;
2477         if (mp) {
2478             for (;;) {
2479                 /* pretend constant fold didn't happen? */
2480                 if (mp->mad_key == 'f' &&
2481                     (o->op_type == OP_CONST ||
2482                      o->op_type == OP_GV) )
2483                 {
2484                     token_getmad(tk,(OP*)mp->mad_val,slot);
2485                     return;
2486                 }
2487                 if (!mp->mad_next)
2488                     break;
2489                 mp = mp->mad_next;
2490             }
2491             mp->mad_next = tm;
2492             mp = mp->mad_next;
2493         }
2494         else {
2495             o->op_madprop = tm;
2496             mp = o->op_madprop;
2497         }
2498         if (mp->mad_key == 'X')
2499             mp->mad_key = slot; /* just change the first one */
2500
2501         tk->tk_mad = 0;
2502     }
2503     else
2504         mad_free(tm);
2505     Safefree(tk);
2506 }
2507
2508 void
2509 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2510 {
2511     MADPROP* mp;
2512     if (!from)
2513         return;
2514     if (o) {
2515         mp = o->op_madprop;
2516         if (mp) {
2517             for (;;) {
2518                 /* pretend constant fold didn't happen? */
2519                 if (mp->mad_key == 'f' &&
2520                     (o->op_type == OP_CONST ||
2521                      o->op_type == OP_GV) )
2522                 {
2523                     op_getmad(from,(OP*)mp->mad_val,slot);
2524                     return;
2525                 }
2526                 if (!mp->mad_next)
2527                     break;
2528                 mp = mp->mad_next;
2529             }
2530             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2531         }
2532         else {
2533             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2534         }
2535     }
2536 }
2537
2538 void
2539 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2540 {
2541     MADPROP* mp;
2542     if (!from)
2543         return;
2544     if (o) {
2545         mp = o->op_madprop;
2546         if (mp) {
2547             for (;;) {
2548                 /* pretend constant fold didn't happen? */
2549                 if (mp->mad_key == 'f' &&
2550                     (o->op_type == OP_CONST ||
2551                      o->op_type == OP_GV) )
2552                 {
2553                     op_getmad(from,(OP*)mp->mad_val,slot);
2554                     return;
2555                 }
2556                 if (!mp->mad_next)
2557                     break;
2558                 mp = mp->mad_next;
2559             }
2560             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2561         }
2562         else {
2563             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2564         }
2565     }
2566     else {
2567         PerlIO_printf(PerlIO_stderr(),
2568                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2569         op_free(from);
2570     }
2571 }
2572
2573 void
2574 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2575 {
2576     MADPROP* tm;
2577     if (!mp || !o)
2578         return;
2579     if (slot)
2580         mp->mad_key = slot;
2581     tm = o->op_madprop;
2582     o->op_madprop = mp;
2583     for (;;) {
2584         if (!mp->mad_next)
2585             break;
2586         mp = mp->mad_next;
2587     }
2588     mp->mad_next = tm;
2589 }
2590
2591 void
2592 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2593 {
2594     if (!o)
2595         return;
2596     addmad(tm, &(o->op_madprop), slot);
2597 }
2598
2599 void
2600 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2601 {
2602     MADPROP* mp;
2603     if (!tm || !root)
2604         return;
2605     if (slot)
2606         tm->mad_key = slot;
2607     mp = *root;
2608     if (!mp) {
2609         *root = tm;
2610         return;
2611     }
2612     for (;;) {
2613         if (!mp->mad_next)
2614             break;
2615         mp = mp->mad_next;
2616     }
2617     mp->mad_next = tm;
2618 }
2619
2620 MADPROP *
2621 Perl_newMADsv(pTHX_ char key, SV* sv)
2622 {
2623     return newMADPROP(key, MAD_SV, sv, 0);
2624 }
2625
2626 MADPROP *
2627 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2628 {
2629     MADPROP *mp;
2630     Newxz(mp, 1, MADPROP);
2631     mp->mad_next = 0;
2632     mp->mad_key = key;
2633     mp->mad_vlen = vlen;
2634     mp->mad_type = type;
2635     mp->mad_val = val;
2636 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2637     return mp;
2638 }
2639
2640 void
2641 Perl_mad_free(pTHX_ MADPROP* mp)
2642 {
2643 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2644     if (!mp)
2645         return;
2646     if (mp->mad_next)
2647         mad_free(mp->mad_next);
2648 /*    if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2649         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2650     switch (mp->mad_type) {
2651     case MAD_NULL:
2652         break;
2653     case MAD_PV:
2654         Safefree((char*)mp->mad_val);
2655         break;
2656     case MAD_OP:
2657         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2658             op_free((OP*)mp->mad_val);
2659         break;
2660     case MAD_SV:
2661         sv_free((SV*)mp->mad_val);
2662         break;
2663     default:
2664         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2665         break;
2666     }
2667     Safefree(mp);
2668 }
2669
2670 #endif
2671
2672 OP *
2673 Perl_newNULLLIST(pTHX)
2674 {
2675     return newOP(OP_STUB, 0);
2676 }
2677
2678 OP *
2679 Perl_force_list(pTHX_ OP *o)
2680 {
2681     if (!o || o->op_type != OP_LIST)
2682         o = newLISTOP(OP_LIST, 0, o, NULL);
2683     op_null(o);
2684     return o;
2685 }
2686
2687 OP *
2688 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2689 {
2690     dVAR;
2691     LISTOP *listop;
2692
2693     NewOp(1101, listop, 1, LISTOP);
2694
2695     listop->op_type = (OPCODE)type;
2696     listop->op_ppaddr = PL_ppaddr[type];
2697     if (first || last)
2698         flags |= OPf_KIDS;
2699     listop->op_flags = (U8)flags;
2700
2701     if (!last && first)
2702         last = first;
2703     else if (!first && last)
2704         first = last;
2705     else if (first)
2706         first->op_sibling = last;
2707     listop->op_first = first;
2708     listop->op_last = last;
2709     if (type == OP_LIST) {
2710         OP* const pushop = newOP(OP_PUSHMARK, 0);
2711         pushop->op_sibling = first;
2712         listop->op_first = pushop;
2713         listop->op_flags |= OPf_KIDS;
2714         if (!last)
2715             listop->op_last = pushop;
2716     }
2717
2718     return CHECKOP(type, listop);
2719 }
2720
2721 OP *
2722 Perl_newOP(pTHX_ I32 type, I32 flags)
2723 {
2724     dVAR;
2725     OP *o;
2726     NewOp(1101, o, 1, OP);
2727     o->op_type = (OPCODE)type;
2728     o->op_ppaddr = PL_ppaddr[type];
2729     o->op_flags = (U8)flags;
2730     o->op_latefree = 0;
2731     o->op_latefreed = 0;
2732     o->op_attached = 0;
2733
2734     o->op_next = o;
2735     o->op_private = (U8)(0 | (flags >> 8));
2736     if (PL_opargs[type] & OA_RETSCALAR)
2737         scalar(o);
2738     if (PL_opargs[type] & OA_TARGET)
2739         o->op_targ = pad_alloc(type, SVs_PADTMP);
2740     return CHECKOP(type, o);
2741 }
2742
2743 OP *
2744 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2745 {
2746     dVAR;
2747     UNOP *unop;
2748
2749     if (!first)
2750         first = newOP(OP_STUB, 0);
2751     if (PL_opargs[type] & OA_MARK)
2752         first = force_list(first);
2753
2754     NewOp(1101, unop, 1, UNOP);
2755     unop->op_type = (OPCODE)type;
2756     unop->op_ppaddr = PL_ppaddr[type];
2757     unop->op_first = first;
2758     unop->op_flags = (U8)(flags | OPf_KIDS);
2759     unop->op_private = (U8)(1 | (flags >> 8));
2760     unop = (UNOP*) CHECKOP(type, unop);
2761     if (unop->op_next)
2762         return (OP*)unop;
2763
2764     return fold_constants((OP *) unop);
2765 }
2766
2767 OP *
2768 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2769 {
2770     dVAR;
2771     BINOP *binop;
2772     NewOp(1101, binop, 1, BINOP);
2773
2774     if (!first)
2775         first = newOP(OP_NULL, 0);
2776
2777     binop->op_type = (OPCODE)type;
2778     binop->op_ppaddr = PL_ppaddr[type];
2779     binop->op_first = first;
2780     binop->op_flags = (U8)(flags | OPf_KIDS);
2781     if (!last) {
2782         last = first;
2783         binop->op_private = (U8)(1 | (flags >> 8));
2784     }
2785     else {
2786         binop->op_private = (U8)(2 | (flags >> 8));
2787         first->op_sibling = last;
2788     }
2789
2790     binop = (BINOP*)CHECKOP(type, binop);
2791     if (binop->op_next || binop->op_type != (OPCODE)type)
2792         return (OP*)binop;
2793
2794     binop->op_last = binop->op_first->op_sibling;
2795
2796     return fold_constants((OP *)binop);
2797 }
2798
2799 static int uvcompare(const void *a, const void *b)
2800     __attribute__nonnull__(1)
2801     __attribute__nonnull__(2)
2802     __attribute__pure__;
2803 static int uvcompare(const void *a, const void *b)
2804 {
2805     if (*((const UV *)a) < (*(const UV *)b))
2806         return -1;
2807     if (*((const UV *)a) > (*(const UV *)b))
2808         return 1;
2809     if (*((const UV *)a+1) < (*(const UV *)b+1))
2810         return -1;
2811     if (*((const UV *)a+1) > (*(const UV *)b+1))
2812         return 1;
2813     return 0;
2814 }
2815
2816 OP *
2817 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2818 {
2819     dVAR;
2820     SV * const tstr = ((SVOP*)expr)->op_sv;
2821     SV * const rstr =
2822 #ifdef PERL_MAD
2823                         (repl->op_type == OP_NULL)
2824                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2825 #endif
2826                               ((SVOP*)repl)->op_sv;
2827     STRLEN tlen;
2828     STRLEN rlen;
2829     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2830     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2831     register I32 i;
2832     register I32 j;
2833     I32 grows = 0;
2834     register short *tbl;
2835
2836     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2837     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2838     I32 del              = o->op_private & OPpTRANS_DELETE;
2839     SV* swash;
2840     PL_hints |= HINT_BLOCK_SCOPE;
2841
2842     if (SvUTF8(tstr))
2843         o->op_private |= OPpTRANS_FROM_UTF;
2844
2845     if (SvUTF8(rstr))
2846         o->op_private |= OPpTRANS_TO_UTF;
2847
2848     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2849         SV* const listsv = newSVpvs("# comment\n");
2850         SV* transv = NULL;
2851         const U8* tend = t + tlen;
2852         const U8* rend = r + rlen;
2853         STRLEN ulen;
2854         UV tfirst = 1;
2855         UV tlast = 0;
2856         IV tdiff;
2857         UV rfirst = 1;
2858         UV rlast = 0;
2859         IV rdiff;
2860         IV diff;
2861         I32 none = 0;
2862         U32 max = 0;
2863         I32 bits;
2864         I32 havefinal = 0;
2865         U32 final = 0;
2866         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2867         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2868         U8* tsave = NULL;
2869         U8* rsave = NULL;
2870         const U32 flags = UTF8_ALLOW_DEFAULT;
2871
2872         if (!from_utf) {
2873             STRLEN len = tlen;
2874             t = tsave = bytes_to_utf8(t, &len);
2875             tend = t + len;
2876         }
2877         if (!to_utf && rlen) {
2878             STRLEN len = rlen;
2879             r = rsave = bytes_to_utf8(r, &len);
2880             rend = r + len;
2881         }
2882
2883 /* There are several snags with this code on EBCDIC:
2884    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2885    2. scan_const() in toke.c has encoded chars in native encoding which makes
2886       ranges at least in EBCDIC 0..255 range the bottom odd.
2887 */
2888
2889         if (complement) {
2890             U8 tmpbuf[UTF8_MAXBYTES+1];
2891             UV *cp;
2892             UV nextmin = 0;
2893             Newx(cp, 2*tlen, UV);
2894             i = 0;
2895             transv = newSVpvs("");
2896             while (t < tend) {
2897                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2898                 t += ulen;
2899                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2900                     t++;
2901                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2902                     t += ulen;
2903                 }
2904                 else {
2905                  cp[2*i+1] = cp[2*i];
2906                 }
2907                 i++;
2908             }
2909             qsort(cp, i, 2*sizeof(UV), uvcompare);
2910             for (j = 0; j < i; j++) {
2911                 UV  val = cp[2*j];
2912                 diff = val - nextmin;
2913                 if (diff > 0) {
2914                     t = uvuni_to_utf8(tmpbuf,nextmin);
2915                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2916                     if (diff > 1) {
2917                         U8  range_mark = UTF_TO_NATIVE(0xff);
2918                         t = uvuni_to_utf8(tmpbuf, val - 1);
2919                         sv_catpvn(transv, (char *)&range_mark, 1);
2920                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2921                     }
2922                 }
2923                 val = cp[2*j+1];
2924                 if (val >= nextmin)
2925                     nextmin = val + 1;
2926             }
2927             t = uvuni_to_utf8(tmpbuf,nextmin);
2928             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2929             {
2930                 U8 range_mark = UTF_TO_NATIVE(0xff);
2931                 sv_catpvn(transv, (char *)&range_mark, 1);
2932             }
2933             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2934                                     UNICODE_ALLOW_SUPER);
2935             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2936             t = (const U8*)SvPVX_const(transv);
2937             tlen = SvCUR(transv);
2938             tend = t + tlen;
2939             Safefree(cp);
2940         }
2941         else if (!rlen && !del) {
2942             r = t; rlen = tlen; rend = tend;
2943         }
2944         if (!squash) {
2945                 if ((!rlen && !del) || t == r ||
2946                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2947                 {
2948                     o->op_private |= OPpTRANS_IDENTICAL;
2949                 }
2950         }
2951
2952         while (t < tend || tfirst <= tlast) {
2953             /* see if we need more "t" chars */
2954             if (tfirst > tlast) {
2955                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2956                 t += ulen;
2957                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2958                     t++;
2959                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2960                     t += ulen;
2961                 }
2962                 else
2963                     tlast = tfirst;
2964             }
2965
2966             /* now see if we need more "r" chars */
2967             if (rfirst > rlast) {
2968                 if (r < rend) {
2969                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2970                     r += ulen;
2971                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2972                         r++;
2973                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2974                         r += ulen;
2975                     }
2976                     else
2977                         rlast = rfirst;
2978                 }
2979                 else {
2980                     if (!havefinal++)
2981                         final = rlast;
2982                     rfirst = rlast = 0xffffffff;
2983                 }
2984             }
2985
2986             /* now see which range will peter our first, if either. */
2987             tdiff = tlast - tfirst;
2988             rdiff = rlast - rfirst;
2989
2990             if (tdiff <= rdiff)
2991                 diff = tdiff;
2992             else
2993                 diff = rdiff;
2994
2995             if (rfirst == 0xffffffff) {
2996                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2997                 if (diff > 0)
2998                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2999                                    (long)tfirst, (long)tlast);
3000                 else
3001                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3002             }
3003             else {
3004                 if (diff > 0)
3005                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3006                                    (long)tfirst, (long)(tfirst + diff),
3007                                    (long)rfirst);
3008                 else
3009                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3010                                    (long)tfirst, (long)rfirst);
3011
3012                 if (rfirst + diff > max)
3013                     max = rfirst + diff;
3014                 if (!grows)
3015                     grows = (tfirst < rfirst &&
3016                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3017                 rfirst += diff + 1;
3018             }
3019             tfirst += diff + 1;
3020         }
3021
3022         none = ++max;
3023         if (del)
3024             del = ++max;
3025
3026         if (max > 0xffff)
3027             bits = 32;
3028         else if (max > 0xff)
3029             bits = 16;
3030         else
3031             bits = 8;
3032
3033         PerlMemShared_free(cPVOPo->op_pv);
3034         cPVOPo->op_pv = NULL;
3035
3036         swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3037 #ifdef USE_ITHREADS
3038         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3039         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3040         PAD_SETSV(cPADOPo->op_padix, swash);
3041         SvPADTMP_on(swash);
3042 #else
3043         cSVOPo->op_sv = swash;
3044 #endif
3045         SvREFCNT_dec(listsv);
3046         SvREFCNT_dec(transv);
3047
3048         if (!del && havefinal && rlen)
3049             (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3050                            newSVuv((UV)final), 0);
3051
3052         if (grows)
3053             o->op_private |= OPpTRANS_GROWS;
3054
3055         Safefree(tsave);
3056         Safefree(rsave);
3057
3058 #ifdef PERL_MAD
3059         op_getmad(expr,o,'e');
3060         op_getmad(repl,o,'r');
3061 #else
3062         op_free(expr);
3063         op_free(repl);
3064 #endif
3065         return o;
3066     }
3067
3068     tbl = (short*)cPVOPo->op_pv;
3069     if (complement) {
3070         Zero(tbl, 256, short);
3071         for (i = 0; i < (I32)tlen; i++)
3072             tbl[t[i]] = -1;
3073         for (i = 0, j = 0; i < 256; i++) {
3074             if (!tbl[i]) {
3075                 if (j >= (I32)rlen) {
3076                     if (del)
3077                         tbl[i] = -2;
3078                     else if (rlen)
3079                         tbl[i] = r[j-1];
3080                     else
3081                         tbl[i] = (short)i;
3082                 }
3083                 else {
3084                     if (i < 128 && r[j] >= 128)
3085                         grows = 1;
3086                     tbl[i] = r[j++];
3087                 }
3088             }
3089         }
3090         if (!del) {
3091             if (!rlen) {
3092                 j = rlen;
3093                 if (!squash)
3094                     o->op_private |= OPpTRANS_IDENTICAL;
3095             }
3096             else if (j >= (I32)rlen)
3097                 j = rlen - 1;
3098             else {
3099                 tbl = PerlMemShared_realloc(tbl,
3100                                         (0x101+rlen-j) * sizeof(short));
3101                 cPVOPo->op_pv = (char*)tbl;
3102             }
3103             tbl[0x100] = (short)(rlen - j);
3104             for (i=0; i < (I32)rlen - j; i++)
3105                 tbl[0x101+i] = r[j+i];
3106         }
3107     }
3108     else {
3109         if (!rlen && !del) {
3110             r = t; rlen = tlen;
3111             if (!squash)
3112                 o->op_private |= OPpTRANS_IDENTICAL;
3113         }
3114         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3115             o->op_private |= OPpTRANS_IDENTICAL;
3116         }
3117         for (i = 0; i < 256; i++)
3118             tbl[i] = -1;
3119         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3120             if (j >= (I32)rlen) {
3121                 if (del) {
3122                     if (tbl[t[i]] == -1)
3123                         tbl[t[i]] = -2;
3124                     continue;
3125                 }
3126                 --j;
3127             }
3128             if (tbl[t[i]] == -1) {
3129                 if (t[i] < 128 && r[j] >= 128)
3130                     grows = 1;
3131                 tbl[t[i]] = r[j];
3132             }
3133         }
3134     }
3135     if (grows)
3136         o->op_private |= OPpTRANS_GROWS;
3137 #ifdef PERL_MAD
3138     op_getmad(expr,o,'e');
3139     op_getmad(repl,o,'r');
3140 #else
3141     op_free(expr);
3142     op_free(repl);
3143 #endif
3144
3145     return o;
3146 }
3147
3148 OP *
3149 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3150 {
3151     dVAR;
3152     PMOP *pmop;
3153
3154     NewOp(1101, pmop, 1, PMOP);
3155     pmop->op_type = (OPCODE)type;
3156     pmop->op_ppaddr = PL_ppaddr[type];
3157     pmop->op_flags = (U8)flags;
3158     pmop->op_private = (U8)(0 | (flags >> 8));
3159
3160     if (PL_hints & HINT_RE_TAINT)
3161         pmop->op_pmpermflags |= PMf_RETAINT;
3162     if (PL_hints & HINT_LOCALE)
3163         pmop->op_pmpermflags |= PMf_LOCALE;
3164     pmop->op_pmflags = pmop->op_pmpermflags;
3165
3166 #ifdef USE_ITHREADS
3167     if (av_len((AV*) PL_regex_pad[0]) > -1) {
3168         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3169         pmop->op_pmoffset = SvIV(repointer);
3170         SvREPADTMP_off(repointer);
3171         sv_setiv(repointer,0);
3172     } else {
3173         SV * const repointer = newSViv(0);
3174         av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3175         pmop->op_pmoffset = av_len(PL_regex_padav);
3176         PL_regex_pad = AvARRAY(PL_regex_padav);
3177     }
3178 #endif
3179
3180         /* link into pm list */
3181     if (type != OP_TRANS && PL_curstash) {
3182         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3183
3184         if (!mg) {
3185             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3186         }
3187         pmop->op_pmnext = (PMOP*)mg->mg_obj;
3188         mg->mg_obj = (SV*)pmop;
3189         PmopSTASH_set(pmop,PL_curstash);
3190     }
3191
3192     return CHECKOP(type, pmop);
3193 }
3194
3195 /* Given some sort of match op o, and an expression expr containing a
3196  * pattern, either compile expr into a regex and attach it to o (if it's
3197  * constant), or convert expr into a runtime regcomp op sequence (if it's
3198  * not)
3199  *
3200  * isreg indicates that the pattern is part of a regex construct, eg
3201  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3202  * split "pattern", which aren't. In the former case, expr will be a list
3203  * if the pattern contains more than one term (eg /a$b/) or if it contains
3204  * a replacement, ie s/// or tr///.
3205  */
3206
3207 OP *
3208 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3209 {
3210     dVAR;
3211     PMOP *pm;
3212     LOGOP *rcop;
3213     I32 repl_has_vars = 0;
3214     OP* repl = NULL;
3215     bool reglist;
3216
3217     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3218         /* last element in list is the replacement; pop it */
3219         OP* kid;
3220         repl = cLISTOPx(expr)->op_last;
3221         kid = cLISTOPx(expr)->op_first;
3222         while (kid->op_sibling != repl)
3223             kid = kid->op_sibling;
3224         kid->op_sibling = NULL;
3225         cLISTOPx(expr)->op_last = kid;
3226     }
3227
3228     if (isreg && expr->op_type == OP_LIST &&
3229         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3230     {
3231         /* convert single element list to element */
3232         OP* const oe = expr;
3233         expr = cLISTOPx(oe)->op_first->op_sibling;
3234         cLISTOPx(oe)->op_first->op_sibling = NULL;
3235         cLISTOPx(oe)->op_last = NULL;
3236         op_free(oe);
3237     }
3238
3239     if (o->op_type == OP_TRANS) {
3240         return pmtrans(o, expr, repl);
3241     }
3242
3243     reglist = isreg && expr->op_type == OP_LIST;
3244     if (reglist)
3245         op_null(expr);
3246
3247     PL_hints |= HINT_BLOCK_SCOPE;
3248     pm = (PMOP*)o;
3249
3250     if (expr->op_type == OP_CONST) {
3251         STRLEN plen;
3252         SV * const pat = ((SVOP*)expr)->op_sv;
3253         const char *p = SvPV_const(pat, plen);
3254         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3255             U32 was_readonly = SvREADONLY(pat);
3256
3257             if (was_readonly) {
3258                 if (SvFAKE(pat)) {
3259                     sv_force_normal_flags(pat, 0);
3260                     assert(!SvREADONLY(pat));
3261                     was_readonly = 0;
3262                 } else {
3263                     SvREADONLY_off(pat);
3264                 }
3265             }
3266
3267             sv_setpvn(pat, "\\s+", 3);
3268
3269             SvFLAGS(pat) |= was_readonly;
3270
3271             p = SvPV_const(pat, plen);
3272             pm->op_pmflags |= PMf_SKIPWHITE;
3273         }
3274         if (DO_UTF8(pat))
3275             pm->op_pmdynflags |= PMdf_UTF8;
3276         /* FIXME - can we make this function take const char * args?  */
3277         PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3278         if (PM_GETRE(pm)->extflags & RXf_WHITE)
3279             pm->op_pmflags |= PMf_WHITE;
3280         else
3281             pm->op_pmflags &= ~PMf_WHITE;
3282 #ifdef PERL_MAD
3283         op_getmad(expr,(OP*)pm,'e');
3284 #else
3285         op_free(expr);
3286 #endif
3287     }
3288     else {
3289         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3290             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3291                             ? OP_REGCRESET
3292                             : OP_REGCMAYBE),0,expr);
3293
3294         NewOp(1101, rcop, 1, LOGOP);
3295         rcop->op_type = OP_REGCOMP;
3296         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3297         rcop->op_first = scalar(expr);
3298         rcop->op_flags |= OPf_KIDS
3299                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3300                             | (reglist ? OPf_STACKED : 0);
3301         rcop->op_private = 1;
3302         rcop->op_other = o;
3303         if (reglist)
3304             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3305
3306         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3307         PL_cv_has_eval = 1;
3308
3309         /* establish postfix order */
3310         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3311             LINKLIST(expr);
3312             rcop->op_next = expr;
3313             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3314         }
3315         else {
3316             rcop->op_next = LINKLIST(expr);
3317             expr->op_next = (OP*)rcop;
3318         }
3319
3320         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3321     }
3322
3323     if (repl) {
3324         OP *curop;
3325         if (pm->op_pmflags & PMf_EVAL) {
3326             curop = NULL;
3327             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3328                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3329         }
3330         else if (repl->op_type == OP_CONST)
3331             curop = repl;
3332         else {
3333             OP *lastop = NULL;
3334             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3335                 if (curop->op_type == OP_SCOPE
3336                         || curop->op_type == OP_LEAVE
3337                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3338                     if (curop->op_type == OP_GV) {
3339                         GV * const gv = cGVOPx_gv(curop);
3340                         repl_has_vars = 1;
3341                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3342                             break;
3343                     }
3344                     else if (curop->op_type == OP_RV2CV)
3345                         break;
3346                     else if (curop->op_type == OP_RV2SV ||
3347                              curop->op_type == OP_RV2AV ||
3348                              curop->op_type == OP_RV2HV ||
3349                              curop->op_type == OP_RV2GV) {
3350                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3351                             break;
3352                     }
3353                     else if (curop->op_type == OP_PADSV ||
3354                              curop->op_type == OP_PADAV ||
3355                              curop->op_type == OP_PADHV ||
3356                              curop->op_type == OP_PADANY)
3357                     {
3358                         repl_has_vars = 1;
3359                     }
3360                     else if (curop->op_type == OP_PUSHRE)
3361                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3362                     else
3363                         break;
3364                 }
3365                 lastop = curop;
3366             }
3367         }
3368         if (curop == repl
3369             && !(repl_has_vars
3370                  && (!PM_GETRE(pm)
3371                      || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3372         {
3373             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3374             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3375             prepend_elem(o->op_type, scalar(repl), o);
3376         }
3377         else {
3378             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3379                 pm->op_pmflags |= PMf_MAYBE_CONST;
3380                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3381             }
3382             NewOp(1101, rcop, 1, LOGOP);
3383             rcop->op_type = OP_SUBSTCONT;
3384             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3385             rcop->op_first = scalar(repl);
3386             rcop->op_flags |= OPf_KIDS;
3387             rcop->op_private = 1;
3388             rcop->op_other = o;
3389
3390             /* establish postfix order */
3391             rcop->op_next = LINKLIST(repl);
3392             repl->op_next = (OP*)rcop;
3393
3394             pm->op_pmreplroot = scalar((OP*)rcop);
3395             pm->op_pmreplstart = LINKLIST(rcop);
3396             rcop->op_next = 0;
3397         }
3398     }
3399
3400     return (OP*)pm;
3401 }
3402
3403 OP *
3404 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3405 {
3406     dVAR;
3407     SVOP *svop;
3408     NewOp(1101, svop, 1, SVOP);
3409     svop->op_type = (OPCODE)type;
3410     svop->op_ppaddr = PL_ppaddr[type];
3411     svop->op_sv = sv;
3412     svop->op_next = (OP*)svop;
3413     svop->op_flags = (U8)flags;
3414     if (PL_opargs[type] & OA_RETSCALAR)
3415         scalar((OP*)svop);
3416     if (PL_opargs[type] & OA_TARGET)
3417         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3418     return CHECKOP(type, svop);
3419 }
3420
3421 OP *
3422 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3423 {
3424     dVAR;
3425     PADOP *padop;
3426     NewOp(1101, padop, 1, PADOP);
3427     padop->op_type = (OPCODE)type;
3428     padop->op_ppaddr = PL_ppaddr[type];
3429     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3430     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3431     PAD_SETSV(padop->op_padix, sv);
3432     if (sv)
3433         SvPADTMP_on(sv);
3434     padop->op_next = (OP*)padop;
3435     padop->op_flags = (U8)flags;
3436     if (PL_opargs[type] & OA_RETSCALAR)
3437         scalar((OP*)padop);
3438     if (PL_opargs[type] & OA_TARGET)
3439         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3440     return CHECKOP(type, padop);
3441 }
3442
3443 OP *
3444 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3445 {
3446     dVAR;
3447 #ifdef USE_ITHREADS
3448     if (gv)
3449         GvIN_PAD_on(gv);
3450     return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3451 #else
3452     return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3453 #endif
3454 }
3455
3456 OP *
3457 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3458 {
3459     dVAR;
3460     PVOP *pvop;
3461     NewOp(1101, pvop, 1, PVOP);
3462     pvop->op_type = (OPCODE)type;
3463     pvop->op_ppaddr = PL_ppaddr[type];
3464     pvop->op_pv = pv;
3465     pvop->op_next = (OP*)pvop;
3466     pvop->op_flags = (U8)flags;
3467     if (PL_opargs[type] & OA_RETSCALAR)
3468         scalar((OP*)pvop);
3469     if (PL_opargs[type] & OA_TARGET)
3470         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3471     return CHECKOP(type, pvop);
3472 }
3473
3474 #ifdef PERL_MAD
3475 OP*
3476 #else
3477 void
3478 #endif
3479 Perl_package(pTHX_ OP *o)
3480 {
3481     dVAR;
3482     const char *name;
3483     STRLEN len;
3484 #ifdef PERL_MAD
3485     OP *pegop;
3486 #endif
3487
3488     save_hptr(&PL_curstash);
3489     save_item(PL_curstname);
3490
3491     name = SvPV_const(cSVOPo->op_sv, len);
3492     PL_curstash = gv_stashpvn(name, len, TRUE);
3493     sv_setpvn(PL_curstname, name, len);
3494
3495     PL_hints |= HINT_BLOCK_SCOPE;
3496     PL_copline = NOLINE;
3497     PL_expect = XSTATE;
3498
3499 #ifndef PERL_MAD
3500     op_free(o);
3501 #else
3502     if (!PL_madskills) {
3503         op_free(o);
3504         return NULL;
3505     }
3506
3507     pegop = newOP(OP_NULL,0);
3508     op_getmad(o,pegop,'P');
3509     return pegop;
3510 #endif
3511 }
3512
3513 #ifdef PERL_MAD
3514 OP*
3515 #else
3516 void
3517 #endif
3518 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3519 {
3520     dVAR;
3521     OP *pack;
3522     OP *imop;
3523     OP *veop;
3524 #ifdef PERL_MAD
3525     OP *pegop = newOP(OP_NULL,0);
3526 #endif
3527
3528     if (idop->op_type != OP_CONST)
3529         Perl_croak(aTHX_ "Module name must be constant");
3530
3531     if (PL_madskills)
3532         op_getmad(idop,pegop,'U');
3533
3534     veop = NULL;
3535
3536     if (version) {
3537         SV * const vesv = ((SVOP*)version)->op_sv;
3538
3539         if (PL_madskills)
3540             op_getmad(version,pegop,'V');
3541         if (!arg && !SvNIOKp(vesv)) {
3542             arg = version;
3543         }
3544         else {
3545             OP *pack;
3546             SV *meth;
3547
3548             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3549                 Perl_croak(aTHX_ "Version number must be constant number");
3550
3551             /* Make copy of idop so we don't free it twice */
3552             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3553
3554             /* Fake up a method call to VERSION */
3555             meth = newSVpvs_share("VERSION");
3556             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3557                             append_elem(OP_LIST,
3558                                         prepend_elem(OP_LIST, pack, list(version)),
3559                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3560         }
3561     }
3562
3563     /* Fake up an import/unimport */
3564     if (arg && arg->op_type == OP_STUB) {
3565         if (PL_madskills)
3566             op_getmad(arg,pegop,'S');
3567         imop = arg;             /* no import on explicit () */
3568     }
3569     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3570         imop = NULL;            /* use 5.0; */
3571         if (!aver)
3572             idop->op_private |= OPpCONST_NOVER;
3573     }
3574     else {
3575         SV *meth;
3576
3577         if (PL_madskills)
3578             op_getmad(arg,pegop,'A');
3579
3580         /* Make copy of idop so we don't free it twice */
3581         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3582
3583         /* Fake up a method call to import/unimport */
3584         meth = aver
3585             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3586         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3587                        append_elem(OP_LIST,
3588                                    prepend_elem(OP_LIST, pack, list(arg)),
3589                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3590     }
3591
3592     /* Fake up the BEGIN {}, which does its thing immediately. */
3593     newATTRSUB(floor,
3594         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3595         NULL,
3596         NULL,
3597         append_elem(OP_LINESEQ,
3598             append_elem(OP_LINESEQ,
3599                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3600                 newSTATEOP(0, NULL, veop)),
3601             newSTATEOP(0, NULL, imop) ));
3602
3603     /* The "did you use incorrect case?" warning used to be here.
3604      * The problem is that on case-insensitive filesystems one
3605      * might get false positives for "use" (and "require"):
3606      * "use Strict" or "require CARP" will work.  This causes
3607      * portability problems for the script: in case-strict
3608      * filesystems the script will stop working.
3609      *
3610      * The "incorrect case" warning checked whether "use Foo"
3611      * imported "Foo" to your namespace, but that is wrong, too:
3612      * there is no requirement nor promise in the language that
3613      * a Foo.pm should or would contain anything in package "Foo".
3614      *
3615      * There is very little Configure-wise that can be done, either:
3616      * the case-sensitivity of the build filesystem of Perl does not
3617      * help in guessing the case-sensitivity of the runtime environment.
3618      */
3619
3620     PL_hints |= HINT_BLOCK_SCOPE;
3621     PL_copline = NOLINE;
3622     PL_expect = XSTATE;
3623     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3624
3625 #ifdef PERL_MAD
3626     if (!PL_madskills) {
3627         /* FIXME - don't allocate pegop if !PL_madskills */
3628         op_free(pegop);
3629         return NULL;
3630     }
3631     return pegop;
3632 #endif
3633 }
3634
3635 /*
3636 =head1 Embedding Functions
3637
3638 =for apidoc load_module
3639
3640 Loads the module whose name is pointed to by the string part of name.
3641 Note that the actual module name, not its filename, should be given.
3642 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3643 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3644 (or 0 for no flags). ver, if specified, provides version semantics
3645 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3646 arguments can be used to specify arguments to the module's import()
3647 method, similar to C<use Foo::Bar VERSION LIST>.
3648
3649 =cut */
3650
3651 void
3652 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3653 {
3654     va_list args;
3655     va_start(args, ver);
3656     vload_module(flags, name, ver, &args);
3657     va_end(args);
3658 }
3659
3660 #ifdef PERL_IMPLICIT_CONTEXT
3661 void
3662 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3663 {
3664     dTHX;
3665     va_list args;
3666     va_start(args, ver);
3667     vload_module(flags, name, ver, &args);
3668     va_end(args);
3669 }
3670 #endif
3671
3672 void
3673 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3674 {
3675     dVAR;
3676     OP *veop, *imop;
3677
3678     OP * const modname = newSVOP(OP_CONST, 0, name);
3679     modname->op_private |= OPpCONST_BARE;
3680     if (ver) {
3681         veop = newSVOP(OP_CONST, 0, ver);
3682     }
3683     else
3684         veop = NULL;
3685     if (flags & PERL_LOADMOD_NOIMPORT) {
3686         imop = sawparens(newNULLLIST());
3687     }
3688     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3689         imop = va_arg(*args, OP*);
3690     }
3691     else {
3692         SV *sv;
3693         imop = NULL;
3694         sv = va_arg(*args, SV*);
3695         while (sv) {
3696             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3697             sv = va_arg(*args, SV*);
3698         }
3699     }
3700     {
3701         const line_t ocopline = PL_copline;
3702         COP * const ocurcop = PL_curcop;
3703         const int oexpect = PL_expect;
3704
3705         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3706                 veop, modname, imop);
3707         PL_expect = oexpect;
3708         PL_copline = ocopline;
3709         PL_curcop = ocurcop;
3710     }
3711 }
3712
3713 OP *
3714 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3715 {
3716     dVAR;
3717     OP *doop;
3718     GV *gv = NULL;
3719
3720     if (!force_builtin) {
3721         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3722         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3723             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3724             gv = gvp ? *gvp : NULL;
3725         }
3726     }
3727
3728     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3729         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3730                                append_elem(OP_LIST, term,
3731                                            scalar(newUNOP(OP_RV2CV, 0,
3732                                                           newGVOP(OP_GV, 0, gv))))));
3733     }
3734     else {
3735         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3736     }
3737     return doop;
3738 }
3739
3740 OP *
3741 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3742 {
3743     return newBINOP(OP_LSLICE, flags,
3744             list(force_list(subscript)),
3745             list(force_list(listval)) );
3746 }
3747
3748 STATIC I32
3749 S_is_list_assignment(pTHX_ register const OP *o)
3750 {
3751     unsigned type;
3752     U8 flags;
3753
3754     if (!o)
3755         return TRUE;
3756
3757     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3758         o = cUNOPo->op_first;
3759
3760     flags = o->op_flags;
3761     type = o->op_type;
3762     if (type == OP_COND_EXPR) {
3763         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3764         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3765
3766         if (t && f)
3767             return TRUE;
3768         if (t || f)
3769             yyerror("Assignment to both a list and a scalar");
3770         return FALSE;
3771     }
3772
3773     if (type == OP_LIST &&
3774         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3775         o->op_private & OPpLVAL_INTRO)
3776         return FALSE;
3777
3778     if (type == OP_LIST || flags & OPf_PARENS ||
3779         type == OP_RV2AV || type == OP_RV2HV ||
3780         type == OP_ASLICE || type == OP_HSLICE)
3781         return TRUE;
3782
3783     if (type == OP_PADAV || type == OP_PADHV)
3784         return TRUE;
3785
3786     if (type == OP_RV2SV)
3787         return FALSE;
3788
3789     return FALSE;
3790 }
3791
3792 OP *
3793 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3794 {
3795     dVAR;
3796     OP *o;
3797
3798     if (optype) {
3799         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3800             return newLOGOP(optype, 0,
3801                 mod(scalar(left), optype),
3802                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3803         }
3804         else {
3805             return newBINOP(optype, OPf_STACKED,
3806                 mod(scalar(left), optype), scalar(right));
3807         }
3808     }
3809
3810     if (is_list_assignment(left)) {
3811         OP *curop;
3812
3813         PL_modcount = 0;
3814         /* Grandfathering $[ assignment here.  Bletch.*/
3815         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3816         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3817         left = mod(left, OP_AASSIGN);
3818         if (PL_eval_start)
3819             PL_eval_start = 0;
3820         else if (left->op_type == OP_CONST) {
3821             /* FIXME for MAD */
3822             /* Result of assignment is always 1 (or we'd be dead already) */
3823             return newSVOP(OP_CONST, 0, newSViv(1));
3824         }
3825         curop = list(force_list(left));
3826         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3827         o->op_private = (U8)(0 | (flags >> 8));
3828
3829         /* PL_generation sorcery:
3830          * an assignment like ($a,$b) = ($c,$d) is easier than
3831          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3832          * To detect whether there are common vars, the global var
3833          * PL_generation is incremented for each assign op we compile.
3834          * Then, while compiling the assign op, we run through all the
3835          * variables on both sides of the assignment, setting a spare slot
3836          * in each of them to PL_generation. If any of them already have
3837          * that value, we know we've got commonality.  We could use a
3838          * single bit marker, but then we'd have to make 2 passes, first
3839          * to clear the flag, then to test and set it.  To find somewhere
3840          * to store these values, evil chicanery is done with SvUVX().
3841          */
3842
3843         {
3844             OP *lastop = o;
3845             PL_generation++;
3846             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3847                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3848                     if (curop->op_type == OP_GV) {
3849                         GV *gv = cGVOPx_gv(curop);
3850                         if (gv == PL_defgv
3851                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3852                             break;
3853                         GvASSIGN_GENERATION_set(gv, PL_generation);
3854                     }
3855                     else if (curop->op_type == OP_PADSV ||
3856                              curop->op_type == OP_PADAV ||
3857                              curop->op_type == OP_PADHV ||
3858                              curop->op_type == OP_PADANY)
3859                     {
3860                         if (PAD_COMPNAME_GEN(curop->op_targ)
3861                                                     == (STRLEN)PL_generation)
3862                             break;
3863                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3864
3865                     }
3866                     else if (curop->op_type == OP_RV2CV)
3867                         break;
3868                     else if (curop->op_type == OP_RV2SV ||
3869                              curop->op_type == OP_RV2AV ||
3870                              curop->op_type == OP_RV2HV ||
3871                              curop->op_type == OP_RV2GV) {
3872                         if (lastop->op_type != OP_GV)   /* funny deref? */
3873                             break;
3874                     }
3875                     else if (curop->op_type == OP_PUSHRE) {
3876                         if (((PMOP*)curop)->op_pmreplroot) {
3877 #ifdef USE_ITHREADS
3878                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3879                                         ((PMOP*)curop)->op_pmreplroot));
3880 #else
3881                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3882 #endif
3883                             if (gv == PL_defgv
3884                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3885                                 break;
3886                             GvASSIGN_GENERATION_set(gv, PL_generation);
3887                             GvASSIGN_GENERATION_set(gv, PL_generation);
3888                         }
3889                     }
3890                     else
3891                         break;
3892                 }
3893                 lastop = curop;
3894             }
3895             if (curop != o)
3896                 o->op_private |= OPpASSIGN_COMMON;
3897         }
3898
3899         if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3900                 && (left->op_type == OP_LIST
3901                     || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3902         {
3903             OP* lop = ((LISTOP*)left)->op_first;
3904             while (lop) {
3905                 if (lop->op_type == OP_PADSV ||
3906                     lop->op_type == OP_PADAV ||
3907                     lop->op_type == OP_PADHV ||
3908                     lop->op_type == OP_PADANY)
3909                 {
3910                     if (lop->op_private & OPpPAD_STATE) {
3911                         if (left->op_private & OPpLVAL_INTRO) {
3912                             o->op_private |= OPpASSIGN_STATE;
3913                             /* hijacking PADSTALE for uninitialized state variables */
3914                             SvPADSTALE_on(PAD_SVl(lop->op_targ));
3915                         }
3916                         else { /* we already checked for WARN_MISC before */
3917                             Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3918                                     PAD_COMPNAME_PV(lop->op_targ));
3919                         }
3920                     }
3921                 }
3922                 lop = lop->op_sibling;
3923             }
3924         }
3925
3926         if (right && right->op_type == OP_SPLIT) {
3927             OP* tmpop = ((LISTOP*)right)->op_first;
3928             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3929                 PMOP * const pm = (PMOP*)tmpop;
3930                 if (left->op_type == OP_RV2AV &&
3931                     !(left->op_private & OPpLVAL_INTRO) &&
3932                     !(o->op_private & OPpASSIGN_COMMON) )
3933                 {
3934                     tmpop = ((UNOP*)left)->op_first;
3935                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3936 #ifdef USE_ITHREADS
3937                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3938                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3939 #else
3940                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3941                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
3942 #endif
3943                         pm->op_pmflags |= PMf_ONCE;
3944                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3945                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3946                         tmpop->op_sibling = NULL;       /* don't free split */
3947                         right->op_next = tmpop->op_next;  /* fix starting loc */
3948 #ifdef PERL_MAD
3949                         op_getmad(o,right,'R');         /* blow off assign */
3950 #else
3951                         op_free(o);                     /* blow off assign */
3952 #endif
3953                         right->op_flags &= ~OPf_WANT;
3954                                 /* "I don't know and I don't care." */
3955                         return right;
3956                     }
3957                 }
3958                 else {
3959                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3960                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3961                     {
3962                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3963                         if (SvIVX(sv) == 0)
3964                             sv_setiv(sv, PL_modcount+1);
3965                     }
3966                 }
3967             }
3968         }
3969         return o;
3970     }
3971     if (!right)
3972         right = newOP(OP_UNDEF, 0);
3973     if (right->op_type == OP_READLINE) {
3974         right->op_flags |= OPf_STACKED;
3975         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3976     }
3977     else {
3978         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3979         o = newBINOP(OP_SASSIGN, flags,
3980             scalar(right), mod(scalar(left), OP_SASSIGN) );
3981         if (PL_eval_start)
3982             PL_eval_start = 0;
3983         else {
3984             /* FIXME for MAD */
3985             op_free(o);
3986             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3987             o->op_private |= OPpCONST_ARYBASE;
3988         }
3989     }
3990     return o;
3991 }
3992
3993 OP *
3994 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3995 {
3996     dVAR;
3997     const U32 seq = intro_my();
3998     register COP *cop;
3999
4000     NewOp(1101, cop, 1, COP);
4001     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4002         cop->op_type = OP_DBSTATE;
4003         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4004     }
4005     else {
4006         cop->op_type = OP_NEXTSTATE;
4007         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4008     }
4009     cop->op_flags = (U8)flags;
4010     CopHINTS_set(cop, PL_hints);
4011 #ifdef NATIVE_HINTS
4012     cop->op_private |= NATIVE_HINTS;
4013 #endif
4014     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4015     cop->op_next = (OP*)cop;
4016
4017     if (label) {
4018         CopLABEL_set(cop, label);
4019         PL_hints |= HINT_BLOCK_SCOPE;
4020     }
4021     cop->cop_seq = seq;
4022     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4023        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4024     */
4025     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4026     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4027     if (cop->cop_hints_hash) {
4028         HINTS_REFCNT_LOCK;
4029         cop->cop_hints_hash->refcounted_he_refcnt++;
4030         HINTS_REFCNT_UNLOCK;
4031     }
4032
4033     if (PL_copline == NOLINE)
4034         CopLINE_set(cop, CopLINE(PL_curcop));
4035     else {
4036         CopLINE_set(cop, PL_copline);
4037         PL_copline = NOLINE;
4038     }
4039 #ifdef USE_ITHREADS
4040     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4041 #else
4042     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4043 #endif
4044     CopSTASH_set(cop, PL_curstash);
4045
4046     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4047         AV *av = CopFILEAVx(PL_curcop);
4048         if (av) {
4049             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4050             if (svp && *svp != &PL_sv_undef ) {
4051                 (void)SvIOK_on(*svp);
4052                 SvIV_set(*svp, PTR2IV(cop));
4053             }
4054         }
4055     }
4056
4057     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4058 }
4059
4060
4061 OP *
4062 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4063 {
4064     dVAR;
4065     return new_logop(type, flags, &first, &other);
4066 }
4067
4068 STATIC OP *
4069 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4070 {
4071     dVAR;
4072     LOGOP *logop;
4073     OP *o;
4074     OP *first = *firstp;
4075     OP * const other = *otherp;
4076
4077     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4078         return newBINOP(type, flags, scalar(first), scalar(other));
4079
4080     scalarboolean(first);
4081     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4082     if (first->op_type == OP_NOT
4083         && (first->op_flags & OPf_SPECIAL)
4084         && (first->op_flags & OPf_KIDS)) {
4085         if (type == OP_AND || type == OP_OR) {
4086             if (type == OP_AND)
4087                 type = OP_OR;
4088             else
4089                 type = OP_AND;
4090             o = first;
4091             first = *firstp = cUNOPo->op_first;
4092             if (o->op_next)
4093                 first->op_next = o->op_next;
4094             cUNOPo->op_first = NULL;
4095 #ifdef PERL_MAD
4096             op_getmad(o,first,'O');
4097 #else
4098             op_free(o);
4099 #endif
4100         }
4101     }
4102     if (first->op_type == OP_CONST) {
4103         if (first->op_private & OPpCONST_STRICT)
4104             no_bareword_allowed(first);
4105         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4106                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4107         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4108             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4109             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4110             *firstp = NULL;
4111             if (other->op_type == OP_CONST)
4112                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4113             if (PL_madskills) {
4114                 OP *newop = newUNOP(OP_NULL, 0, other);
4115                 op_getmad(first, newop, '1');
4116                 newop->op_targ = type;  /* set "was" field */
4117                 return newop;
4118             }
4119             op_free(first);
4120             return other;
4121         }
4122         else {
4123             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4124             const OP *o2 = other;
4125             if ( ! (o2->op_type == OP_LIST
4126                     && (( o2 = cUNOPx(o2)->op_first))
4127                     && o2->op_type == OP_PUSHMARK
4128                     && (( o2 = o2->op_sibling)) )
4129             )
4130                 o2 = other;
4131             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4132                         || o2->op_type == OP_PADHV)
4133                 && o2->op_private & OPpLVAL_INTRO
4134                 && ckWARN(WARN_DEPRECATED))
4135             {
4136                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4137                             "Deprecated use of my() in false conditional");
4138             }
4139
4140             *otherp = NULL;
4141             if (first->op_type == OP_CONST)
4142                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4143             if (PL_madskills) {
4144                 first = newUNOP(OP_NULL, 0, first);
4145                 op_getmad(other, first, '2');
4146                 first->op_targ = type;  /* set "was" field */
4147             }
4148             else
4149                 op_free(other);
4150             return first;
4151         }
4152     }
4153     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4154         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4155     {
4156         const OP * const k1 = ((UNOP*)first)->op_first;
4157         const OP * const k2 = k1->op_sibling;
4158         OPCODE warnop = 0;
4159         switch (first->op_type)
4160         {
4161         case OP_NULL:
4162             if (k2 && k2->op_type == OP_READLINE
4163                   && (k2->op_flags & OPf_STACKED)
4164                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4165             {
4166                 warnop = k2->op_type;
4167             }
4168             break;
4169
4170         case OP_SASSIGN:
4171             if (k1->op_type == OP_READDIR
4172                   || k1->op_type == OP_GLOB
4173                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4174                   || k1->op_type == OP_EACH)
4175             {
4176                 warnop = ((k1->op_type == OP_NULL)
4177                           ? (OPCODE)k1->op_targ : k1->op_type);
4178             }
4179             break;
4180         }
4181         if (warnop) {
4182             const line_t oldline = CopLINE(PL_curcop);
4183             CopLINE_set(PL_curcop, PL_copline);
4184             Perl_warner(aTHX_ packWARN(WARN_MISC),
4185                  "Value of %s%s can be \"0\"; test with defined()",
4186                  PL_op_desc[warnop],
4187                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4188                   ? " construct" : "() operator"));
4189             CopLINE_set(PL_curcop, oldline);
4190         }
4191     }
4192
4193     if (!other)
4194         return first;
4195
4196     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4197         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4198
4199     NewOp(1101, logop, 1, LOGOP);
4200
4201     logop->op_type = (OPCODE)type;
4202     logop->op_ppaddr = PL_ppaddr[type];
4203     logop->op_first = first;
4204     logop->op_flags = (U8)(flags | OPf_KIDS);
4205     logop->op_other = LINKLIST(other);
4206     logop->op_private = (U8)(1 | (flags >> 8));
4207
4208     /* establish postfix order */
4209     logop->op_next = LINKLIST(first);
4210     first->op_next = (OP*)logop;
4211     first->op_sibling = other;
4212
4213     CHECKOP(type,logop);
4214
4215     o = newUNOP(OP_NULL, 0, (OP*)logop);
4216     other->op_next = o;
4217
4218     return o;
4219 }
4220
4221 OP *
4222 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4223 {
4224     dVAR;
4225     LOGOP *logop;
4226     OP *start;
4227     OP *o;
4228
4229     if (!falseop)
4230         return newLOGOP(OP_AND, 0, first, trueop);
4231     if (!trueop)
4232         return newLOGOP(OP_OR, 0, first, falseop);
4233
4234     scalarboolean(first);
4235     if (first->op_type == OP_CONST) {
4236         if (first->op_private & OPpCONST_BARE &&
4237             first->op_private & OPpCONST_STRICT) {
4238             no_bareword_allowed(first);
4239         }
4240         if (SvTRUE(((SVOP*)first)->op_sv)) {
4241 #ifdef PERL_MAD
4242             if (PL_madskills) {
4243                 trueop = newUNOP(OP_NULL, 0, trueop);
4244                 op_getmad(first,trueop,'C');
4245                 op_getmad(falseop,trueop,'e');
4246             }
4247             /* FIXME for MAD - should there be an ELSE here?  */
4248 #else
4249             op_free(first);
4250             op_free(falseop);
4251 #endif
4252             return trueop;
4253         }
4254         else {
4255 #ifdef PERL_MAD
4256             if (PL_madskills) {
4257                 falseop = newUNOP(OP_NULL, 0, falseop);
4258                 op_getmad(first,falseop,'C');
4259                 op_getmad(trueop,falseop,'t');
4260             }
4261             /* FIXME for MAD - should there be an ELSE here?  */
4262 #else
4263             op_free(first);
4264             op_free(trueop);
4265 #endif
4266             return falseop;
4267         }
4268     }
4269     NewOp(1101, logop, 1, LOGOP);
4270     logop->op_type = OP_COND_EXPR;
4271     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4272     logop->op_first = first;
4273     logop->op_flags = (U8)(flags | OPf_KIDS);
4274     logop->op_private = (U8)(1 | (flags >> 8));
4275     logop->op_other = LINKLIST(trueop);
4276     logop->op_next = LINKLIST(falseop);
4277
4278     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4279             logop);
4280
4281     /* establish postfix order */
4282     start = LINKLIST(first);
4283     first->op_next = (OP*)logop;
4284
4285     first->op_sibling = trueop;
4286     trueop->op_sibling = falseop;
4287     o = newUNOP(OP_NULL, 0, (OP*)logop);
4288
4289     trueop->op_next = falseop->op_next = o;
4290
4291     o->op_next = start;
4292     return o;
4293 }
4294
4295 OP *
4296 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4297 {
4298     dVAR;
4299     LOGOP *range;
4300     OP *flip;
4301     OP *flop;
4302     OP *leftstart;
4303     OP *o;
4304
4305     NewOp(1101, range, 1, LOGOP);
4306
4307     range->op_type = OP_RANGE;
4308     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4309     range->op_first = left;
4310     range->op_flags = OPf_KIDS;
4311     leftstart = LINKLIST(left);
4312     range->op_other = LINKLIST(right);
4313     range->op_private = (U8)(1 | (flags >> 8));
4314
4315     left->op_sibling = right;
4316
4317     range->op_next = (OP*)range;
4318     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4319     flop = newUNOP(OP_FLOP, 0, flip);
4320     o = newUNOP(OP_NULL, 0, flop);
4321     linklist(flop);
4322     range->op_next = leftstart;
4323
4324     left->op_next = flip;
4325     right->op_next = flop;
4326
4327     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4328     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4329     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4330     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4331
4332     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4333     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4334
4335     flip->op_next = o;
4336     if (!flip->op_private || !flop->op_private)
4337         linklist(o);            /* blow off optimizer unless constant */
4338
4339     return o;
4340 }
4341
4342 OP *
4343 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4344 {
4345     dVAR;
4346     OP* listop;
4347     OP* o;
4348     const bool once = block && block->op_flags & OPf_SPECIAL &&
4349       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4350
4351     PERL_UNUSED_ARG(debuggable);
4352
4353     if (expr) {
4354         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4355             return block;       /* do {} while 0 does once */
4356         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4357             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4358             expr = newUNOP(OP_DEFINED, 0,
4359                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4360         } else if (expr->op_flags & OPf_KIDS) {
4361             const OP * const k1 = ((UNOP*)expr)->op_first;
4362             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4363             switch (expr->op_type) {
4364               case OP_NULL:
4365                 if (k2 && k2->op_type == OP_READLINE
4366                       && (k2->op_flags & OPf_STACKED)
4367                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4368                     expr = newUNOP(OP_DEFINED, 0, expr);
4369                 break;
4370
4371               case OP_SASSIGN:
4372                 if (k1 && (k1->op_type == OP_READDIR
4373                       || k1->op_type == OP_GLOB
4374                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4375                       || k1->op_type == OP_EACH))
4376                     expr = newUNOP(OP_DEFINED, 0, expr);
4377                 break;
4378             }
4379         }
4380     }
4381
4382     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4383      * op, in listop. This is wrong. [perl #27024] */
4384     if (!block)
4385         block = newOP(OP_NULL, 0);
4386     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4387     o = new_logop(OP_AND, 0, &expr, &listop);
4388
4389     if (listop)
4390         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4391
4392     if (once && o != listop)
4393         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4394
4395     if (o == listop)
4396         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4397
4398     o->op_flags |= flags;
4399     o = scope(o);
4400     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4401     return o;
4402 }
4403
4404 OP *
4405 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4406 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4407 {
4408     dVAR;
4409     OP *redo;
4410     OP *next = NULL;
4411     OP *listop;
4412     OP *o;
4413     U8 loopflags = 0;
4414
4415     PERL_UNUSED_ARG(debuggable);
4416
4417     if (expr) {
4418         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4419                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4420             expr = newUNOP(OP_DEFINED, 0,
4421                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4422         } else if (expr->op_flags & OPf_KIDS) {
4423             const OP * const k1 = ((UNOP*)expr)->op_first;
4424             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4425             switch (expr->op_type) {
4426               case OP_NULL:
4427                 if (k2 && k2->op_type == OP_READLINE
4428                       && (k2->op_flags & OPf_STACKED)
4429                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4430                     expr = newUNOP(OP_DEFINED, 0, expr);
4431                 break;
4432
4433               case OP_SASSIGN:
4434                 if (k1 && (k1->op_type == OP_READDIR
4435                       || k1->op_type == OP_GLOB
4436                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4437                       || k1->op_type == OP_EACH))
4438                     expr = newUNOP(OP_DEFINED, 0, expr);
4439                 break;
4440             }
4441         }
4442     }
4443
4444     if (!block)
4445         block = newOP(OP_NULL, 0);
4446     else if (cont || has_my) {
4447         block = scope(block);
4448     }
4449
4450     if (cont) {
4451         next = LINKLIST(cont);
4452     }
4453     if (expr) {
4454         OP * const unstack = newOP(OP_UNSTACK, 0);
4455         if (!next)
4456             next = unstack;
4457         cont = append_elem(OP_LINESEQ, cont, unstack);
4458     }
4459
4460     assert(block);
4461     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4462     assert(listop);
4463     redo = LINKLIST(listop);
4464
4465     if (expr) {
4466         PL_copline = (line_t)whileline;
4467         scalar(listop);
4468         o = new_logop(OP_AND, 0, &expr, &listop);
4469         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4470             op_free(expr);              /* oops, it's a while (0) */
4471             op_free((OP*)loop);
4472             return NULL;                /* listop already freed by new_logop */
4473         }
4474         if (listop)
4475             ((LISTOP*)listop)->op_last->op_next =
4476                 (o == listop ? redo : LINKLIST(o));
4477     }
4478     else
4479         o = listop;
4480
4481     if (!loop) {
4482         NewOp(1101,loop,1,LOOP);
4483         loop->op_type = OP_ENTERLOOP;
4484         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4485         loop->op_private = 0;
4486         loop->op_next = (OP*)loop;
4487     }
4488
4489     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4490
4491     loop->op_redoop = redo;
4492     loop->op_lastop = o;
4493     o->op_private |= loopflags;
4494
4495     if (next)
4496         loop->op_nextop = next;
4497     else
4498         loop->op_nextop = o;
4499
4500     o->op_flags |= flags;
4501     o->op_private |= (flags >> 8);
4502     return o;
4503 }
4504
4505 OP *
4506 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4507 {
4508     dVAR;
4509     LOOP *loop;
4510     OP *wop;
4511     PADOFFSET padoff = 0;
4512     I32 iterflags = 0;
4513     I32 iterpflags = 0;
4514     OP *madsv = NULL;
4515
4516     if (sv) {
4517         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4518             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4519             sv->op_type = OP_RV2GV;
4520             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4521             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4522                 iterpflags |= OPpITER_DEF;
4523         }
4524         else if (sv->op_type == OP_PADSV) { /* private variable */
4525             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4526             padoff = sv->op_targ;
4527             if (PL_madskills)
4528                 madsv = sv;
4529             else {
4530                 sv->op_targ = 0;
4531                 op_free(sv);
4532             }
4533             sv = NULL;
4534         }
4535         else
4536             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4537         if (padoff) {
4538             SV *const namesv = PAD_COMPNAME_SV(padoff);
4539             STRLEN len;
4540             const char *const name = SvPV_const(namesv, len);
4541
4542             if (len == 2 && name[0] == '$' && name[1] == '_')
4543                 iterpflags |= OPpITER_DEF;
4544         }
4545     }
4546     else {
4547         const PADOFFSET offset = pad_findmy("$_");
4548         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4549             sv = newGVOP(OP_GV, 0, PL_defgv);
4550         }
4551         else {
4552             padoff = offset;
4553         }
4554         iterpflags |= OPpITER_DEF;
4555     }
4556     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4557         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4558         iterflags |= OPf_STACKED;
4559     }
4560     else if (expr->op_type == OP_NULL &&
4561              (expr->op_flags & OPf_KIDS) &&
4562              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4563     {
4564         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4565          * set the STACKED flag to indicate that these values are to be
4566          * treated as min/max values by 'pp_iterinit'.
4567          */
4568         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4569         LOGOP* const range = (LOGOP*) flip->op_first;
4570         OP* const left  = range->op_first;
4571         OP* const right = left->op_sibling;
4572         LISTOP* listop;
4573
4574         range->op_flags &= ~OPf_KIDS;
4575         range->op_first = NULL;
4576
4577         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4578         listop->op_first->op_next = range->op_next;
4579         left->op_next = range->op_other;
4580         right->op_next = (OP*)listop;
4581         listop->op_next = listop->op_first;
4582
4583 #ifdef PERL_MAD
4584         op_getmad(expr,(OP*)listop,'O');
4585 #else
4586         op_free(expr);
4587 #endif
4588         expr = (OP*)(listop);
4589         op_null(expr);
4590         iterflags |= OPf_STACKED;
4591     }
4592     else {
4593         expr = mod(force_list(expr), OP_GREPSTART);
4594     }
4595
4596     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4597                                append_elem(OP_LIST, expr, scalar(sv))));
4598     assert(!loop->op_next);
4599     /* for my  $x () sets OPpLVAL_INTRO;
4600      * for our $x () sets OPpOUR_INTRO */
4601     loop->op_private = (U8)iterpflags;
4602 #ifdef PL_OP_SLAB_ALLOC
4603     {
4604         LOOP *tmp;
4605         NewOp(1234,tmp,1,LOOP);
4606         Copy(loop,tmp,1,LISTOP);
4607         S_op_destroy(aTHX_ (OP*)loop);
4608         loop = tmp;
4609     }
4610 #else
4611     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4612 #endif
4613     loop->op_targ = padoff;
4614     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4615     if (madsv)
4616         op_getmad(madsv, (OP*)loop, 'v');
4617     PL_copline = forline;
4618     return newSTATEOP(0, label, wop);
4619 }
4620
4621 OP*
4622 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4623 {
4624     dVAR;
4625     OP *o;
4626
4627     if (type != OP_GOTO || label->op_type == OP_CONST) {
4628         /* "last()" means "last" */
4629         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4630             o = newOP(type, OPf_SPECIAL);
4631         else {
4632             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4633                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4634                                         : ""));
4635         }
4636 #ifdef PERL_MAD
4637         op_getmad(label,o,'L');
4638 #else
4639         op_free(label);
4640 #endif
4641     }
4642     else {
4643         /* Check whether it's going to be a goto &function */
4644         if (label->op_type == OP_ENTERSUB
4645                 && !(label->op_flags & OPf_STACKED))
4646             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4647         o = newUNOP(type, OPf_STACKED, label);
4648     }
4649     PL_hints |= HINT_BLOCK_SCOPE;
4650     return o;
4651 }
4652
4653 /* if the condition is a literal array or hash
4654    (or @{ ... } etc), make a reference to it.
4655  */
4656 STATIC OP *
4657 S_ref_array_or_hash(pTHX_ OP *cond)
4658 {
4659     if (cond
4660     && (cond->op_type == OP_RV2AV
4661     ||  cond->op_type == OP_PADAV
4662     ||  cond->op_type == OP_RV2HV
4663     ||  cond->op_type == OP_PADHV))
4664
4665         return newUNOP(OP_REFGEN,
4666             0, mod(cond, OP_REFGEN));
4667
4668     else
4669         return cond;
4670 }
4671
4672 /* These construct the optree fragments representing given()
4673    and when() blocks.
4674
4675    entergiven and enterwhen are LOGOPs; the op_other pointer
4676    points up to the associated leave op. We need this so we
4677    can put it in the context and make break/continue work.
4678    (Also, of course, pp_enterwhen will jump straight to
4679    op_other if the match fails.)
4680  */
4681
4682 STATIC
4683 OP *
4684 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4685                    I32 enter_opcode, I32 leave_opcode,
4686                    PADOFFSET entertarg)
4687 {
4688     dVAR;
4689     LOGOP *enterop;
4690     OP *o;
4691
4692     NewOp(1101, enterop, 1, LOGOP);
4693     enterop->op_type = enter_opcode;
4694     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4695     enterop->op_flags =  (U8) OPf_KIDS;
4696     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4697     enterop->op_private = 0;
4698
4699     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4700
4701     if (cond) {
4702         enterop->op_first = scalar(cond);
4703         cond->op_sibling = block;
4704
4705         o->op_next = LINKLIST(cond);
4706         cond->op_next = (OP *) enterop;
4707     }
4708     else {
4709         /* This is a default {} block */
4710         enterop->op_first = block;
4711         enterop->op_flags |= OPf_SPECIAL;
4712
4713         o->op_next = (OP *) enterop;
4714     }
4715
4716     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4717                                        entergiven and enterwhen both
4718                                        use ck_null() */
4719
4720     enterop->op_next = LINKLIST(block);
4721     block->op_next = enterop->op_other = o;
4722
4723     return o;
4724 }
4725
4726 /* Does this look like a boolean operation? For these purposes
4727    a boolean operation is:
4728      - a subroutine call [*]
4729      - a logical connective
4730      - a comparison operator
4731      - a filetest operator, with the exception of -s -M -A -C
4732      - defined(), exists() or eof()
4733      - /$re/ or $foo =~ /$re/
4734
4735    [*] possibly surprising
4736  */
4737 STATIC
4738 bool
4739 S_looks_like_bool(pTHX_ const OP *o)
4740 {
4741     dVAR;
4742     switch(o->op_type) {
4743         case OP_OR:
4744             return looks_like_bool(cLOGOPo->op_first);
4745
4746         case OP_AND:
4747             return (
4748                 looks_like_bool(cLOGOPo->op_first)
4749              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4750
4751         case OP_ENTERSUB:
4752
4753         case OP_NOT:    case OP_XOR:
4754         /* Note that OP_DOR is not here */
4755
4756         case OP_EQ:     case OP_NE:     case OP_LT:
4757         case OP_GT:     case OP_LE:     case OP_GE:
4758
4759         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4760         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4761
4762         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4763         case OP_SGT:    case OP_SLE:    case OP_SGE:
4764
4765         case OP_SMARTMATCH:
4766
4767         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4768         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4769         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4770         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4771         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4772         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4773         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4774         case OP_FTTEXT:   case OP_FTBINARY:
4775
4776         case OP_DEFINED: case OP_EXISTS:
4777         case OP_MATCH:   case OP_EOF:
4778
4779             return TRUE;
4780
4781         case OP_CONST:
4782             /* Detect comparisons that have been optimized away */
4783             if (cSVOPo->op_sv == &PL_sv_yes
4784             ||  cSVOPo->op_sv == &PL_sv_no)
4785
4786                 return TRUE;
4787
4788         /* FALL THROUGH */
4789         default:
4790             return FALSE;
4791     }
4792 }
4793
4794 OP *
4795 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4796 {
4797     dVAR;
4798     assert( cond );
4799     return newGIVWHENOP(
4800         ref_array_or_hash(cond),
4801         block,
4802         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4803         defsv_off);
4804 }
4805
4806 /* If cond is null, this is a default {} block */
4807 OP *
4808 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4809 {
4810     const bool cond_llb = (!cond || looks_like_bool(cond));
4811     OP *cond_op;
4812
4813     if (cond_llb)
4814         cond_op = cond;
4815     else {
4816         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4817                 newDEFSVOP(),
4818                 scalar(ref_array_or_hash(cond)));
4819     }
4820
4821     return newGIVWHENOP(
4822         cond_op,
4823         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4824         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4825 }
4826
4827 /*
4828 =for apidoc cv_undef
4829
4830 Clear out all the active components of a CV. This can happen either
4831 by an explicit C<undef &foo>, or by the reference count going to zero.
4832 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4833 children can still follow the full lexical scope chain.
4834
4835 =cut
4836 */
4837
4838 void
4839 Perl_cv_undef(pTHX_ CV *cv)
4840 {
4841     dVAR;
4842 #ifdef USE_ITHREADS
4843     if (CvFILE(cv) && !CvISXSUB(cv)) {
4844         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4845         Safefree(CvFILE(cv));
4846     }
4847     CvFILE(cv) = NULL;
4848 #endif
4849
4850     if (!CvISXSUB(cv) && CvROOT(cv)) {
4851         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4852             Perl_croak(aTHX_ "Can't undef active subroutine");
4853         ENTER;
4854
4855         PAD_SAVE_SETNULLPAD();
4856
4857         op_free(CvROOT(cv));
4858         CvROOT(cv) = NULL;
4859         CvSTART(cv) = NULL;
4860         LEAVE;
4861     }
4862     SvPOK_off((SV*)cv);         /* forget prototype */
4863     CvGV(cv) = NULL;
4864
4865     pad_undef(cv);
4866
4867     /* remove CvOUTSIDE unless this is an undef rather than a free */
4868     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4869         if (!CvWEAKOUTSIDE(cv))
4870             SvREFCNT_dec(CvOUTSIDE(cv));
4871         CvOUTSIDE(cv) = NULL;
4872     }
4873     if (CvCONST(cv)) {
4874         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4875         CvCONST_off(cv);
4876     }
4877     if (CvISXSUB(cv) && CvXSUB(cv)) {
4878         CvXSUB(cv) = NULL;
4879     }
4880     /* delete all flags except WEAKOUTSIDE */
4881     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4882 }
4883
4884 void
4885 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4886                     const STRLEN len)
4887 {
4888     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4889        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
4890     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
4891          || (p && (len != SvCUR(cv) /* Not the same length.  */
4892                    || memNE(p, SvPVX_const(cv), len))))
4893          && ckWARN_d(WARN_PROTOTYPE)) {
4894         SV* const msg = sv_newmortal();
4895         SV* name = NULL;
4896
4897         if (gv)
4898             gv_efullname3(name = sv_newmortal(), gv, NULL);
4899         sv_setpv(msg, "Prototype mismatch:");
4900         if (name)
4901             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4902         if (SvPOK(cv))
4903             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4904         else
4905             sv_catpvs(msg, ": none");
4906         sv_catpvs(msg, " vs ");
4907         if (p)
4908             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4909         else
4910             sv_catpvs(msg, "none");
4911         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4912     }
4913 }
4914
4915 static void const_sv_xsub(pTHX_ CV* cv);
4916
4917 /*
4918
4919 =head1 Optree Manipulation Functions
4920
4921 =for apidoc cv_const_sv
4922
4923 If C<cv> is a constant sub eligible for inlining. returns the constant
4924 value returned by the sub.  Otherwise, returns NULL.
4925
4926 Constant subs can be created with C<newCONSTSUB> or as described in
4927 L<perlsub/"Constant Functions">.
4928
4929 =cut
4930 */
4931 SV *
4932 Perl_cv_const_sv(pTHX_ CV *cv)
4933 {
4934     PERL_UNUSED_CONTEXT;
4935     if (!cv)
4936         return NULL;
4937     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4938         return NULL;
4939     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4940 }
4941
4942 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4943  * Can be called in 3 ways:
4944  *
4945  * !cv
4946  *      look for a single OP_CONST with attached value: return the value
4947  *
4948  * cv && CvCLONE(cv) && !CvCONST(cv)
4949  *
4950  *      examine the clone prototype, and if contains only a single
4951  *      OP_CONST referencing a pad const, or a single PADSV referencing
4952  *      an outer lexical, return a non-zero value to indicate the CV is
4953  *      a candidate for "constizing" at clone time
4954  *
4955  * cv && CvCONST(cv)
4956  *
4957  *      We have just cloned an anon prototype that was marked as a const
4958  *      candidiate. Try to grab the current value, and in the case of
4959  *      PADSV, ignore it if it has multiple references. Return the value.
4960  */
4961
4962 SV *
4963 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4964 {
4965     dVAR;
4966     SV *sv = NULL;
4967
4968     if (!o)
4969         return NULL;
4970
4971     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4972         o = cLISTOPo->op_first->op_sibling;
4973
4974     for (; o; o = o->op_next) {
4975         const OPCODE type = o->op_type;
4976
4977         if (sv && o->op_next == o)
4978             return sv;
4979         if (o->op_next != o) {
4980             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4981                 continue;
4982             if (type == OP_DBSTATE)
4983                 continue;
4984         }
4985         if (type == OP_LEAVESUB || type == OP_RETURN)
4986             break;
4987         if (sv)
4988             return NULL;
4989         if (type == OP_CONST && cSVOPo->op_sv)
4990             sv = cSVOPo->op_sv;
4991         else if (cv && type == OP_CONST) {
4992             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4993             if (!sv)
4994                 return NULL;
4995         }
4996         else if (cv && type == OP_PADSV) {
4997             if (CvCONST(cv)) { /* newly cloned anon */
4998                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4999                 /* the candidate should have 1 ref from this pad and 1 ref
5000                  * from the parent */
5001                 if (!sv || SvREFCNT(sv) != 2)
5002                     return NULL;
5003                 sv = newSVsv(sv);
5004                 SvREADONLY_on(sv);
5005                 return sv;
5006             }
5007             else {
5008                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5009                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5010             }
5011         }
5012         else {
5013             return NULL;
5014         }
5015     }
5016     return sv;
5017 }
5018
5019 #ifdef PERL_MAD
5020 OP *
5021 #else
5022 void
5023 #endif
5024 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5025 {
5026 #if 0
5027     /* This would be the return value, but the return cannot be reached.  */
5028     OP* pegop = newOP(OP_NULL, 0);
5029 #endif
5030
5031     PERL_UNUSED_ARG(floor);
5032
5033     if (o)
5034         SAVEFREEOP(o);
5035     if (proto)
5036         SAVEFREEOP(proto);
5037     if (attrs)
5038         SAVEFREEOP(attrs);
5039     if (block)
5040         SAVEFREEOP(block);
5041     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5042 #ifdef PERL_MAD
5043     NORETURN_FUNCTION_END;
5044 #endif
5045 }
5046
5047 CV *
5048 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5049 {
5050     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5051 }
5052
5053 CV *
5054 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5055 {
5056     dVAR;
5057     const char *aname;
5058     GV *gv;
5059     const char *ps;
5060     STRLEN ps_len;
5061     register CV *cv = NULL;
5062     SV *const_sv;
5063     /* If the subroutine has no body, no attributes, and no builtin attributes
5064        then it's just a sub declaration, and we may be able to get away with
5065        storing with a placeholder scalar in the symbol table, rather than a
5066        full GV and CV.  If anything is present then it will take a full CV to
5067        store it.  */
5068     const I32 gv_fetch_flags
5069         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5070            || PL_madskills)
5071         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5072     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5073
5074     if (proto) {
5075         assert(proto->op_type == OP_CONST);
5076         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5077     }
5078     else
5079         ps = NULL;
5080
5081     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5082         SV * const sv = sv_newmortal();
5083         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5084                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5085                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5086         aname = SvPVX_const(sv);
5087     }
5088     else
5089         aname = NULL;
5090
5091     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5092         : gv_fetchpv(aname ? aname
5093                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5094                      gv_fetch_flags, SVt_PVCV);
5095
5096     if (!PL_madskills) {
5097         if (o)
5098             SAVEFREEOP(o);
5099         if (proto)
5100             SAVEFREEOP(proto);
5101         if (attrs)
5102             SAVEFREEOP(attrs);
5103     }
5104
5105     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5106                                            maximum a prototype before. */
5107         if (SvTYPE(gv) > SVt_NULL) {
5108             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5109                 && ckWARN_d(WARN_PROTOTYPE))
5110             {
5111                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5112             }
5113             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5114         }
5115         if (ps)
5116             sv_setpvn((SV*)gv, ps, ps_len);
5117         else
5118             sv_setiv((SV*)gv, -1);
5119         SvREFCNT_dec(PL_compcv);
5120         cv = PL_compcv = NULL;
5121         PL_sub_generation++;
5122         goto done;
5123     }
5124
5125     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5126
5127 #ifdef GV_UNIQUE_CHECK
5128     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5129         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5130     }
5131 #endif
5132
5133     if (!block || !ps || *ps || attrs
5134         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5135 #ifdef PERL_MAD
5136         || block->op_type == OP_NULL
5137 #endif
5138         )
5139         const_sv = NULL;
5140     else
5141         const_sv = op_const_sv(block, NULL);
5142
5143     if (cv) {
5144         const bool exists = CvROOT(cv) || CvXSUB(cv);
5145
5146 #ifdef GV_UNIQUE_CHECK
5147         if (exists && GvUNIQUE(gv)) {
5148             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5149         }
5150 #endif
5151
5152         /* if the subroutine doesn't exist and wasn't pre-declared
5153          * with a prototype, assume it will be AUTOLOADed,
5154          * skipping the prototype check
5155          */
5156         if (exists || SvPOK(cv))
5157             cv_ckproto_len(cv, gv, ps, ps_len);
5158         /* already defined (or promised)? */
5159         if (exists || GvASSUMECV(gv)) {
5160             if ((!block
5161 #ifdef PERL_MAD
5162                  || block->op_type == OP_NULL
5163 #endif
5164                  )&& !attrs) {
5165                 if (CvFLAGS(PL_compcv)) {
5166                     /* might have had built-in attrs applied */
5167                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5168                 }
5169                 /* just a "sub foo;" when &foo is already defined */
5170                 SAVEFREESV(PL_compcv);
5171                 goto done;
5172             }
5173             if (block
5174 #ifdef PERL_MAD
5175                 && block->op_type != OP_NULL
5176 #endif
5177                 ) {
5178                 if (ckWARN(WARN_REDEFINE)
5179                     || (CvCONST(cv)
5180                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5181                 {
5182                     const line_t oldline = CopLINE(PL_curcop);
5183                     if (PL_copline != NOLINE)
5184                         CopLINE_set(PL_curcop, PL_copline);
5185                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5186                         CvCONST(cv) ? "Constant subroutine %s redefined"
5187                                     : "Subroutine %s redefined", name);
5188                     CopLINE_set(PL_curcop, oldline);
5189                 }
5190 #ifdef PERL_MAD
5191                 if (!PL_minus_c)        /* keep old one around for madskills */
5192 #endif
5193                     {
5194                         /* (PL_madskills unset in used file.) */
5195                         SvREFCNT_dec(cv);
5196                     }
5197                 cv = NULL;
5198             }
5199         }
5200     }
5201     if (const_sv) {
5202         SvREFCNT_inc_simple_void_NN(const_sv);
5203         if (cv) {
5204             assert(!CvROOT(cv) && !CvCONST(cv));
5205             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5206             CvXSUBANY(cv).any_ptr = const_sv;
5207             CvXSUB(cv) = const_sv_xsub;
5208             CvCONST_on(cv);
5209             CvISXSUB_on(cv);
5210         }
5211         else {
5212             GvCV(gv) = NULL;
5213             cv = newCONSTSUB(NULL, name, const_sv);
5214         }
5215         PL_sub_generation++;
5216         if (PL_madskills)
5217             goto install_block;
5218         op_free(block);
5219         SvREFCNT_dec(PL_compcv);
5220         PL_compcv = NULL;
5221         goto done;
5222     }
5223     if (attrs) {
5224         HV *stash;
5225         SV *rcv;
5226
5227         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5228          * before we clobber PL_compcv.
5229          */
5230         if (cv && (!block
5231 #ifdef PERL_MAD
5232                     || block->op_type == OP_NULL
5233 #endif
5234                     )) {
5235             rcv = (SV*)cv;
5236             /* Might have had built-in attributes applied -- propagate them. */
5237             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5238             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5239                 stash = GvSTASH(CvGV(cv));
5240             else if (CvSTASH(cv))
5241                 stash = CvSTASH(cv);
5242             else
5243                 stash = PL_curstash;
5244         }
5245         else {
5246             /* possibly about to re-define existing subr -- ignore old cv */
5247             rcv = (SV*)PL_compcv;
5248             if (name && GvSTASH(gv))
5249                 stash = GvSTASH(gv);
5250             else
5251                 stash = PL_curstash;
5252         }
5253         apply_attrs(stash, rcv, attrs, FALSE);
5254     }
5255     if (cv) {                           /* must reuse cv if autoloaded */
5256         if (
5257 #ifdef PERL_MAD
5258             (
5259 #endif
5260              !block
5261 #ifdef PERL_MAD
5262              || block->op_type == OP_NULL) && !PL_madskills
5263 #endif
5264              ) {
5265             /* got here with just attrs -- work done, so bug out */
5266             SAVEFREESV(PL_compcv);
5267             goto done;
5268         }
5269         /* transfer PL_compcv to cv */
5270         cv_undef(cv);
5271         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5272         if (!CvWEAKOUTSIDE(cv))
5273             SvREFCNT_dec(CvOUTSIDE(cv));
5274         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5275         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5276         CvOUTSIDE(PL_compcv) = 0;
5277         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5278         CvPADLIST(PL_compcv) = 0;
5279         /* inner references to PL_compcv must be fixed up ... */
5280         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5281         /* ... before we throw it away */
5282         SvREFCNT_dec(PL_compcv);
5283         PL_compcv = cv;
5284         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5285           ++PL_sub_generation;
5286     }
5287     else {
5288         cv = PL_compcv;
5289         if (name) {
5290             GvCV(gv) = cv;
5291             if (PL_madskills) {
5292                 if (strEQ(name, "import")) {
5293                     PL_formfeed = (SV*)cv;
5294                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5295                 }
5296             }
5297             GvCVGEN(gv) = 0;
5298             PL_sub_generation++;
5299         }
5300     }
5301     CvGV(cv) = gv;
5302     CvFILE_set_from_cop(cv, PL_curcop);
5303     CvSTASH(cv) = PL_curstash;
5304
5305     if (ps)
5306         sv_setpvn((SV*)cv, ps, ps_len);
5307
5308     if (PL_error_count) {
5309         op_free(block);
5310         block = NULL;
5311         if (name) {
5312             const char *s = strrchr(name, ':');
5313             s = s ? s+1 : name;
5314             if (strEQ(s, "BEGIN")) {
5315                 const char not_safe[] =
5316                     "BEGIN not safe after errors--compilation aborted";
5317                 if (PL_in_eval & EVAL_KEEPERR)
5318                     Perl_croak(aTHX_ not_safe);
5319                 else {
5320                     /* force display of errors found but not reported */
5321                     sv_catpv(ERRSV, not_safe);
5322                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5323                 }
5324             }
5325         }
5326     }
5327  install_block:
5328     if (!block)
5329         goto done;
5330
5331     if (CvLVALUE(cv)) {
5332         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5333                              mod(scalarseq(block), OP_LEAVESUBLV));
5334         block->op_attached = 1;
5335     }
5336     else {
5337         /* This makes sub {}; work as expected.  */
5338         if (block->op_type == OP_STUB) {
5339             OP* const newblock = newSTATEOP(0, NULL, 0);
5340 #ifdef PERL_MAD
5341             op_getmad(block,newblock,'B');
5342 #else
5343             op_free(block);
5344 #endif
5345             block = newblock;
5346         }
5347         else
5348             block->op_attached = 1;
5349         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5350     }
5351     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5352     OpREFCNT_set(CvROOT(cv), 1);
5353     CvSTART(cv) = LINKLIST(CvROOT(cv));
5354     CvROOT(cv)->op_next = 0;
5355     CALL_PEEP(CvSTART(cv));
5356
5357     /* now that optimizer has done its work, adjust pad values */
5358
5359     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5360
5361     if (CvCLONE(cv)) {
5362         assert(!CvCONST(cv));
5363         if (ps && !*ps && op_const_sv(block, cv))
5364             CvCONST_on(cv);
5365     }
5366
5367     if (name || aname) {
5368         const char *s;
5369         const char * const tname = (name ? name : aname);
5370
5371         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5372             SV * const sv = newSV(0);
5373             SV * const tmpstr = sv_newmortal();
5374             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5375                                                   GV_ADDMULTI, SVt_PVHV);
5376             HV *hv;
5377
5378             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5379                            CopFILE(PL_curcop),
5380                            (long)PL_subline, (long)CopLINE(PL_curcop));
5381             gv_efullname3(tmpstr, gv, NULL);
5382             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5383             hv = GvHVn(db_postponed);
5384             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5385                 CV * const pcv = GvCV(db_postponed);
5386                 if (pcv) {
5387                     dSP;
5388                     PUSHMARK(SP);
5389                     XPUSHs(tmpstr);
5390                     PUTBACK;
5391                     call_sv((SV*)pcv, G_DISCARD);
5392                 }
5393             }
5394         }
5395
5396         if ((s = strrchr(tname,':')))
5397             s++;
5398         else
5399             s = tname;
5400
5401         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5402             goto done;
5403
5404         if (strEQ(s, "BEGIN") && !PL_error_count) {
5405             const I32 oldscope = PL_scopestack_ix;
5406             ENTER;
5407             SAVECOPFILE(&PL_compiling);
5408             SAVECOPLINE(&PL_compiling);
5409
5410             if (!PL_beginav)
5411                 PL_beginav = newAV();
5412             DEBUG_x( dump_sub(gv) );
5413             av_push(PL_beginav, (SV*)cv);
5414             GvCV(gv) = 0;               /* cv has been hijacked */
5415             call_list(oldscope, PL_beginav);
5416
5417             PL_curcop = &PL_compiling;
5418             CopHINTS_set(&PL_compiling, PL_hints);
5419             LEAVE;
5420         }
5421         else if (strEQ(s, "END") && !PL_error_count) {
5422             if (!PL_endav)
5423                 PL_endav = newAV();
5424             DEBUG_x( dump_sub(gv) );
5425             av_unshift(PL_endav, 1);
5426             av_store(PL_endav, 0, (SV*)cv);
5427             GvCV(gv) = 0;               /* cv has been hijacked */
5428         }
5429         else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5430             /* It's never too late to run a unitcheck block */
5431             if (!PL_unitcheckav)
5432                 PL_unitcheckav = newAV();
5433             DEBUG_x( dump_sub(gv) );
5434             av_unshift(PL_unitcheckav, 1);
5435             av_store(PL_unitcheckav, 0, (SV*)cv);
5436             GvCV(gv) = 0;               /* cv has been hijacked */
5437         }
5438         else if (strEQ(s, "CHECK") && !PL_error_count) {
5439             if (!PL_checkav)
5440                 PL_checkav = newAV();
5441             DEBUG_x( dump_sub(gv) );
5442             if (PL_main_start && ckWARN(WARN_VOID))
5443                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5444             av_unshift(PL_checkav, 1);
5445             av_store(PL_checkav, 0, (SV*)cv);
5446             GvCV(gv) = 0;               /* cv has been hijacked */
5447         }
5448         else if (strEQ(s, "INIT") && !PL_error_count) {
5449             if (!PL_initav)
5450                 PL_initav = newAV();
5451             DEBUG_x( dump_sub(gv) );
5452             if (PL_main_start && ckWARN(WARN_VOID))
5453                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5454             av_push(PL_initav, (SV*)cv);
5455             GvCV(gv) = 0;               /* cv has been hijacked */
5456         }
5457     }
5458
5459   done:
5460     PL_copline = NOLINE;
5461     LEAVE_SCOPE(floor);
5462     return cv;
5463 }
5464
5465 /* XXX unsafe for threads if eval_owner isn't held */
5466 /*
5467 =for apidoc newCONSTSUB
5468
5469 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5470 eligible for inlining at compile-time.
5471
5472 =cut
5473 */
5474
5475 CV *
5476 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5477 {
5478     dVAR;
5479     CV* cv;
5480 #ifdef USE_ITHREADS
5481     const char *const temp_p = CopFILE(PL_curcop);
5482     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5483 #else
5484     SV *const temp_sv = CopFILESV(PL_curcop);
5485     STRLEN len;
5486     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5487 #endif
5488     char *const file = savepvn(temp_p, temp_p ? len : 0);
5489
5490     ENTER;
5491
5492     SAVECOPLINE(PL_curcop);
5493     CopLINE_set(PL_curcop, PL_copline);
5494
5495     SAVEHINTS();
5496     PL_hints &= ~HINT_BLOCK_SCOPE;
5497
5498     if (stash) {
5499         SAVESPTR(PL_curstash);
5500         SAVECOPSTASH(PL_curcop);
5501         PL_curstash = stash;
5502         CopSTASH_set(PL_curcop,stash);
5503     }
5504
5505     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5506        and so doesn't get free()d.  (It's expected to be from the C pre-
5507        processor __FILE__ directive). But we need a dynamically allocated one,
5508        and we need it to get freed.  */
5509     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5510     CvXSUBANY(cv).any_ptr = sv;
5511     CvCONST_on(cv);
5512     Safefree(file);
5513
5514 #ifdef USE_ITHREADS
5515     if (stash)
5516         CopSTASH_free(PL_curcop);
5517 #endif
5518     LEAVE;
5519
5520     return cv;
5521 }
5522
5523 CV *
5524 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5525                  const char *const filename, const char *const proto,
5526                  U32 flags)
5527 {
5528     CV *cv = newXS(name, subaddr, filename);
5529
5530     if (flags & XS_DYNAMIC_FILENAME) {
5531         /* We need to "make arrangements" (ie cheat) to ensure that the
5532            filename lasts as long as the PVCV we just created, but also doesn't
5533            leak  */
5534         STRLEN filename_len = strlen(filename);
5535         STRLEN proto_and_file_len = filename_len;
5536         char *proto_and_file;
5537         STRLEN proto_len;
5538
5539         if (proto) {
5540             proto_len = strlen(proto);
5541             proto_and_file_len += proto_len;
5542
5543             Newx(proto_and_file, proto_and_file_len + 1, char);
5544             Copy(proto, proto_and_file, proto_len, char);
5545             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5546         } else {
5547             proto_len = 0;
5548             proto_and_file = savepvn(filename, filename_len);
5549         }
5550
5551         /* This gets free()d.  :-)  */
5552         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5553                         SV_HAS_TRAILING_NUL);
5554         if (proto) {
5555             /* This gives us the correct prototype, rather than one with the
5556                file name appended.  */
5557             SvCUR_set(cv, proto_len);
5558         } else {
5559             SvPOK_off(cv);
5560         }
5561         CvFILE(cv) = proto_and_file + proto_len;
5562     } else {
5563         sv_setpv((SV *)cv, proto);
5564     }
5565     return cv;
5566 }
5567
5568 /*
5569 =for apidoc U||newXS
5570
5571 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5572 static storage, as it is used directly as CvFILE(), without a copy being made.
5573
5574 =cut
5575 */
5576
5577 CV *
5578 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5579 {
5580     dVAR;
5581     GV * const gv = gv_fetchpv(name ? name :
5582                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5583                         GV_ADDMULTI, SVt_PVCV);
5584     register CV *cv;
5585
5586     if (!subaddr)
5587         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5588
5589     if ((cv = (name ? GvCV(gv) : NULL))) {
5590         if (GvCVGEN(gv)) {
5591             /* just a cached method */
5592             SvREFCNT_dec(cv);
5593             cv = NULL;
5594         }
5595         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5596             /* already defined (or promised) */
5597             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5598             if (ckWARN(WARN_REDEFINE)) {
5599                 GV * const gvcv = CvGV(cv);
5600                 if (gvcv) {
5601                     HV * const stash = GvSTASH(gvcv);
5602                     if (stash) {
5603                         const char *redefined_name = HvNAME_get(stash);
5604                         if ( strEQ(redefined_name,"autouse") ) {
5605                             const line_t oldline = CopLINE(PL_curcop);
5606                             if (PL_copline != NOLINE)
5607                                 CopLINE_set(PL_curcop, PL_copline);
5608                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5609                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5610                                                     : "Subroutine %s redefined"
5611                                         ,name);
5612                             CopLINE_set(PL_curcop, oldline);
5613                         }
5614                     }
5615                 }
5616             }
5617             SvREFCNT_dec(cv);
5618             cv = NULL;
5619         }
5620     }
5621
5622     if (cv)                             /* must reuse cv if autoloaded */
5623         cv_undef(cv);
5624     else {
5625         cv = (CV*)newSV(0);
5626         sv_upgrade((SV *)cv, SVt_PVCV);
5627         if (name) {
5628             GvCV(gv) = cv;
5629             GvCVGEN(gv) = 0;
5630             PL_sub_generation++;
5631         }
5632     }
5633     CvGV(cv) = gv;
5634     (void)gv_fetchfile(filename);
5635     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5636                                    an external constant string */
5637     CvISXSUB_on(cv);
5638     CvXSUB(cv) = subaddr;
5639
5640     if (name) {
5641         const char *s = strrchr(name,':');
5642         if (s)
5643             s++;
5644         else
5645             s = name;
5646
5647         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5648             goto done;
5649
5650         if (strEQ(s, "BEGIN")) {
5651             if (!PL_beginav)
5652                 PL_beginav = newAV();
5653             av_push(PL_beginav, (SV*)cv);
5654             GvCV(gv) = 0;               /* cv has been hijacked */
5655         }
5656         else if (strEQ(s, "END")) {
5657             if (!PL_endav)
5658                 PL_endav = newAV();
5659             av_unshift(PL_endav, 1);
5660             av_store(PL_endav, 0, (SV*)cv);
5661             GvCV(gv) = 0;               /* cv has been hijacked */
5662         }
5663         else if (strEQ(s, "CHECK")) {
5664             if (!PL_checkav)
5665                 PL_checkav = newAV();
5666             if (PL_main_start && ckWARN(WARN_VOID))
5667                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5668             av_unshift(PL_checkav, 1);
5669             av_store(PL_checkav, 0, (SV*)cv);
5670             GvCV(gv) = 0;               /* cv has been hijacked */
5671         }
5672         else if (strEQ(s, "INIT")) {
5673             if (!PL_initav)
5674                 PL_initav = newAV();
5675             if (PL_main_start && ckWARN(WARN_VOID))
5676                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5677             av_push(PL_initav, (SV*)cv);
5678             GvCV(gv) = 0;               /* cv has been hijacked */
5679         }
5680     }
5681     else
5682         CvANON_on(cv);
5683
5684 done:
5685     return cv;
5686 }
5687
5688 #ifdef PERL_MAD
5689 OP *
5690 #else
5691 void
5692 #endif
5693 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5694 {
5695     dVAR;
5696     register CV *cv;
5697 #ifdef PERL_MAD
5698     OP* pegop = newOP(OP_NULL, 0);
5699 #endif
5700
5701     GV * const gv = o
5702         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5703         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5704
5705 #ifdef GV_UNIQUE_CHECK
5706     if (GvUNIQUE(gv)) {
5707         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5708     }
5709 #endif
5710     GvMULTI_on(gv);
5711     if ((cv = GvFORM(gv))) {
5712         if (ckWARN(WARN_REDEFINE)) {
5713             const line_t oldline = CopLINE(PL_curcop);
5714             if (PL_copline != NOLINE)
5715                 CopLINE_set(PL_curcop, PL_copline);
5716             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5717                         o ? "Format %"SVf" redefined"
5718                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5719             CopLINE_set(PL_curcop, oldline);
5720         }
5721         SvREFCNT_dec(cv);
5722     }
5723     cv = PL_compcv;
5724     GvFORM(gv) = cv;
5725     CvGV(cv) = gv;
5726     CvFILE_set_from_cop(cv, PL_curcop);
5727
5728
5729     pad_tidy(padtidy_FORMAT);
5730     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5731     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5732     OpREFCNT_set(CvROOT(cv), 1);
5733     CvSTART(cv) = LINKLIST(CvROOT(cv));
5734     CvROOT(cv)->op_next = 0;
5735     CALL_PEEP(CvSTART(cv));
5736 #ifdef PERL_MAD
5737     op_getmad(o,pegop,'n');
5738     op_getmad_weak(block, pegop, 'b');
5739 #else
5740     op_free(o);
5741 #endif
5742     PL_copline = NOLINE;
5743     LEAVE_SCOPE(floor);
5744 #ifdef PERL_MAD
5745     return pegop;
5746 #endif
5747 }
5748
5749 OP *
5750 Perl_newANONLIST(pTHX_ OP *o)
5751 {
5752     return convert(OP_ANONLIST, OPf_SPECIAL, o);
5753 }
5754
5755 OP *
5756 Perl_newANONHASH(pTHX_ OP *o)
5757 {
5758     return convert(OP_ANONHASH, OPf_SPECIAL, o);
5759 }
5760
5761 OP *
5762 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5763 {
5764     return newANONATTRSUB(floor, proto, NULL, block);
5765 }
5766
5767 OP *
5768 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5769 {
5770     return newUNOP(OP_REFGEN, 0,
5771         newSVOP(OP_ANONCODE, 0,
5772                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5773 }
5774
5775 OP *
5776 Perl_oopsAV(pTHX_ OP *o)
5777 {
5778     dVAR;
5779     switch (o->op_type) {
5780     case OP_PADSV:
5781         o->op_type = OP_PADAV;
5782         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5783         return ref(o, OP_RV2AV);
5784
5785     case OP_RV2SV:
5786         o->op_type = OP_RV2AV;
5787         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5788         ref(o, OP_RV2AV);
5789         break;
5790
5791     default:
5792         if (ckWARN_d(WARN_INTERNAL))
5793             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5794         break;
5795     }
5796     return o;
5797 }
5798
5799 OP *
5800 Perl_oopsHV(pTHX_ OP *o)
5801 {
5802     dVAR;
5803     switch (o->op_type) {
5804     case OP_PADSV:
5805     case OP_PADAV:
5806         o->op_type = OP_PADHV;
5807         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5808         return ref(o, OP_RV2HV);
5809
5810     case OP_RV2SV:
5811     case OP_RV2AV:
5812         o->op_type = OP_RV2HV;
5813         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5814         ref(o, OP_RV2HV);
5815         break;
5816
5817     default:
5818         if (ckWARN_d(WARN_INTERNAL))
5819             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5820         break;
5821     }
5822     return o;
5823 }
5824
5825 OP *
5826 Perl_newAVREF(pTHX_ OP *o)
5827 {
5828     dVAR;
5829     if (o->op_type == OP_PADANY) {
5830         o->op_type = OP_PADAV;
5831         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5832         return o;
5833     }
5834     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5835                 && ckWARN(WARN_DEPRECATED)) {
5836         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5837                 "Using an array as a reference is deprecated");
5838     }
5839     return newUNOP(OP_RV2AV, 0, scalar(o));
5840 }
5841
5842 OP *
5843 Perl_newGVREF(pTHX_ I32 type, OP *o)
5844 {
5845     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5846         return newUNOP(OP_NULL, 0, o);
5847     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5848 }
5849
5850 OP *
5851 Perl_newHVREF(pTHX_ OP *o)
5852 {
5853     dVAR;
5854     if (o->op_type == OP_PADANY) {
5855         o->op_type = OP_PADHV;
5856         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5857         return o;
5858     }
5859     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5860                 && ckWARN(WARN_DEPRECATED)) {
5861         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5862                 "Using a hash as a reference is deprecated");
5863     }
5864     return newUNOP(OP_RV2HV, 0, scalar(o));
5865 }
5866
5867 OP *
5868 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5869 {
5870     return newUNOP(OP_RV2CV, flags, scalar(o));
5871 }
5872
5873 OP *
5874 Perl_newSVREF(pTHX_ OP *o)
5875 {
5876     dVAR;
5877     if (o->op_type == OP_PADANY) {
5878         o->op_type = OP_PADSV;
5879         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5880         return o;
5881     }
5882     return newUNOP(OP_RV2SV, 0, scalar(o));
5883 }
5884
5885 /* Check routines. See the comments at the top of this file for details
5886  * on when these are called */
5887
5888 OP *
5889 Perl_ck_anoncode(pTHX_ OP *o)
5890 {
5891     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5892     if (!PL_madskills)
5893         cSVOPo->op_sv = NULL;
5894     return o;
5895 }
5896
5897 OP *
5898 Perl_ck_bitop(pTHX_ OP *o)
5899 {
5900     dVAR;
5901 #define OP_IS_NUMCOMPARE(op) \
5902         ((op) == OP_LT   || (op) == OP_I_LT || \
5903          (op) == OP_GT   || (op) == OP_I_GT || \
5904          (op) == OP_LE   || (op) == OP_I_LE || \
5905          (op) == OP_GE   || (op) == OP_I_GE || \
5906          (op) == OP_EQ   || (op) == OP_I_EQ || \
5907          (op) == OP_NE   || (op) == OP_I_NE || \
5908          (op) == OP_NCMP || (op) == OP_I_NCMP)
5909     o->op_private = (U8)(PL_hints & HINT_INTEGER);
5910     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5911             && (o->op_type == OP_BIT_OR
5912              || o->op_type == OP_BIT_AND
5913              || o->op_type == OP_BIT_XOR))
5914     {
5915         const OP * const left = cBINOPo->op_first;
5916         const OP * const right = left->op_sibling;
5917         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5918                 (left->op_flags & OPf_PARENS) == 0) ||
5919             (OP_IS_NUMCOMPARE(right->op_type) &&
5920                 (right->op_flags & OPf_PARENS) == 0))
5921             if (ckWARN(WARN_PRECEDENCE))
5922                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5923                         "Possible precedence problem on bitwise %c operator",
5924                         o->op_type == OP_BIT_OR ? '|'
5925                             : o->op_type == OP_BIT_AND ? '&' : '^'
5926                         );
5927     }
5928     return o;
5929 }
5930
5931 OP *
5932 Perl_ck_concat(pTHX_ OP *o)
5933 {
5934     const OP * const kid = cUNOPo->op_first;
5935     PERL_UNUSED_CONTEXT;
5936     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5937             !(kUNOP->op_first->op_flags & OPf_MOD))
5938         o->op_flags |= OPf_STACKED;
5939     return o;
5940 }
5941
5942 OP *
5943 Perl_ck_spair(pTHX_ OP *o)
5944 {
5945     dVAR;
5946     if (o->op_flags & OPf_KIDS) {
5947         OP* newop;
5948         OP* kid;
5949         const OPCODE type = o->op_type;
5950         o = modkids(ck_fun(o), type);
5951         kid = cUNOPo->op_first;
5952         newop = kUNOP->op_first->op_sibling;
5953         if (newop) {
5954             const OPCODE type = newop->op_type;
5955             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5956                     type == OP_PADAV || type == OP_PADHV ||
5957                     type == OP_RV2AV || type == OP_RV2HV)
5958                 return o;
5959         }
5960 #ifdef PERL_MAD
5961         op_getmad(kUNOP->op_first,newop,'K');
5962 #else
5963         op_free(kUNOP->op_first);
5964 #endif
5965         kUNOP->op_first = newop;
5966     }
5967     o->op_ppaddr = PL_ppaddr[++o->op_type];
5968     return ck_fun(o);
5969 }
5970
5971 OP *
5972 Perl_ck_delete(pTHX_ OP *o)
5973 {
5974     o = ck_fun(o);
5975     o->op_private = 0;
5976     if (o->op_flags & OPf_KIDS) {
5977         OP * const kid = cUNOPo->op_first;
5978         switch (kid->op_type) {
5979         case OP_ASLICE:
5980             o->op_flags |= OPf_SPECIAL;
5981             /* FALL THROUGH */
5982         case OP_HSLICE:
5983             o->op_private |= OPpSLICE;
5984             break;
5985         case OP_AELEM:
5986             o->op_flags |= OPf_SPECIAL;
5987             /* FALL THROUGH */
5988         case OP_HELEM:
5989             break;
5990         default:
5991             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5992                   OP_DESC(o));
5993         }
5994         op_null(kid);
5995     }
5996     return o;
5997 }
5998
5999 OP *
6000 Perl_ck_die(pTHX_ OP *o)
6001 {
6002 #ifdef VMS
6003     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6004 #endif
6005     return ck_fun(o);
6006 }
6007
6008 OP *
6009 Perl_ck_eof(pTHX_ OP *o)
6010 {
6011     dVAR;
6012
6013     if (o->op_flags & OPf_KIDS) {
6014         if (cLISTOPo->op_first->op_type == OP_STUB) {
6015             OP * const newop
6016                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6017 #ifdef PERL_MAD
6018             op_getmad(o,newop,'O');
6019 #else
6020             op_free(o);
6021 #endif
6022             o = newop;
6023         }
6024         return ck_fun(o);
6025     }
6026     return o;
6027 }
6028
6029 OP *
6030 Perl_ck_eval(pTHX_ OP *o)
6031 {
6032     dVAR;
6033     PL_hints |= HINT_BLOCK_SCOPE;
6034     if (o->op_flags & OPf_KIDS) {
6035         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6036
6037         if (!kid) {
6038             o->op_flags &= ~OPf_KIDS;
6039             op_null(o);
6040         }
6041         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6042             LOGOP *enter;
6043 #ifdef PERL_MAD
6044             OP* const oldo = o;
6045 #endif
6046
6047             cUNOPo->op_first = 0;
6048 #ifndef PERL_MAD
6049             op_free(o);
6050 #endif
6051
6052             NewOp(1101, enter, 1, LOGOP);
6053             enter->op_type = OP_ENTERTRY;
6054             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6055             enter->op_private = 0;
6056
6057             /* establish postfix order */
6058             enter->op_next = (OP*)enter;
6059
6060             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6061             o->op_type = OP_LEAVETRY;
6062             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6063             enter->op_other = o;
6064             op_getmad(oldo,o,'O');
6065             return o;
6066         }
6067         else {
6068             scalar((OP*)kid);
6069             PL_cv_has_eval = 1;
6070         }
6071     }
6072     else {
6073 #ifdef PERL_MAD
6074         OP* const oldo = o;
6075 #else
6076         op_free(o);
6077 #endif
6078         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6079         op_getmad(oldo,o,'O');
6080     }
6081     o->op_targ = (PADOFFSET)PL_hints;
6082     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6083         /* Store a copy of %^H that pp_entereval can pick up */
6084         OP *hhop = newSVOP(OP_CONST, 0,
6085                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6086         cUNOPo->op_first->op_sibling = hhop;
6087         o->op_private |= OPpEVAL_HAS_HH;
6088     }
6089     return o;
6090 }
6091
6092 OP *
6093 Perl_ck_exit(pTHX_ OP *o)
6094 {
6095 #ifdef VMS
6096     HV * const table = GvHV(PL_hintgv);
6097     if (table) {
6098        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6099        if (svp && *svp && SvTRUE(*svp))
6100            o->op_private |= OPpEXIT_VMSISH;
6101     }
6102     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6103 #endif
6104     return ck_fun(o);
6105 }
6106
6107 OP *
6108 Perl_ck_exec(pTHX_ OP *o)
6109 {
6110     if (o->op_flags & OPf_STACKED) {
6111         OP *kid;
6112         o = ck_fun(o);
6113         kid = cUNOPo->op_first->op_sibling;
6114         if (kid->op_type == OP_RV2GV)
6115             op_null(kid);
6116     }
6117     else
6118         o = listkids(o);
6119     return o;
6120 }
6121
6122 OP *
6123 Perl_ck_exists(pTHX_ OP *o)
6124 {
6125     dVAR;
6126     o = ck_fun(o);
6127     if (o->op_flags & OPf_KIDS) {
6128         OP * const kid = cUNOPo->op_first;
6129         if (kid->op_type == OP_ENTERSUB) {
6130             (void) ref(kid, o->op_type);
6131             if (kid->op_type != OP_RV2CV && !PL_error_count)
6132                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6133                             OP_DESC(o));
6134             o->op_private |= OPpEXISTS_SUB;
6135         }
6136         else if (kid->op_type == OP_AELEM)
6137             o->op_flags |= OPf_SPECIAL;
6138         else if (kid->op_type != OP_HELEM)
6139             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6140                         OP_DESC(o));
6141         op_null(kid);
6142     }
6143     return o;
6144 }
6145
6146 OP *
6147 Perl_ck_rvconst(pTHX_ register OP *o)
6148 {
6149     dVAR;
6150     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6151
6152     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6153     if (o->op_type == OP_RV2CV)
6154         o->op_private &= ~1;
6155
6156     if (kid->op_type == OP_CONST) {
6157         int iscv;
6158         GV *gv;
6159         SV * const kidsv = kid->op_sv;
6160
6161         /* Is it a constant from cv_const_sv()? */
6162         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6163             SV * const rsv = SvRV(kidsv);
6164             const svtype type = SvTYPE(rsv);
6165             const char *badtype = NULL;
6166
6167             switch (o->op_type) {
6168             case OP_RV2SV:
6169                 if (type > SVt_PVMG)
6170                     badtype = "a SCALAR";
6171                 break;
6172             case OP_RV2AV:
6173                 if (type != SVt_PVAV)
6174                     badtype = "an ARRAY";
6175                 break;
6176             case OP_RV2HV:
6177                 if (type != SVt_PVHV)
6178                     badtype = "a HASH";
6179                 break;
6180             case OP_RV2CV:
6181                 if (type != SVt_PVCV)
6182                     badtype = "a CODE";
6183                 break;
6184             }
6185             if (badtype)
6186                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6187             return o;
6188         }
6189         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6190                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6191             /* If this is an access to a stash, disable "strict refs", because
6192              * stashes aren't auto-vivified at compile-time (unless we store
6193              * symbols in them), and we don't want to produce a run-time
6194              * stricture error when auto-vivifying the stash. */
6195             const char *s = SvPV_nolen(kidsv);
6196             const STRLEN l = SvCUR(kidsv);
6197             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6198                 o->op_private &= ~HINT_STRICT_REFS;
6199         }
6200         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6201             const char *badthing;
6202             switch (o->op_type) {
6203             case OP_RV2SV:
6204                 badthing = "a SCALAR";
6205                 break;
6206             case OP_RV2AV:
6207                 badthing = "an ARRAY";
6208                 break;
6209             case OP_RV2HV:
6210                 badthing = "a HASH";
6211                 break;
6212             default:
6213                 badthing = NULL;
6214                 break;
6215             }
6216             if (badthing)
6217                 Perl_croak(aTHX_
6218                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6219                            SVfARG(kidsv), badthing);
6220         }
6221         /*
6222          * This is a little tricky.  We only want to add the symbol if we
6223          * didn't add it in the lexer.  Otherwise we get duplicate strict
6224          * warnings.  But if we didn't add it in the lexer, we must at
6225          * least pretend like we wanted to add it even if it existed before,
6226          * or we get possible typo warnings.  OPpCONST_ENTERED says
6227          * whether the lexer already added THIS instance of this symbol.
6228          */
6229         iscv = (o->op_type == OP_RV2CV) * 2;
6230         do {
6231             gv = gv_fetchsv(kidsv,
6232                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6233                 iscv
6234                     ? SVt_PVCV
6235                     : o->op_type == OP_RV2SV
6236                         ? SVt_PV
6237                         : o->op_type == OP_RV2AV
6238                             ? SVt_PVAV
6239                             : o->op_type == OP_RV2HV
6240                                 ? SVt_PVHV
6241                                 : SVt_PVGV);
6242         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6243         if (gv) {
6244             kid->op_type = OP_GV;
6245             SvREFCNT_dec(kid->op_sv);
6246 #ifdef USE_ITHREADS
6247             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6248             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6249             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6250             GvIN_PAD_on(gv);
6251             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6252 #else
6253             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6254 #endif
6255             kid->op_private = 0;
6256             kid->op_ppaddr = PL_ppaddr[OP_GV];
6257         }
6258     }
6259     return o;
6260 }
6261
6262 OP *
6263 Perl_ck_ftst(pTHX_ OP *o)
6264 {
6265     dVAR;
6266     const I32 type = o->op_type;
6267
6268     if (o->op_flags & OPf_REF) {
6269         NOOP;
6270     }
6271     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6272         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6273         const OPCODE kidtype = kid->op_type;
6274
6275         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6276             OP * const newop = newGVOP(type, OPf_REF,
6277                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6278 #ifdef PERL_MAD
6279             op_getmad(o,newop,'O');
6280 #else
6281             op_free(o);
6282 #endif
6283             return newop;
6284         }
6285         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6286             o->op_private |= OPpFT_ACCESS;
6287         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6288                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6289             o->op_private |= OPpFT_STACKED;
6290     }
6291     else {
6292 #ifdef PERL_MAD
6293         OP* const oldo = o;
6294 #else
6295         op_free(o);
6296 #endif
6297         if (type == OP_FTTTY)
6298             o = newGVOP(type, OPf_REF, PL_stdingv);
6299         else
6300             o = newUNOP(type, 0, newDEFSVOP());
6301         op_getmad(oldo,o,'O');
6302     }
6303     return o;
6304 }
6305
6306 OP *
6307 Perl_ck_fun(pTHX_ OP *o)
6308 {
6309     dVAR;
6310     const int type = o->op_type;
6311     register I32 oa = PL_opargs[type] >> OASHIFT;
6312
6313     if (o->op_flags & OPf_STACKED) {
6314         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6315             oa &= ~OA_OPTIONAL;
6316         else
6317             return no_fh_allowed(o);
6318     }
6319
6320     if (o->op_flags & OPf_KIDS) {
6321         OP **tokid = &cLISTOPo->op_first;
6322         register OP *kid = cLISTOPo->op_first;
6323         OP *sibl;
6324         I32 numargs = 0;
6325
6326         if (kid->op_type == OP_PUSHMARK ||
6327             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6328         {
6329             tokid = &kid->op_sibling;
6330             kid = kid->op_sibling;
6331         }
6332         if (!kid && PL_opargs[type] & OA_DEFGV)
6333             *tokid = kid = newDEFSVOP();
6334
6335         while (oa && kid) {
6336             numargs++;
6337             sibl = kid->op_sibling;
6338 #ifdef PERL_MAD
6339             if (!sibl && kid->op_type == OP_STUB) {
6340                 numargs--;
6341                 break;
6342             }
6343 #endif
6344             switch (oa & 7) {
6345             case OA_SCALAR:
6346                 /* list seen where single (scalar) arg expected? */
6347                 if (numargs == 1 && !(oa >> 4)
6348                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6349                 {
6350                     return too_many_arguments(o,PL_op_desc[type]);
6351                 }
6352                 scalar(kid);
6353                 break;
6354             case OA_LIST:
6355                 if (oa < 16) {
6356                     kid = 0;
6357                     continue;
6358                 }
6359                 else
6360                     list(kid);
6361                 break;
6362             case OA_AVREF:
6363                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6364                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6365                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6366                         "Useless use of %s with no values",
6367                         PL_op_desc[type]);
6368
6369                 if (kid->op_type == OP_CONST &&
6370                     (kid->op_private & OPpCONST_BARE))
6371                 {
6372                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6373                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6374                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6375                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6376                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6377                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6378 #ifdef PERL_MAD
6379                     op_getmad(kid,newop,'K');
6380 #else
6381                     op_free(kid);
6382 #endif
6383                     kid = newop;
6384                     kid->op_sibling = sibl;
6385                     *tokid = kid;
6386                 }
6387                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6388                     bad_type(numargs, "array", PL_op_desc[type], kid);
6389                 mod(kid, type);
6390                 break;
6391             case OA_HVREF:
6392                 if (kid->op_type == OP_CONST &&
6393                     (kid->op_private & OPpCONST_BARE))
6394                 {
6395                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6396                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6397                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6398                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6399                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6400                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6401 #ifdef PERL_MAD
6402                     op_getmad(kid,newop,'K');
6403 #else
6404                     op_free(kid);
6405 #endif
6406                     kid = newop;
6407                     kid->op_sibling = sibl;
6408                     *tokid = kid;
6409                 }
6410                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6411                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6412                 mod(kid, type);
6413                 break;
6414             case OA_CVREF:
6415                 {
6416                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6417                     kid->op_sibling = 0;
6418                     linklist(kid);
6419                     newop->op_next = newop;
6420                     kid = newop;
6421                     kid->op_sibling = sibl;
6422                     *tokid = kid;
6423                 }
6424                 break;
6425             case OA_FILEREF:
6426                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6427                     if (kid->op_type == OP_CONST &&
6428                         (kid->op_private & OPpCONST_BARE))
6429                     {
6430                         OP * const newop = newGVOP(OP_GV, 0,
6431                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6432                         if (!(o->op_private & 1) && /* if not unop */
6433                             kid == cLISTOPo->op_last)
6434                             cLISTOPo->op_last = newop;
6435 #ifdef PERL_MAD
6436                         op_getmad(kid,newop,'K');
6437 #else
6438                         op_free(kid);
6439 #endif
6440                         kid = newop;
6441                     }
6442                     else if (kid->op_type == OP_READLINE) {
6443                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6444                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6445                     }
6446                     else {
6447                         I32 flags = OPf_SPECIAL;
6448                         I32 priv = 0;
6449                         PADOFFSET targ = 0;
6450
6451                         /* is this op a FH constructor? */
6452                         if (is_handle_constructor(o,numargs)) {
6453                             const char *name = NULL;
6454                             STRLEN len = 0;
6455
6456                             flags = 0;
6457                             /* Set a flag to tell rv2gv to vivify
6458                              * need to "prove" flag does not mean something
6459                              * else already - NI-S 1999/05/07
6460                              */
6461                             priv = OPpDEREF;
6462                             if (kid->op_type == OP_PADSV) {
6463                                 SV *const namesv
6464                                     = PAD_COMPNAME_SV(kid->op_targ);
6465                                 name = SvPV_const(namesv, len);
6466                             }
6467                             else if (kid->op_type == OP_RV2SV
6468                                      && kUNOP->op_first->op_type == OP_GV)
6469                             {
6470                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6471                                 name = GvNAME(gv);
6472                                 len = GvNAMELEN(gv);
6473                             }
6474                             else if (kid->op_type == OP_AELEM
6475                                      || kid->op_type == OP_HELEM)
6476                             {
6477                                  OP *firstop;
6478                                  OP *op = ((BINOP*)kid)->op_first;
6479                                  name = NULL;
6480                                  if (op) {
6481                                       SV *tmpstr = NULL;
6482                                       const char * const a =
6483                                            kid->op_type == OP_AELEM ?
6484                                            "[]" : "{}";
6485                                       if (((op->op_type == OP_RV2AV) ||
6486                                            (op->op_type == OP_RV2HV)) &&
6487                                           (firstop = ((UNOP*)op)->op_first) &&
6488                                           (firstop->op_type == OP_GV)) {
6489                                            /* packagevar $a[] or $h{} */
6490                                            GV * const gv = cGVOPx_gv(firstop);
6491                                            if (gv)
6492                                                 tmpstr =
6493                                                      Perl_newSVpvf(aTHX_
6494                                                                    "%s%c...%c",
6495                                                                    GvNAME(gv),
6496                                                                    a[0], a[1]);
6497                                       }
6498                                       else if (op->op_type == OP_PADAV
6499                                                || op->op_type == OP_PADHV) {
6500                                            /* lexicalvar $a[] or $h{} */
6501                                            const char * const padname =
6502                                                 PAD_COMPNAME_PV(op->op_targ);
6503                                            if (padname)
6504                                                 tmpstr =
6505                                                      Perl_newSVpvf(aTHX_
6506                                                                    "%s%c...%c",
6507                                                                    padname + 1,
6508                                                                    a[0], a[1]);
6509                                       }
6510                                       if (tmpstr) {
6511                                            name = SvPV_const(tmpstr, len);
6512                                            sv_2mortal(tmpstr);
6513                                       }
6514                                  }
6515                                  if (!name) {
6516                                       name = "__ANONIO__";
6517                                       len = 10;
6518                                  }
6519                                  mod(kid, type);
6520                             }
6521                             if (name) {
6522                                 SV *namesv;
6523                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6524                                 namesv = PAD_SVl(targ);
6525                                 SvUPGRADE(namesv, SVt_PV);
6526                                 if (*name != '$')
6527                                     sv_setpvn(namesv, "$", 1);
6528                                 sv_catpvn(namesv, name, len);
6529                             }
6530                         }
6531                         kid->op_sibling = 0;
6532                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6533                         kid->op_targ = targ;
6534                         kid->op_private |= priv;
6535                     }
6536                     kid->op_sibling = sibl;
6537                     *tokid = kid;
6538                 }
6539                 scalar(kid);
6540                 break;
6541             case OA_SCALARREF:
6542                 mod(scalar(kid), type);
6543                 break;
6544             }
6545             oa >>= 4;
6546             tokid = &kid->op_sibling;
6547             kid = kid->op_sibling;
6548         }
6549 #ifdef PERL_MAD
6550         if (kid && kid->op_type != OP_STUB)
6551             return too_many_arguments(o,OP_DESC(o));
6552         o->op_private |= numargs;
6553 #else
6554         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6555         o->op_private |= numargs;
6556         if (kid)
6557             return too_many_arguments(o,OP_DESC(o));
6558 #endif
6559         listkids(o);
6560     }
6561     else if (PL_opargs[type] & OA_DEFGV) {
6562 #ifdef PERL_MAD
6563         OP *newop = newUNOP(type, 0, newDEFSVOP());
6564         op_getmad(o,newop,'O');
6565         return newop;
6566 #else
6567         /* Ordering of these two is important to keep f_map.t passing.  */
6568         op_free(o);
6569         return newUNOP(type, 0, newDEFSVOP());
6570 #endif
6571     }
6572
6573     if (oa) {
6574         while (oa & OA_OPTIONAL)
6575             oa >>= 4;
6576         if (oa && oa != OA_LIST)
6577             return too_few_arguments(o,OP_DESC(o));
6578     }
6579     return o;
6580 }
6581
6582 OP *
6583 Perl_ck_glob(pTHX_ OP *o)
6584 {
6585     dVAR;
6586     GV *gv;
6587
6588     o = ck_fun(o);
6589     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6590         append_elem(OP_GLOB, o, newDEFSVOP());
6591
6592     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6593           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6594     {
6595         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6596     }
6597
6598 #if !defined(PERL_EXTERNAL_GLOB)
6599     /* XXX this can be tightened up and made more failsafe. */
6600     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6601         GV *glob_gv;
6602         ENTER;
6603         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6604                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6605         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6606         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6607         GvCV(gv) = GvCV(glob_gv);
6608         SvREFCNT_inc_void((SV*)GvCV(gv));
6609         GvIMPORTED_CV_on(gv);
6610         LEAVE;
6611     }
6612 #endif /* PERL_EXTERNAL_GLOB */
6613
6614     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6615         append_elem(OP_GLOB, o,
6616                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6617         o->op_type = OP_LIST;
6618         o->op_ppaddr = PL_ppaddr[OP_LIST];
6619         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6620         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6621         cLISTOPo->op_first->op_targ = 0;
6622         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6623                     append_elem(OP_LIST, o,
6624                                 scalar(newUNOP(OP_RV2CV, 0,
6625                                                newGVOP(OP_GV, 0, gv)))));
6626         o = newUNOP(OP_NULL, 0, ck_subr(o));
6627         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6628         return o;
6629     }
6630     gv = newGVgen("main");
6631     gv_IOadd(gv);
6632     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6633     scalarkids(o);
6634     return o;
6635 }
6636
6637 OP *
6638 Perl_ck_grep(pTHX_ OP *o)
6639 {
6640     dVAR;
6641     LOGOP *gwop = NULL;
6642     OP *kid;
6643     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6644     PADOFFSET offset;
6645
6646     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6647     /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6648
6649     if (o->op_flags & OPf_STACKED) {
6650         OP* k;
6651         o = ck_sort(o);
6652         kid = cLISTOPo->op_first->op_sibling;
6653         if (!cUNOPx(kid)->op_next)
6654             Perl_croak(aTHX_ "panic: ck_grep");
6655         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6656             kid = k;
6657         }
6658         NewOp(1101, gwop, 1, LOGOP);
6659         kid->op_next = (OP*)gwop;
6660         o->op_flags &= ~OPf_STACKED;
6661     }
6662     kid = cLISTOPo->op_first->op_sibling;
6663     if (type == OP_MAPWHILE)
6664         list(kid);
6665     else
6666         scalar(kid);
6667     o = ck_fun(o);
6668     if (PL_error_count)
6669         return o;
6670     kid = cLISTOPo->op_first->op_sibling;
6671     if (kid->op_type != OP_NULL)
6672         Perl_croak(aTHX_ "panic: ck_grep");
6673     kid = kUNOP->op_first;
6674
6675     if (!gwop)
6676         NewOp(1101, gwop, 1, LOGOP);
6677     gwop->op_type = type;
6678     gwop->op_ppaddr = PL_ppaddr[type];
6679     gwop->op_first = listkids(o);
6680     gwop->op_flags |= OPf_KIDS;
6681     gwop->op_other = LINKLIST(kid);
6682     kid->op_next = (OP*)gwop;
6683     offset = pad_findmy("$_");
6684     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6685         o->op_private = gwop->op_private = 0;
6686         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6687     }
6688     else {
6689         o->op_private = gwop->op_private = OPpGREP_LEX;
6690         gwop->op_targ = o->op_targ = offset;
6691     }
6692
6693     kid = cLISTOPo->op_first->op_sibling;
6694     if (!kid || !kid->op_sibling)
6695         return too_few_arguments(o,OP_DESC(o));
6696     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6697         mod(kid, OP_GREPSTART);
6698
6699     return (OP*)gwop;
6700 }
6701
6702 OP *
6703 Perl_ck_index(pTHX_ OP *o)
6704 {
6705     if (o->op_flags & OPf_KIDS) {
6706         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6707         if (kid)
6708             kid = kid->op_sibling;                      /* get past "big" */
6709         if (kid && kid->op_type == OP_CONST)
6710             fbm_compile(((SVOP*)kid)->op_sv, 0);
6711     }
6712     return ck_fun(o);
6713 }
6714
6715 OP *
6716 Perl_ck_lengthconst(pTHX_ OP *o)
6717 {
6718     /* XXX length optimization goes here */
6719     return ck_fun(o);
6720 }
6721
6722 OP *
6723 Perl_ck_lfun(pTHX_ OP *o)
6724 {
6725     const OPCODE type = o->op_type;
6726     return modkids(ck_fun(o), type);
6727 }
6728
6729 OP *
6730 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6731 {
6732     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6733         switch (cUNOPo->op_first->op_type) {
6734         case OP_RV2AV:
6735             /* This is needed for
6736                if (defined %stash::)
6737                to work.   Do not break Tk.
6738                */
6739             break;                      /* Globals via GV can be undef */
6740         case OP_PADAV:
6741         case OP_AASSIGN:                /* Is this a good idea? */
6742             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6743                         "defined(@array) is deprecated");
6744             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6745                         "\t(Maybe you should just omit the defined()?)\n");
6746         break;
6747         case OP_RV2HV:
6748             /* This is needed for
6749                if (defined %stash::)
6750                to work.   Do not break Tk.
6751                */
6752             break;                      /* Globals via GV can be undef */
6753         case OP_PADHV:
6754             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6755                         "defined(%%hash) is deprecated");
6756             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6757                         "\t(Maybe you should just omit the defined()?)\n");
6758             break;
6759         default:
6760             /* no warning */
6761             break;
6762         }
6763     }
6764     return ck_rfun(o);
6765 }
6766
6767 OP *
6768 Perl_ck_rfun(pTHX_ OP *o)
6769 {
6770     const OPCODE type = o->op_type;
6771     return refkids(ck_fun(o), type);
6772 }
6773
6774 OP *
6775 Perl_ck_listiob(pTHX_ OP *o)
6776 {
6777     register OP *kid;
6778
6779     kid = cLISTOPo->op_first;
6780     if (!kid) {
6781         o = force_list(o);
6782         kid = cLISTOPo->op_first;
6783     }
6784     if (kid->op_type == OP_PUSHMARK)
6785         kid = kid->op_sibling;
6786     if (kid && o->op_flags & OPf_STACKED)
6787         kid = kid->op_sibling;
6788     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6789         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6790             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6791             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6792             cLISTOPo->op_first->op_sibling = kid;
6793             cLISTOPo->op_last = kid;
6794             kid = kid->op_sibling;
6795         }
6796     }
6797
6798     if (!kid)
6799         append_elem(o->op_type, o, newDEFSVOP());
6800
6801     return listkids(o);
6802 }
6803
6804 OP *
6805 Perl_ck_smartmatch(pTHX_ OP *o)
6806 {
6807     dVAR;
6808     if (0 == (o->op_flags & OPf_SPECIAL)) {
6809         OP *first  = cBINOPo->op_first;
6810         OP *second = first->op_sibling;
6811
6812         /* Implicitly take a reference to an array or hash */
6813         first->op_sibling = NULL;
6814         first = cBINOPo->op_first = ref_array_or_hash(first);
6815         second = first->op_sibling = ref_array_or_hash(second);
6816
6817         /* Implicitly take a reference to a regular expression */
6818         if (first->op_type == OP_MATCH) {
6819             first->op_type = OP_QR;
6820             first->op_ppaddr = PL_ppaddr[OP_QR];
6821         }
6822         if (second->op_type == OP_MATCH) {
6823             second->op_type = OP_QR;
6824             second->op_ppaddr = PL_ppaddr[OP_QR];
6825         }
6826     }
6827
6828     return o;
6829 }
6830
6831
6832 OP *
6833 Perl_ck_sassign(pTHX_ OP *o)
6834 {
6835     OP * const kid = cLISTOPo->op_first;
6836     /* has a disposable target? */
6837     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6838         && !(kid->op_flags & OPf_STACKED)
6839         /* Cannot steal the second time! */
6840         && !(kid->op_private & OPpTARGET_MY))
6841     {
6842         OP * const kkid = kid->op_sibling;
6843
6844         /* Can just relocate the target. */
6845         if (kkid && kkid->op_type == OP_PADSV
6846             && !(kkid->op_private & OPpLVAL_INTRO))
6847         {
6848             kid->op_targ = kkid->op_targ;
6849             kkid->op_targ = 0;
6850             /* Now we do not need PADSV and SASSIGN. */
6851             kid->op_sibling = o->op_sibling;    /* NULL */
6852             cLISTOPo->op_first = NULL;
6853 #ifdef PERL_MAD
6854             op_getmad(o,kid,'O');
6855             op_getmad(kkid,kid,'M');
6856 #else
6857             op_free(o);
6858             op_free(kkid);
6859 #endif
6860             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6861             return kid;
6862         }
6863     }
6864     if (kid->op_sibling) {
6865         OP *kkid = kid->op_sibling;
6866         if (kkid->op_type == OP_PADSV
6867                 && (kkid->op_private & OPpLVAL_INTRO)
6868                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6869             o->op_private |= OPpASSIGN_STATE;
6870             /* hijacking PADSTALE for uninitialized state variables */
6871             SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6872         }
6873     }
6874     return o;
6875 }
6876
6877 OP *
6878 Perl_ck_match(pTHX_ OP *o)
6879 {
6880     dVAR;
6881     if (o->op_type != OP_QR && PL_compcv) {
6882         const PADOFFSET offset = pad_findmy("$_");
6883         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6884             o->op_targ = offset;
6885             o->op_private |= OPpTARGET_MY;
6886         }
6887     }
6888     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6889         o->op_private |= OPpRUNTIME;
6890     return o;
6891 }
6892
6893 OP *
6894 Perl_ck_method(pTHX_ OP *o)
6895 {
6896     OP * const kid = cUNOPo->op_first;
6897     if (kid->op_type == OP_CONST) {
6898         SV* sv = kSVOP->op_sv;
6899         const char * const method = SvPVX_const(sv);
6900         if (!(strchr(method, ':') || strchr(method, '\''))) {
6901             OP *cmop;
6902             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6903                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6904             }
6905             else {
6906                 kSVOP->op_sv = NULL;
6907             }
6908             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6909 #ifdef PERL_MAD
6910             op_getmad(o,cmop,'O');
6911 #else
6912             op_free(o);
6913 #endif
6914             return cmop;
6915         }
6916     }
6917     return o;
6918 }
6919
6920 OP *
6921 Perl_ck_null(pTHX_ OP *o)
6922 {
6923     PERL_UNUSED_CONTEXT;
6924     return o;
6925 }
6926
6927 OP *
6928 Perl_ck_open(pTHX_ OP *o)
6929 {
6930     dVAR;
6931     HV * const table = GvHV(PL_hintgv);
6932     if (table) {
6933         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6934         if (svp && *svp) {
6935             const I32 mode = mode_from_discipline(*svp);
6936             if (mode & O_BINARY)
6937                 o->op_private |= OPpOPEN_IN_RAW;
6938             else if (mode & O_TEXT)
6939                 o->op_private |= OPpOPEN_IN_CRLF;
6940         }
6941
6942         svp = hv_fetchs(table, "open_OUT", FALSE);
6943         if (svp && *svp) {
6944             const I32 mode = mode_from_discipline(*svp);
6945             if (mode & O_BINARY)
6946                 o->op_private |= OPpOPEN_OUT_RAW;
6947             else if (mode & O_TEXT)
6948                 o->op_private |= OPpOPEN_OUT_CRLF;
6949         }
6950     }
6951     if (o->op_type == OP_BACKTICK)
6952         return o;
6953     {
6954          /* In case of three-arg dup open remove strictness
6955           * from the last arg if it is a bareword. */
6956          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6957          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6958          OP *oa;
6959          const char *mode;
6960
6961          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6962              (last->op_private & OPpCONST_BARE) &&
6963              (last->op_private & OPpCONST_STRICT) &&
6964              (oa = first->op_sibling) &&                /* The fh. */
6965              (oa = oa->op_sibling) &&                   /* The mode. */
6966              (oa->op_type == OP_CONST) &&
6967              SvPOK(((SVOP*)oa)->op_sv) &&
6968              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6969              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6970              (last == oa->op_sibling))                  /* The bareword. */
6971               last->op_private &= ~OPpCONST_STRICT;
6972     }
6973     return ck_fun(o);
6974 }
6975
6976 OP *
6977 Perl_ck_repeat(pTHX_ OP *o)
6978 {
6979     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6980         o->op_private |= OPpREPEAT_DOLIST;
6981         cBINOPo->op_first = force_list(cBINOPo->op_first);
6982     }
6983     else
6984         scalar(o);
6985     return o;
6986 }
6987
6988 OP *
6989 Perl_ck_require(pTHX_ OP *o)
6990 {
6991     dVAR;
6992     GV* gv = NULL;
6993
6994     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6995         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6996
6997         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6998             SV * const sv = kid->op_sv;
6999             U32 was_readonly = SvREADONLY(sv);
7000             char *s;
7001
7002             if (was_readonly) {
7003                 if (SvFAKE(sv)) {
7004                     sv_force_normal_flags(sv, 0);
7005                     assert(!SvREADONLY(sv));
7006                     was_readonly = 0;
7007                 } else {
7008                     SvREADONLY_off(sv);
7009                 }
7010             }
7011
7012             for (s = SvPVX(sv); *s; s++) {
7013                 if (*s == ':' && s[1] == ':') {
7014                     const STRLEN len = strlen(s+2)+1;
7015                     *s = '/';
7016                     Move(s+2, s+1, len, char);
7017                     SvCUR_set(sv, SvCUR(sv) - 1);
7018                 }
7019             }
7020             sv_catpvs(sv, ".pm");
7021             SvFLAGS(sv) |= was_readonly;
7022         }
7023     }
7024
7025     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7026         /* handle override, if any */
7027         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7028         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7029             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7030             gv = gvp ? *gvp : NULL;
7031         }
7032     }
7033
7034     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7035         OP * const kid = cUNOPo->op_first;
7036         OP * newop;
7037
7038         cUNOPo->op_first = 0;
7039 #ifndef PERL_MAD
7040         op_free(o);
7041 #endif
7042         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7043                                 append_elem(OP_LIST, kid,
7044                                             scalar(newUNOP(OP_RV2CV, 0,
7045                                                            newGVOP(OP_GV, 0,
7046                                                                    gv))))));
7047         op_getmad(o,newop,'O');
7048         return newop;
7049     }
7050
7051     return ck_fun(o);
7052 }
7053
7054 OP *
7055 Perl_ck_return(pTHX_ OP *o)
7056 {
7057     dVAR;
7058     if (CvLVALUE(PL_compcv)) {
7059         OP *kid;
7060         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7061             mod(kid, OP_LEAVESUBLV);
7062     }
7063     return o;
7064 }
7065
7066 OP *
7067 Perl_ck_select(pTHX_ OP *o)
7068 {
7069     dVAR;
7070     OP* kid;
7071     if (o->op_flags & OPf_KIDS) {
7072         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7073         if (kid && kid->op_sibling) {
7074             o->op_type = OP_SSELECT;
7075             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7076             o = ck_fun(o);
7077             return fold_constants(o);
7078         }
7079     }
7080     o = ck_fun(o);
7081     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7082     if (kid && kid->op_type == OP_RV2GV)
7083         kid->op_private &= ~HINT_STRICT_REFS;
7084     return o;
7085 }
7086
7087 OP *
7088 Perl_ck_shift(pTHX_ OP *o)
7089 {
7090     dVAR;
7091     const I32 type = o->op_type;
7092
7093     if (!(o->op_flags & OPf_KIDS)) {
7094         OP *argop;
7095         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7096 #ifdef PERL_MAD
7097         OP * const oldo = o;
7098 #else
7099         op_free(o);
7100 #endif
7101         argop = newUNOP(OP_RV2AV, 0,
7102             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7103 #ifdef PERL_MAD
7104         o = newUNOP(type, 0, scalar(argop));
7105         op_getmad(oldo,o,'O');
7106         return o;
7107 #else
7108         return newUNOP(type, 0, scalar(argop));
7109 #endif
7110     }
7111     return scalar(modkids(ck_fun(o), type));
7112 }
7113
7114 OP *
7115 Perl_ck_sort(pTHX_ OP *o)
7116 {
7117     dVAR;
7118     OP *firstkid;
7119
7120     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7121         HV * const hinthv = GvHV(PL_hintgv);
7122         if (hinthv) {
7123             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7124             if (svp) {
7125                 const I32 sorthints = (I32)SvIV(*svp);
7126                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7127                     o->op_private |= OPpSORT_QSORT;
7128                 if ((sorthints & HINT_SORT_STABLE) != 0)
7129                     o->op_private |= OPpSORT_STABLE;
7130             }
7131         }
7132     }
7133
7134     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7135         simplify_sort(o);
7136     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7137     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7138         OP *k = NULL;
7139         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7140
7141         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7142             linklist(kid);
7143             if (kid->op_type == OP_SCOPE) {
7144                 k = kid->op_next;
7145                 kid->op_next = 0;
7146             }
7147             else if (kid->op_type == OP_LEAVE) {
7148                 if (o->op_type == OP_SORT) {
7149                     op_null(kid);                       /* wipe out leave */
7150                     kid->op_next = kid;
7151
7152                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7153                         if (k->op_next == kid)
7154                             k->op_next = 0;
7155                         /* don't descend into loops */
7156                         else if (k->op_type == OP_ENTERLOOP
7157                                  || k->op_type == OP_ENTERITER)
7158                         {
7159                             k = cLOOPx(k)->op_lastop;
7160                         }
7161                     }
7162                 }
7163                 else
7164                     kid->op_next = 0;           /* just disconnect the leave */
7165                 k = kLISTOP->op_first;
7166             }
7167             CALL_PEEP(k);
7168
7169             kid = firstkid;
7170             if (o->op_type == OP_SORT) {
7171                 /* provide scalar context for comparison function/block */
7172                 kid = scalar(kid);
7173                 kid->op_next = kid;
7174             }
7175             else
7176                 kid->op_next = k;
7177             o->op_flags |= OPf_SPECIAL;
7178         }
7179         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7180             op_null(firstkid);
7181
7182         firstkid = firstkid->op_sibling;
7183     }
7184
7185     /* provide list context for arguments */
7186     if (o->op_type == OP_SORT)
7187         list(firstkid);
7188
7189     return o;
7190 }
7191
7192 STATIC void
7193 S_simplify_sort(pTHX_ OP *o)
7194 {
7195     dVAR;
7196     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7197     OP *k;
7198     int descending;
7199     GV *gv;
7200     const char *gvname;
7201     if (!(o->op_flags & OPf_STACKED))
7202         return;
7203     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7204     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7205     kid = kUNOP->op_first;                              /* get past null */
7206     if (kid->op_type != OP_SCOPE)
7207         return;
7208     kid = kLISTOP->op_last;                             /* get past scope */
7209     switch(kid->op_type) {
7210         case OP_NCMP:
7211         case OP_I_NCMP:
7212         case OP_SCMP:
7213             break;
7214         default:
7215             return;
7216     }
7217     k = kid;                                            /* remember this node*/
7218     if (kBINOP->op_first->op_type != OP_RV2SV)
7219         return;
7220     kid = kBINOP->op_first;                             /* get past cmp */
7221     if (kUNOP->op_first->op_type != OP_GV)
7222         return;
7223     kid = kUNOP->op_first;                              /* get past rv2sv */
7224     gv = kGVOP_gv;
7225     if (GvSTASH(gv) != PL_curstash)
7226         return;
7227     gvname = GvNAME(gv);
7228     if (*gvname == 'a' && gvname[1] == '\0')
7229         descending = 0;
7230     else if (*gvname == 'b' && gvname[1] == '\0')
7231         descending = 1;
7232     else
7233         return;
7234
7235     kid = k;                                            /* back to cmp */
7236     if (kBINOP->op_last->op_type != OP_RV2SV)
7237         return;
7238     kid = kBINOP->op_last;                              /* down to 2nd arg */
7239     if (kUNOP->op_first->op_type != OP_GV)
7240         return;
7241     kid = kUNOP->op_first;                              /* get past rv2sv */
7242     gv = kGVOP_gv;
7243     if (GvSTASH(gv) != PL_curstash)
7244         return;
7245     gvname = GvNAME(gv);
7246     if ( descending
7247          ? !(*gvname == 'a' && gvname[1] == '\0')
7248          : !(*gvname == 'b' && gvname[1] == '\0'))
7249         return;
7250     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7251     if (descending)
7252         o->op_private |= OPpSORT_DESCEND;
7253     if (k->op_type == OP_NCMP)
7254         o->op_private |= OPpSORT_NUMERIC;
7255     if (k->op_type == OP_I_NCMP)
7256         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7257     kid = cLISTOPo->op_first->op_sibling;
7258     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7259 #ifdef PERL_MAD
7260     op_getmad(kid,o,'S');                             /* then delete it */
7261 #else
7262     op_free(kid);                                     /* then delete it */
7263 #endif
7264 }
7265
7266 OP *
7267 Perl_ck_split(pTHX_ OP *o)
7268 {
7269     dVAR;
7270     register OP *kid;
7271
7272     if (o->op_flags & OPf_STACKED)
7273         return no_fh_allowed(o);
7274
7275     kid = cLISTOPo->op_first;
7276     if (kid->op_type != OP_NULL)
7277         Perl_croak(aTHX_ "panic: ck_split");
7278     kid = kid->op_sibling;
7279     op_free(cLISTOPo->op_first);
7280     cLISTOPo->op_first = kid;
7281     if (!kid) {
7282         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7283         cLISTOPo->op_last = kid; /* There was only one element previously */
7284     }
7285
7286     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7287         OP * const sibl = kid->op_sibling;
7288         kid->op_sibling = 0;
7289         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7290         if (cLISTOPo->op_first == cLISTOPo->op_last)
7291             cLISTOPo->op_last = kid;
7292         cLISTOPo->op_first = kid;
7293         kid->op_sibling = sibl;
7294     }
7295
7296     kid->op_type = OP_PUSHRE;
7297     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7298     scalar(kid);
7299     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7300       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7301                   "Use of /g modifier is meaningless in split");
7302     }
7303
7304     if (!kid->op_sibling)
7305         append_elem(OP_SPLIT, o, newDEFSVOP());
7306
7307     kid = kid->op_sibling;
7308     scalar(kid);
7309
7310     if (!kid->op_sibling)
7311         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7312     assert(kid->op_sibling);
7313
7314     kid = kid->op_sibling;
7315     scalar(kid);
7316
7317     if (kid->op_sibling)
7318         return too_many_arguments(o,OP_DESC(o));
7319
7320     return o;
7321 }
7322
7323 OP *
7324 Perl_ck_join(pTHX_ OP *o)
7325 {
7326     const OP * const kid = cLISTOPo->op_first->op_sibling;
7327     if (kid && kid->op_type == OP_MATCH) {
7328         if (ckWARN(WARN_SYNTAX)) {
7329             const REGEXP *re = PM_GETRE(kPMOP);
7330             const char *pmstr = re ? re->precomp : "STRING";
7331             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7332                         "/%s/ should probably be written as \"%s\"",
7333                         pmstr, pmstr);
7334         }
7335     }
7336     return ck_fun(o);
7337 }
7338
7339 OP *
7340 Perl_ck_subr(pTHX_ OP *o)
7341 {
7342     dVAR;
7343     OP *prev = ((cUNOPo->op_first->op_sibling)
7344              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7345     OP *o2 = prev->op_sibling;
7346     OP *cvop;
7347     const char *proto = NULL;
7348     const char *proto_end = NULL;
7349     CV *cv = NULL;
7350     GV *namegv = NULL;
7351     int optional = 0;
7352     I32 arg = 0;
7353     I32 contextclass = 0;
7354     const char *e = NULL;
7355     bool delete_op = 0;
7356
7357     o->op_private |= OPpENTERSUB_HASTARG;
7358     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7359     if (cvop->op_type == OP_RV2CV) {
7360         SVOP* tmpop;
7361         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7362         op_null(cvop);          /* disable rv2cv */
7363         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7364         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7365             GV *gv = cGVOPx_gv(tmpop);
7366             cv = GvCVu(gv);
7367             if (!cv)
7368                 tmpop->op_private |= OPpEARLY_CV;
7369             else {
7370                 if (SvPOK(cv)) {
7371                     STRLEN len;
7372                     namegv = CvANON(cv) ? gv : CvGV(cv);
7373                     proto = SvPV((SV*)cv, len);
7374                     proto_end = proto + len;
7375                 }
7376                 if (CvASSERTION(cv)) {
7377                     U32 asserthints = 0;
7378                     HV *const hinthv = GvHV(PL_hintgv);
7379                     if (hinthv) {
7380                         SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7381                         if (svp && *svp)
7382                             asserthints = SvUV(*svp);
7383                     }
7384                     if (asserthints & HINT_ASSERTING) {
7385                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7386                             o->op_private |= OPpENTERSUB_DB;
7387                     }
7388                     else {
7389                         delete_op = 1;
7390                         if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7391                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7392                                         "Impossible to activate assertion call");
7393                         }
7394                     }
7395                 }
7396             }
7397         }
7398     }
7399     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7400         if (o2->op_type == OP_CONST)
7401             o2->op_private &= ~OPpCONST_STRICT;
7402         else if (o2->op_type == OP_LIST) {
7403             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7404             if (sib && sib->op_type == OP_CONST)
7405                 sib->op_private &= ~OPpCONST_STRICT;
7406         }
7407     }
7408     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7409     if (PERLDB_SUB && PL_curstash != PL_debstash)
7410         o->op_private |= OPpENTERSUB_DB;
7411     while (o2 != cvop) {
7412         OP* o3;
7413         if (PL_madskills && o2->op_type == OP_NULL)
7414             o3 = ((UNOP*)o2)->op_first;
7415         else
7416             o3 = o2;
7417         if (proto) {
7418             if (proto >= proto_end)
7419                 return too_many_arguments(o, gv_ename(namegv));
7420
7421             switch (*proto) {
7422             case ';':
7423                 optional = 1;
7424                 proto++;
7425                 continue;
7426             case '_':
7427                 /* _ must be at the end */
7428                 if (proto[1] && proto[1] != ';')
7429                     goto oops;
7430             case '$':
7431                 proto++;
7432                 arg++;
7433                 scalar(o2);
7434                 break;
7435             case '%':
7436             case '@':
7437                 list(o2);
7438                 arg++;
7439                 break;
7440             case '&':
7441                 proto++;
7442                 arg++;
7443                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7444                     bad_type(arg,
7445                         arg == 1 ? "block or sub {}" : "sub {}",
7446                         gv_ename(namegv), o3);
7447                 break;
7448             case '*':
7449                 /* '*' allows any scalar type, including bareword */
7450                 proto++;
7451                 arg++;
7452                 if (o3->op_type == OP_RV2GV)
7453                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7454                 else if (o3->op_type == OP_CONST)
7455                     o3->op_private &= ~OPpCONST_STRICT;
7456                 else if (o3->op_type == OP_ENTERSUB) {
7457                     /* accidental subroutine, revert to bareword */
7458                     OP *gvop = ((UNOP*)o3)->op_first;
7459                     if (gvop && gvop->op_type == OP_NULL) {
7460                         gvop = ((UNOP*)gvop)->op_first;
7461                         if (gvop) {
7462                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7463                                 ;
7464                             if (gvop &&
7465                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7466                                 (gvop = ((UNOP*)gvop)->op_first) &&
7467                                 gvop->op_type == OP_GV)
7468                             {
7469                                 GV * const gv = cGVOPx_gv(gvop);
7470                                 OP * const sibling = o2->op_sibling;
7471                                 SV * const n = newSVpvs("");
7472 #ifdef PERL_MAD
7473                                 OP * const oldo2 = o2;
7474 #else
7475                                 op_free(o2);
7476 #endif
7477                                 gv_fullname4(n, gv, "", FALSE);
7478                                 o2 = newSVOP(OP_CONST, 0, n);
7479                                 op_getmad(oldo2,o2,'O');
7480                                 prev->op_sibling = o2;
7481                                 o2->op_sibling = sibling;
7482                             }
7483                         }
7484                     }
7485                 }
7486                 scalar(o2);
7487                 break;
7488             case '[': case ']':
7489                  goto oops;
7490                  break;
7491             case '\\':
7492                 proto++;
7493                 arg++;
7494             again:
7495                 switch (*proto++) {
7496                 case '[':
7497                      if (contextclass++ == 0) {
7498                           e = strchr(proto, ']');
7499                           if (!e || e == proto)
7500                                goto oops;
7501                      }
7502                      else
7503                           goto oops;
7504                      goto again;
7505                      break;
7506                 case ']':
7507                      if (contextclass) {
7508                          const char *p = proto;
7509                          const char *const end = proto;
7510                          contextclass = 0;
7511                          while (*--p != '[');
7512                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7513                                                  (int)(end - p), p),
7514                                   gv_ename(namegv), o3);
7515                      } else
7516                           goto oops;
7517                      break;
7518                 case '*':
7519                      if (o3->op_type == OP_RV2GV)
7520                           goto wrapref;
7521                      if (!contextclass)
7522                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7523                      break;
7524                 case '&':
7525                      if (o3->op_type == OP_ENTERSUB)
7526                           goto wrapref;
7527                      if (!contextclass)
7528                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7529                                    o3);
7530                      break;
7531                 case '$':
7532                     if (o3->op_type == OP_RV2SV ||
7533                         o3->op_type == OP_PADSV ||
7534                         o3->op_type == OP_HELEM ||
7535                         o3->op_type == OP_AELEM)
7536                          goto wrapref;
7537                     if (!contextclass)
7538                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7539                      break;
7540                 case '@':
7541                     if (o3->op_type == OP_RV2AV ||
7542                         o3->op_type == OP_PADAV)
7543                          goto wrapref;
7544                     if (!contextclass)
7545                         bad_type(arg, "array", gv_ename(namegv), o3);
7546                     break;
7547                 case '%':
7548                     if (o3->op_type == OP_RV2HV ||
7549                         o3->op_type == OP_PADHV)
7550                          goto wrapref;
7551                     if (!contextclass)
7552                          bad_type(arg, "hash", gv_ename(namegv), o3);
7553                     break;
7554                 wrapref:
7555                     {
7556                         OP* const kid = o2;
7557                         OP* const sib = kid->op_sibling;
7558                         kid->op_sibling = 0;
7559                         o2 = newUNOP(OP_REFGEN, 0, kid);
7560                         o2->op_sibling = sib;
7561                         prev->op_sibling = o2;
7562                     }
7563                     if (contextclass && e) {
7564                          proto = e + 1;
7565                          contextclass = 0;
7566                     }
7567                     break;
7568                 default: goto oops;
7569                 }
7570                 if (contextclass)
7571                      goto again;
7572                 break;
7573             case ' ':
7574                 proto++;
7575                 continue;
7576             default:
7577               oops:
7578                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7579                            gv_ename(namegv), SVfARG(cv));
7580             }
7581         }
7582         else
7583             list(o2);
7584         mod(o2, OP_ENTERSUB);
7585         prev = o2;
7586         o2 = o2->op_sibling;
7587     } /* while */
7588     if (o2 == cvop && proto && *proto == '_') {
7589         /* generate an access to $_ */
7590         o2 = newDEFSVOP();
7591         o2->op_sibling = prev->op_sibling;
7592         prev->op_sibling = o2; /* instead of cvop */
7593     }
7594     if (proto && !optional && proto_end > proto &&
7595         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7596         return too_few_arguments(o, gv_ename(namegv));
7597     if(delete_op) {
7598 #ifdef PERL_MAD
7599         OP * const oldo = o;
7600 #else
7601         op_free(o);
7602 #endif
7603         o=newSVOP(OP_CONST, 0, newSViv(0));
7604         op_getmad(oldo,o,'O');
7605     }
7606     return o;
7607 }
7608
7609 OP *
7610 Perl_ck_svconst(pTHX_ OP *o)
7611 {
7612     PERL_UNUSED_CONTEXT;
7613     SvREADONLY_on(cSVOPo->op_sv);
7614     return o;
7615 }
7616
7617 OP *
7618 Perl_ck_chdir(pTHX_ OP *o)
7619 {
7620     if (o->op_flags & OPf_KIDS) {
7621         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7622
7623         if (kid && kid->op_type == OP_CONST &&
7624             (kid->op_private & OPpCONST_BARE))
7625         {
7626             o->op_flags |= OPf_SPECIAL;
7627             kid->op_private &= ~OPpCONST_STRICT;
7628         }
7629     }
7630     return ck_fun(o);
7631 }
7632
7633 OP *
7634 Perl_ck_trunc(pTHX_ OP *o)
7635 {
7636     if (o->op_flags & OPf_KIDS) {
7637         SVOP *kid = (SVOP*)cUNOPo->op_first;
7638
7639         if (kid->op_type == OP_NULL)
7640             kid = (SVOP*)kid->op_sibling;
7641         if (kid && kid->op_type == OP_CONST &&
7642             (kid->op_private & OPpCONST_BARE))
7643         {
7644             o->op_flags |= OPf_SPECIAL;
7645             kid->op_private &= ~OPpCONST_STRICT;
7646         }
7647     }
7648     return ck_fun(o);
7649 }
7650
7651 OP *
7652 Perl_ck_unpack(pTHX_ OP *o)
7653 {
7654     OP *kid = cLISTOPo->op_first;
7655     if (kid->op_sibling) {
7656         kid = kid->op_sibling;
7657         if (!kid->op_sibling)
7658             kid->op_sibling = newDEFSVOP();
7659     }
7660     return ck_fun(o);
7661 }
7662
7663 OP *
7664 Perl_ck_substr(pTHX_ OP *o)
7665 {
7666     o = ck_fun(o);
7667     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7668         OP *kid = cLISTOPo->op_first;
7669
7670         if (kid->op_type == OP_NULL)
7671             kid = kid->op_sibling;
7672         if (kid)
7673             kid->op_flags |= OPf_MOD;
7674
7675     }
7676     return o;
7677 }
7678
7679 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7680  * See the comments at the top of this file for more details about when
7681  * peep() is called */
7682
7683 void
7684 Perl_peep(pTHX_ register OP *o)
7685 {
7686     dVAR;
7687     register OP* oldop = NULL;
7688
7689     if (!o || o->op_opt)
7690         return;
7691     ENTER;
7692     SAVEOP();
7693     SAVEVPTR(PL_curcop);
7694     for (; o; o = o->op_next) {
7695         if (o->op_opt)
7696             break;
7697         PL_op = o;
7698         switch (o->op_type) {
7699         case OP_SETSTATE:
7700         case OP_NEXTSTATE:
7701         case OP_DBSTATE:
7702             PL_curcop = ((COP*)o);              /* for warnings */
7703             o->op_opt = 1;
7704             break;
7705
7706         case OP_CONST:
7707             if (cSVOPo->op_private & OPpCONST_STRICT)
7708                 no_bareword_allowed(o);
7709 #ifdef USE_ITHREADS
7710         case OP_METHOD_NAMED:
7711             /* Relocate sv to the pad for thread safety.
7712              * Despite being a "constant", the SV is written to,
7713              * for reference counts, sv_upgrade() etc. */
7714             if (cSVOP->op_sv) {
7715                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7716                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7717                     /* If op_sv is already a PADTMP then it is being used by
7718                      * some pad, so make a copy. */
7719                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7720                     SvREADONLY_on(PAD_SVl(ix));
7721                     SvREFCNT_dec(cSVOPo->op_sv);
7722                 }
7723                 else if (o->op_type == OP_CONST
7724                          && cSVOPo->op_sv == &PL_sv_undef) {
7725                     /* PL_sv_undef is hack - it's unsafe to store it in the
7726                        AV that is the pad, because av_fetch treats values of
7727                        PL_sv_undef as a "free" AV entry and will merrily
7728                        replace them with a new SV, causing pad_alloc to think
7729                        that this pad slot is free. (When, clearly, it is not)
7730                     */
7731                     SvOK_off(PAD_SVl(ix));
7732                     SvPADTMP_on(PAD_SVl(ix));
7733                     SvREADONLY_on(PAD_SVl(ix));
7734                 }
7735                 else {
7736                     SvREFCNT_dec(PAD_SVl(ix));
7737                     SvPADTMP_on(cSVOPo->op_sv);
7738                     PAD_SETSV(ix, cSVOPo->op_sv);
7739                     /* XXX I don't know how this isn't readonly already. */
7740                     SvREADONLY_on(PAD_SVl(ix));
7741                 }
7742                 cSVOPo->op_sv = NULL;
7743                 o->op_targ = ix;
7744             }
7745 #endif
7746             o->op_opt = 1;
7747             break;
7748
7749         case OP_CONCAT:
7750             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7751                 if (o->op_next->op_private & OPpTARGET_MY) {
7752                     if (o->op_flags & OPf_STACKED) /* chained concats */
7753                         goto ignore_optimization;
7754                     else {
7755                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7756                         o->op_targ = o->op_next->op_targ;
7757                         o->op_next->op_targ = 0;
7758                         o->op_private |= OPpTARGET_MY;
7759                     }
7760                 }
7761                 op_null(o->op_next);
7762             }
7763           ignore_optimization:
7764             o->op_opt = 1;
7765             break;
7766         case OP_STUB:
7767             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7768                 o->op_opt = 1;
7769                 break; /* Scalar stub must produce undef.  List stub is noop */
7770             }
7771             goto nothin;
7772         case OP_NULL:
7773             if (o->op_targ == OP_NEXTSTATE
7774                 || o->op_targ == OP_DBSTATE
7775                 || o->op_targ == OP_SETSTATE)
7776             {
7777                 PL_curcop = ((COP*)o);
7778             }
7779             /* XXX: We avoid setting op_seq here to prevent later calls
7780                to peep() from mistakenly concluding that optimisation
7781                has already occurred. This doesn't fix the real problem,
7782                though (See 20010220.007). AMS 20010719 */
7783             /* op_seq functionality is now replaced by op_opt */
7784             if (oldop && o->op_next) {
7785                 oldop->op_next = o->op_next;
7786                 continue;
7787             }
7788             break;
7789         case OP_SCALAR:
7790         case OP_LINESEQ:
7791         case OP_SCOPE:
7792           nothin:
7793             if (oldop && o->op_next) {
7794                 oldop->op_next = o->op_next;
7795                 continue;
7796             }
7797             o->op_opt = 1;
7798             break;
7799
7800         case OP_PADAV:
7801         case OP_GV:
7802             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7803                 OP* const pop = (o->op_type == OP_PADAV) ?
7804                             o->op_next : o->op_next->op_next;
7805                 IV i;
7806                 if (pop && pop->op_type == OP_CONST &&
7807                     ((PL_op = pop->op_next)) &&
7808                     pop->op_next->op_type == OP_AELEM &&
7809                     !(pop->op_next->op_private &
7810                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7811                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7812                                 <= 255 &&
7813                     i >= 0)
7814                 {
7815                     GV *gv;
7816                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7817                         no_bareword_allowed(pop);
7818                     if (o->op_type == OP_GV)
7819                         op_null(o->op_next);
7820                     op_null(pop->op_next);
7821                     op_null(pop);
7822                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7823                     o->op_next = pop->op_next->op_next;
7824                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7825                     o->op_private = (U8)i;
7826                     if (o->op_type == OP_GV) {
7827                         gv = cGVOPo_gv;
7828                         GvAVn(gv);
7829                     }
7830                     else
7831                         o->op_flags |= OPf_SPECIAL;
7832                     o->op_type = OP_AELEMFAST;
7833                 }
7834                 o->op_opt = 1;
7835                 break;
7836             }
7837
7838             if (o->op_next->op_type == OP_RV2SV) {
7839                 if (!(o->op_next->op_private & OPpDEREF)) {
7840                     op_null(o->op_next);
7841                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7842                                                                | OPpOUR_INTRO);
7843                     o->op_next = o->op_next->op_next;
7844                     o->op_type = OP_GVSV;
7845                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7846                 }
7847             }
7848             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7849                 GV * const gv = cGVOPo_gv;
7850                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7851                     /* XXX could check prototype here instead of just carping */
7852                     SV * const sv = sv_newmortal();
7853                     gv_efullname3(sv, gv, NULL);
7854                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7855                                 "%"SVf"() called too early to check prototype",
7856                                 SVfARG(sv));
7857                 }
7858             }
7859             else if (o->op_next->op_type == OP_READLINE
7860                     && o->op_next->op_next->op_type == OP_CONCAT
7861                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7862             {
7863                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7864                 o->op_type   = OP_RCATLINE;
7865                 o->op_flags |= OPf_STACKED;
7866                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7867                 op_null(o->op_next->op_next);
7868                 op_null(o->op_next);
7869             }
7870
7871             o->op_opt = 1;
7872             break;
7873
7874         case OP_MAPWHILE:
7875         case OP_GREPWHILE:
7876         case OP_AND:
7877         case OP_OR:
7878         case OP_DOR:
7879         case OP_ANDASSIGN:
7880         case OP_ORASSIGN:
7881         case OP_DORASSIGN:
7882         case OP_COND_EXPR:
7883         case OP_RANGE:
7884             o->op_opt = 1;
7885             while (cLOGOP->op_other->op_type == OP_NULL)
7886                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7887             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7888             break;
7889
7890         case OP_ENTERLOOP:
7891         case OP_ENTERITER:
7892             o->op_opt = 1;
7893             while (cLOOP->op_redoop->op_type == OP_NULL)
7894                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7895             peep(cLOOP->op_redoop);
7896             while (cLOOP->op_nextop->op_type == OP_NULL)
7897                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7898             peep(cLOOP->op_nextop);
7899             while (cLOOP->op_lastop->op_type == OP_NULL)
7900                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7901             peep(cLOOP->op_lastop);
7902             break;
7903
7904         case OP_QR:
7905         case OP_MATCH:
7906         case OP_SUBST:
7907             o->op_opt = 1;
7908             while (cPMOP->op_pmreplstart &&
7909                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7910                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7911             peep(cPMOP->op_pmreplstart);
7912             break;
7913
7914         case OP_EXEC:
7915             o->op_opt = 1;
7916             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7917                 && ckWARN(WARN_SYNTAX))
7918             {
7919                 if (o->op_next->op_sibling) {
7920                     const OPCODE type = o->op_next->op_sibling->op_type;
7921                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7922                         const line_t oldline = CopLINE(PL_curcop);
7923                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7924                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7925                                     "Statement unlikely to be reached");
7926                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7927                                     "\t(Maybe you meant system() when you said exec()?)\n");
7928                         CopLINE_set(PL_curcop, oldline);
7929                     }
7930                 }
7931             }
7932             break;
7933
7934         case OP_HELEM: {
7935             UNOP *rop;
7936             SV *lexname;
7937             GV **fields;
7938             SV **svp, *sv;
7939             const char *key = NULL;
7940             STRLEN keylen;
7941
7942             o->op_opt = 1;
7943
7944             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7945                 break;
7946
7947             /* Make the CONST have a shared SV */
7948             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7949             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7950                 key = SvPV_const(sv, keylen);
7951                 lexname = newSVpvn_share(key,
7952                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7953                                          0);
7954                 SvREFCNT_dec(sv);
7955                 *svp = lexname;
7956             }
7957
7958             if ((o->op_private & (OPpLVAL_INTRO)))
7959                 break;
7960
7961             rop = (UNOP*)((BINOP*)o)->op_first;
7962             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7963                 break;
7964             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7965             if (!SvPAD_TYPED(lexname))
7966                 break;
7967             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7968             if (!fields || !GvHV(*fields))
7969                 break;
7970             key = SvPV_const(*svp, keylen);
7971             if (!hv_fetch(GvHV(*fields), key,
7972                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7973             {
7974                 Perl_croak(aTHX_ "No such class field \"%s\" "
7975                            "in variable %s of type %s",
7976                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7977             }
7978
7979             break;
7980         }
7981
7982         case OP_HSLICE: {
7983             UNOP *rop;
7984             SV *lexname;
7985             GV **fields;
7986             SV **svp;
7987             const char *key;
7988             STRLEN keylen;
7989             SVOP *first_key_op, *key_op;
7990
7991             if ((o->op_private & (OPpLVAL_INTRO))
7992                 /* I bet there's always a pushmark... */
7993                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7994                 /* hmmm, no optimization if list contains only one key. */
7995                 break;
7996             rop = (UNOP*)((LISTOP*)o)->op_last;
7997             if (rop->op_type != OP_RV2HV)
7998                 break;
7999             if (rop->op_first->op_type == OP_PADSV)
8000                 /* @$hash{qw(keys here)} */
8001                 rop = (UNOP*)rop->op_first;
8002             else {
8003                 /* @{$hash}{qw(keys here)} */
8004                 if (rop->op_first->op_type == OP_SCOPE
8005                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8006                 {
8007                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8008                 }
8009                 else
8010                     break;
8011             }
8012
8013             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8014             if (!SvPAD_TYPED(lexname))
8015                 break;
8016             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8017             if (!fields || !GvHV(*fields))
8018                 break;
8019             /* Again guessing that the pushmark can be jumped over.... */
8020             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8021                 ->op_first->op_sibling;
8022             for (key_op = first_key_op; key_op;
8023                  key_op = (SVOP*)key_op->op_sibling) {
8024                 if (key_op->op_type != OP_CONST)
8025                     continue;
8026                 svp = cSVOPx_svp(key_op);
8027                 key = SvPV_const(*svp, keylen);
8028                 if (!hv_fetch(GvHV(*fields), key,
8029                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8030                 {
8031                     Perl_croak(aTHX_ "No such class field \"%s\" "
8032                                "in variable %s of type %s",
8033                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8034                 }
8035             }
8036             break;
8037         }
8038
8039         case OP_SORT: {
8040             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8041             OP *oleft;
8042             OP *o2;
8043
8044             /* check that RHS of sort is a single plain array */
8045             OP *oright = cUNOPo->op_first;
8046             if (!oright || oright->op_type != OP_PUSHMARK)
8047                 break;
8048
8049             /* reverse sort ... can be optimised.  */
8050             if (!cUNOPo->op_sibling) {
8051                 /* Nothing follows us on the list. */
8052                 OP * const reverse = o->op_next;
8053
8054                 if (reverse->op_type == OP_REVERSE &&
8055                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8056                     OP * const pushmark = cUNOPx(reverse)->op_first;
8057                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8058                         && (cUNOPx(pushmark)->op_sibling == o)) {
8059                         /* reverse -> pushmark -> sort */
8060                         o->op_private |= OPpSORT_REVERSE;
8061                         op_null(reverse);
8062                         pushmark->op_next = oright->op_next;
8063                         op_null(oright);
8064                     }
8065                 }
8066             }
8067
8068             /* make @a = sort @a act in-place */
8069
8070             o->op_opt = 1;
8071
8072             oright = cUNOPx(oright)->op_sibling;
8073             if (!oright)
8074                 break;
8075             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8076                 oright = cUNOPx(oright)->op_sibling;
8077             }
8078
8079             if (!oright ||
8080                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8081                 || oright->op_next != o
8082                 || (oright->op_private & OPpLVAL_INTRO)
8083             )
8084                 break;
8085
8086             /* o2 follows the chain of op_nexts through the LHS of the
8087              * assign (if any) to the aassign op itself */
8088             o2 = o->op_next;
8089             if (!o2 || o2->op_type != OP_NULL)
8090                 break;
8091             o2 = o2->op_next;
8092             if (!o2 || o2->op_type != OP_PUSHMARK)
8093                 break;
8094             o2 = o2->op_next;
8095             if (o2 && o2->op_type == OP_GV)
8096                 o2 = o2->op_next;
8097             if (!o2
8098                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8099                 || (o2->op_private & OPpLVAL_INTRO)
8100             )
8101                 break;
8102             oleft = o2;
8103             o2 = o2->op_next;
8104             if (!o2 || o2->op_type != OP_NULL)
8105                 break;
8106             o2 = o2->op_next;
8107             if (!o2 || o2->op_type != OP_AASSIGN
8108                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8109                 break;
8110
8111             /* check that the sort is the first arg on RHS of assign */
8112
8113             o2 = cUNOPx(o2)->op_first;
8114             if (!o2 || o2->op_type != OP_NULL)
8115                 break;
8116             o2 = cUNOPx(o2)->op_first;
8117             if (!o2 || o2->op_type != OP_PUSHMARK)
8118                 break;
8119             if (o2->op_sibling != o)
8120                 break;
8121
8122             /* check the array is the same on both sides */
8123             if (oleft->op_type == OP_RV2AV) {
8124                 if (oright->op_type != OP_RV2AV
8125                     || !cUNOPx(oright)->op_first
8126                     || cUNOPx(oright)->op_first->op_type != OP_GV
8127                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8128                         cGVOPx_gv(cUNOPx(oright)->op_first)
8129                 )
8130                     break;
8131             }
8132             else if (oright->op_type != OP_PADAV
8133                 || oright->op_targ != oleft->op_targ
8134             )
8135                 break;
8136
8137             /* transfer MODishness etc from LHS arg to RHS arg */
8138             oright->op_flags = oleft->op_flags;
8139             o->op_private |= OPpSORT_INPLACE;
8140
8141             /* excise push->gv->rv2av->null->aassign */
8142             o2 = o->op_next->op_next;
8143             op_null(o2); /* PUSHMARK */
8144             o2 = o2->op_next;
8145             if (o2->op_type == OP_GV) {
8146                 op_null(o2); /* GV */
8147                 o2 = o2->op_next;
8148             }
8149             op_null(o2); /* RV2AV or PADAV */
8150             o2 = o2->op_next->op_next;
8151             op_null(o2); /* AASSIGN */
8152
8153             o->op_next = o2->op_next;
8154
8155             break;
8156         }
8157
8158         case OP_REVERSE: {
8159             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8160             OP *gvop = NULL;
8161             LISTOP *enter, *exlist;
8162             o->op_opt = 1;
8163
8164             enter = (LISTOP *) o->op_next;
8165             if (!enter)
8166                 break;
8167             if (enter->op_type == OP_NULL) {
8168                 enter = (LISTOP *) enter->op_next;
8169                 if (!enter)
8170                     break;
8171             }
8172             /* for $a (...) will have OP_GV then OP_RV2GV here.
8173                for (...) just has an OP_GV.  */
8174             if (enter->op_type == OP_GV) {
8175                 gvop = (OP *) enter;
8176                 enter = (LISTOP *) enter->op_next;
8177                 if (!enter)
8178                     break;
8179                 if (enter->op_type == OP_RV2GV) {
8180                   enter = (LISTOP *) enter->op_next;
8181                   if (!enter)
8182                     break;
8183                 }
8184             }
8185
8186             if (enter->op_type != OP_ENTERITER)
8187                 break;
8188
8189             iter = enter->op_next;
8190             if (!iter || iter->op_type != OP_ITER)
8191                 break;
8192
8193             expushmark = enter->op_first;
8194             if (!expushmark || expushmark->op_type != OP_NULL
8195                 || expushmark->op_targ != OP_PUSHMARK)
8196                 break;
8197
8198             exlist = (LISTOP *) expushmark->op_sibling;
8199             if (!exlist || exlist->op_type != OP_NULL
8200                 || exlist->op_targ != OP_LIST)
8201                 break;
8202
8203             if (exlist->op_last != o) {
8204                 /* Mmm. Was expecting to point back to this op.  */
8205                 break;
8206             }
8207             theirmark = exlist->op_first;
8208             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8209                 break;
8210
8211             if (theirmark->op_sibling != o) {
8212                 /* There's something between the mark and the reverse, eg
8213                    for (1, reverse (...))
8214                    so no go.  */
8215                 break;
8216             }
8217
8218             ourmark = ((LISTOP *)o)->op_first;
8219             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8220                 break;
8221
8222             ourlast = ((LISTOP *)o)->op_last;
8223             if (!ourlast || ourlast->op_next != o)
8224                 break;
8225
8226             rv2av = ourmark->op_sibling;
8227             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8228                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8229                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8230                 /* We're just reversing a single array.  */
8231                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8232                 enter->op_flags |= OPf_STACKED;
8233             }
8234
8235             /* We don't have control over who points to theirmark, so sacrifice
8236                ours.  */
8237             theirmark->op_next = ourmark->op_next;
8238             theirmark->op_flags = ourmark->op_flags;
8239             ourlast->op_next = gvop ? gvop : (OP *) enter;
8240             op_null(ourmark);
8241             op_null(o);
8242             enter->op_private |= OPpITER_REVERSED;
8243             iter->op_private |= OPpITER_REVERSED;
8244
8245             break;
8246         }
8247
8248         case OP_SASSIGN: {
8249             OP *rv2gv;
8250             UNOP *refgen, *rv2cv;
8251             LISTOP *exlist;
8252
8253             /* I do not understand this, but if o->op_opt isn't set to 1,
8254                various tests in ext/B/t/bytecode.t fail with no readily
8255                apparent cause.  */
8256
8257             o->op_opt = 1;
8258
8259
8260             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8261                 break;
8262
8263             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8264                 break;
8265
8266             rv2gv = ((BINOP *)o)->op_last;
8267             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8268                 break;
8269
8270             refgen = (UNOP *)((BINOP *)o)->op_first;
8271
8272             if (!refgen || refgen->op_type != OP_REFGEN)
8273                 break;
8274
8275             exlist = (LISTOP *)refgen->op_first;
8276             if (!exlist || exlist->op_type != OP_NULL
8277                 || exlist->op_targ != OP_LIST)
8278                 break;
8279
8280             if (exlist->op_first->op_type != OP_PUSHMARK)
8281                 break;
8282
8283             rv2cv = (UNOP*)exlist->op_last;
8284
8285             if (rv2cv->op_type != OP_RV2CV)
8286                 break;
8287
8288             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8289             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8290             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8291
8292             o->op_private |= OPpASSIGN_CV_TO_GV;
8293             rv2gv->op_private |= OPpDONT_INIT_GV;
8294             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8295
8296             break;
8297         }
8298
8299
8300         default:
8301             o->op_opt = 1;
8302             break;
8303         }
8304         oldop = o;
8305     }
8306     LEAVE;
8307 }
8308
8309 char*
8310 Perl_custom_op_name(pTHX_ const OP* o)
8311 {
8312     dVAR;
8313     const IV index = PTR2IV(o->op_ppaddr);
8314     SV* keysv;
8315     HE* he;
8316
8317     if (!PL_custom_op_names) /* This probably shouldn't happen */
8318         return (char *)PL_op_name[OP_CUSTOM];
8319
8320     keysv = sv_2mortal(newSViv(index));
8321
8322     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8323     if (!he)
8324         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8325
8326     return SvPV_nolen(HeVAL(he));
8327 }
8328
8329 char*
8330 Perl_custom_op_desc(pTHX_ const OP* o)
8331 {
8332     dVAR;
8333     const IV index = PTR2IV(o->op_ppaddr);
8334     SV* keysv;
8335     HE* he;
8336
8337     if (!PL_custom_op_descs)
8338         return (char *)PL_op_desc[OP_CUSTOM];
8339
8340     keysv = sv_2mortal(newSViv(index));
8341
8342     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8343     if (!he)
8344         return (char *)PL_op_desc[OP_CUSTOM];
8345
8346     return SvPV_nolen(HeVAL(he));
8347 }
8348
8349 #include "XSUB.h"
8350
8351 /* Efficient sub that returns a constant scalar value. */
8352 static void
8353 const_sv_xsub(pTHX_ CV* cv)
8354 {
8355     dVAR;
8356     dXSARGS;
8357     if (items != 0) {
8358         NOOP;
8359 #if 0
8360         Perl_croak(aTHX_ "usage: %s::%s()",
8361                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8362 #endif
8363     }
8364     EXTEND(sp, 1);
8365     ST(0) = (SV*)XSANY.any_ptr;
8366     XSRETURN(1);
8367 }
8368
8369 /*
8370  * Local variables:
8371  * c-indentation-style: bsd
8372  * c-basic-offset: 4
8373  * indent-tabs-mode: t
8374  * End:
8375  *
8376  * ex: set ts=8 sts=4 sw=4 noet:
8377  */