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