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