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