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