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