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