pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 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  * Now far ahead the Road has gone,
  13  * And I must follow, if I can,
  14  * Pursuing it with eager feet,
  15  * Until it joins some larger way
  16  * Where many paths and errands meet.
  17  * And whither then?  I cannot say.
  18  */
  19
  20 /* This file contains control-oriented pp ("push/pop") functions that
  21  * execute the opcodes that make up a perl program. A typical pp function
  22  * expects to find its arguments on the stack, and usually pushes its
  23  * results onto the stack, hence the 'pp' terminology. Each OP structure
  24  * contains a pointer to the relevant pp_foo() function.
  25  *
  26  * Control-oriented means things like pp_enteriter() and pp_next(), which
  27  * alter the flow of control of the program.
  28  */
  29
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_PP_CTL_C
  33 #include "perl.h"
  34
  35 #ifndef WORD_ALIGN
  36 #define WORD_ALIGN sizeof(U32)
  37 #endif
  38
  39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  40
  41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  42
  43 PP(pp_wantarray)
  44 {
  45     dSP;
  46     I32 cxix;
  47     EXTEND(SP, 1);
  48
  49     cxix = dopoptosub(cxstack_ix);
  50     if (cxix < 0)
  51         RETPUSHUNDEF;
  52
  53     switch (cxstack[cxix].blk_gimme) {
  54     case G_ARRAY:
  55         RETPUSHYES;
  56     case G_SCALAR:
  57         RETPUSHNO;
  58     default:
  59         RETPUSHUNDEF;
  60     }
  61 }
  62
  63 PP(pp_regcmaybe)
  64 {
  65     return NORMAL;
  66 }
  67
  68 PP(pp_regcreset)
  69 {
  70     /* XXXX Should store the old value to allow for tie/overload - and
  71        restore in regcomp, where marked with XXXX. */
  72     PL_reginterp_cnt = 0;
  73     TAINT_NOT;
  74     return NORMAL;
  75 }
  76
  77 PP(pp_regcomp)
  78 {
  79     dSP;
  80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     register char *t;
  82     SV *tmpstr;
  83     STRLEN len;
  84     MAGIC *mg = Null(MAGIC*);
  85
  86     /* prevent recompiling under /o and ithreads. */
  87 #if defined(USE_ITHREADS)
  88     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  89         if (PL_op->op_flags & OPf_STACKED) {
  90             dMARK;
  91             SP = MARK;
  92         }
  93         else
  94             (void)POPs;
  95         RETURN;
  96     }
  97 #endif
  98     if (PL_op->op_flags & OPf_STACKED) {
  99         /* multiple args; concatentate them */
 100         dMARK; dORIGMARK;
 101         tmpstr = PAD_SV(ARGTARG);
 102         sv_setpvn(tmpstr, "", 0);
 103         while (++MARK <= SP) {
 104             if (PL_amagic_generation) {
 105                 SV *sv;
 106                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
 107                     (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
 108                 {
 109                    sv_setsv(tmpstr, sv);
 110                    continue;
 111                 }
 112             }
 113             sv_catsv(tmpstr, *MARK);
 114         }
 115         SvSETMAGIC(tmpstr);
 116         SP = ORIGMARK;
 117     }
 118     else
 119         tmpstr = POPs;
 120
 121     if (SvROK(tmpstr)) {
 122         SV *sv = SvRV(tmpstr);
 123         if(SvMAGICAL(sv))
 124             mg = mg_find(sv, PERL_MAGIC_qr);
 125     }
 126     if (mg) {
 127         regexp *re = (regexp *)mg->mg_obj;
 128         ReREFCNT_dec(PM_GETRE(pm));
 129         PM_SETRE(pm, ReREFCNT_inc(re));
 130     }
 131     else {
 132         t = SvPV(tmpstr, len);
 133
 134         /* Check against the last compiled regexp. */
 135         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
 136             PM_GETRE(pm)->prelen != (I32)len ||
 137             memNE(PM_GETRE(pm)->precomp, t, len))
 138         {
 139             if (PM_GETRE(pm)) {
 140                 ReREFCNT_dec(PM_GETRE(pm));
 141                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
 142             }
 143             if (PL_op->op_flags & OPf_SPECIAL)
 144                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 145
 146             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 147             if (DO_UTF8(tmpstr))
 148                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 149             else {
 150                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 151                 if (pm->op_pmdynflags & PMdf_UTF8)
 152                     t = (char*)bytes_to_utf8((U8*)t, &len);
 153             }
 154             PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
 155             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
 156                 Safefree(t);
 157             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 158                                            inside tie/overload accessors.  */
 159         }
 160     }
 161
 162 #ifndef INCOMPLETE_TAINTS
 163     if (PL_tainting) {
 164         if (PL_tainted)
 165             pm->op_pmdynflags |= PMdf_TAINTED;
 166         else
 167             pm->op_pmdynflags &= ~PMdf_TAINTED;
 168     }
 169 #endif
 170
 171     if (!PM_GETRE(pm)->prelen && PL_curpm)
 172         pm = PL_curpm;
 173     else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
 174         pm->op_pmflags |= PMf_WHITE;
 175     else
 176         pm->op_pmflags &= ~PMf_WHITE;
 177
 178     /* XXX runtime compiled output needs to move to the pad */
 179     if (pm->op_pmflags & PMf_KEEP) {
 180         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 181 #if !defined(USE_ITHREADS)
 182         /* XXX can't change the optree at runtime either */
 183         cLOGOP->op_first->op_next = PL_op->op_next;
 184 #endif
 185     }
 186     RETURN;
 187 }
 188
 189 PP(pp_substcont)
 190 {
 191     dSP;
 192     register PMOP *pm = (PMOP*) cLOGOP->op_other;
 193     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 194     register SV *dstr = cx->sb_dstr;
 195     register char *s = cx->sb_s;
 196     register char *m = cx->sb_m;
 197     char *orig = cx->sb_orig;
 198     register REGEXP *rx = cx->sb_rx;
 199     SV *nsv = Nullsv;
 200     REGEXP *old = PM_GETRE(pm);
 201     if(old != rx) {
 202         if(old)
 203             ReREFCNT_dec(old);
 204         PM_SETRE(pm,rx);
 205     }
 206
 207     rxres_restore(&cx->sb_rxres, rx);
 208     RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
 209
 210     if (cx->sb_iters++) {
 211         I32 saviters = cx->sb_iters;
 212         if (cx->sb_iters > cx->sb_maxiters)
 213             DIE(aTHX_ "Substitution loop");
 214
 215         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 216             cx->sb_rxtainted |= 2;
 217         sv_catsv(dstr, POPs);
 218
 219         /* Are we done */
 220         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 221                                      s == m, cx->sb_targ, NULL,
 222                                      ((cx->sb_rflags & REXEC_COPY_STR)
 223                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 224                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 225         {
 226             SV *targ = cx->sb_targ;
 227
 228             assert(cx->sb_strend >= s);
 229             if(cx->sb_strend > s) {
 230                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 231                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 232                  else
 233                       sv_catpvn(dstr, s, cx->sb_strend - s);
 234             }
 235             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 236
 237 #ifdef PERL_COPY_ON_WRITE
 238             if (SvIsCOW(targ)) {
 239                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 240             } else
 241 #endif
 242             {
 243                 SvOOK_off(targ);
 244                 if (SvLEN(targ))
 245                     Safefree(SvPVX(targ));
 246             }
 247             SvPV_set(targ, SvPVX(dstr));
 248             SvCUR_set(targ, SvCUR(dstr));
 249             SvLEN_set(targ, SvLEN(dstr));
 250             if (DO_UTF8(dstr))
 251                 SvUTF8_on(targ);
 252             SvPV_set(dstr, (char*)0);
 253             sv_free(dstr);
 254
 255             TAINT_IF(cx->sb_rxtainted & 1);
 256             PUSHs(sv_2mortal(newSViv(saviters - 1)));
 257
 258             (void)SvPOK_only_UTF8(targ);
 259             TAINT_IF(cx->sb_rxtainted);
 260             SvSETMAGIC(targ);
 261             SvTAINT(targ);
 262
 263             LEAVE_SCOPE(cx->sb_oldsave);
 264             ReREFCNT_dec(rx);
 265             POPSUBST(cx);
 266             RETURNOP(pm->op_next);
 267         }
 268         cx->sb_iters = saviters;
 269     }
 270     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 271         m = s;
 272         s = orig;
 273         cx->sb_orig = orig = rx->subbeg;
 274         s = orig + (m - s);
 275         cx->sb_strend = s + (cx->sb_strend - m);
 276     }
 277     cx->sb_m = m = rx->startp[0] + orig;
 278     if (m > s) {
 279         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 280             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 281         else
 282             sv_catpvn(dstr, s, m-s);
 283     }
 284     cx->sb_s = rx->endp[0] + orig;
 285     { /* Update the pos() information. */
 286         SV *sv = cx->sb_targ;
 287         MAGIC *mg;
 288         I32 i;
 289         if (SvTYPE(sv) < SVt_PVMG)
 290             (void)SvUPGRADE(sv, SVt_PVMG);
 291         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 292             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 293             mg = mg_find(sv, PERL_MAGIC_regex_global);
 294         }
 295         i = m - orig;
 296         if (DO_UTF8(sv))
 297             sv_pos_b2u(sv, &i);
 298         mg->mg_len = i;
 299     }
 300     if (old != rx)
 301         ReREFCNT_inc(rx);
 302     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 303     rxres_save(&cx->sb_rxres, rx);
 304     RETURNOP(pm->op_pmreplstart);
 305 }
 306
 307 void
 308 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 309 {
 310     UV *p = (UV*)*rsp;
 311     U32 i;
 312
 313     if (!p || p[1] < rx->nparens) {
 314 #ifdef PERL_COPY_ON_WRITE
 315         i = 7 + rx->nparens * 2;
 316 #else
 317         i = 6 + rx->nparens * 2;
 318 #endif
 319         if (!p)
 320             New(501, p, i, UV);
 321         else
 322             Renew(p, i, UV);
 323         *rsp = (void*)p;
 324     }
 325
 326     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 327     RX_MATCH_COPIED_off(rx);
 328
 329 #ifdef PERL_COPY_ON_WRITE
 330     *p++ = PTR2UV(rx->saved_copy);
 331     rx->saved_copy = Nullsv;
 332 #endif
 333
 334     *p++ = rx->nparens;
 335
 336     *p++ = PTR2UV(rx->subbeg);
 337     *p++ = (UV)rx->sublen;
 338     for (i = 0; i <= rx->nparens; ++i) {
 339         *p++ = (UV)rx->startp[i];
 340         *p++ = (UV)rx->endp[i];
 341     }
 342 }
 343
 344 void
 345 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 346 {
 347     UV *p = (UV*)*rsp;
 348     U32 i;
 349
 350     RX_MATCH_COPY_FREE(rx);
 351     RX_MATCH_COPIED_set(rx, *p);
 352     *p++ = 0;
 353
 354 #ifdef PERL_COPY_ON_WRITE
 355     if (rx->saved_copy)
 356         SvREFCNT_dec (rx->saved_copy);
 357     rx->saved_copy = INT2PTR(SV*,*p);
 358     *p++ = 0;
 359 #endif
 360
 361     rx->nparens = *p++;
 362
 363     rx->subbeg = INT2PTR(char*,*p++);
 364     rx->sublen = (I32)(*p++);
 365     for (i = 0; i <= rx->nparens; ++i) {
 366         rx->startp[i] = (I32)(*p++);
 367         rx->endp[i] = (I32)(*p++);
 368     }
 369 }
 370
 371 void
 372 Perl_rxres_free(pTHX_ void **rsp)
 373 {
 374     UV *p = (UV*)*rsp;
 375
 376     if (p) {
 377         Safefree(INT2PTR(char*,*p));
 378 #ifdef PERL_COPY_ON_WRITE
 379         if (p[1]) {
 380             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 381         }
 382 #endif
 383         Safefree(p);
 384         *rsp = Null(void*);
 385     }
 386 }
 387
 388 PP(pp_formline)
 389 {
 390     dSP; dMARK; dORIGMARK;
 391     register SV *tmpForm = *++MARK;
 392     register U32 *fpc;
 393     register char *t;
 394     register char *f;
 395     register char *s;
 396     register char *send;
 397     register I32 arg;
 398     register SV *sv = Nullsv;
 399     char *item = Nullch;
 400     I32 itemsize  = 0;
 401     I32 fieldsize = 0;
 402     I32 lines = 0;
 403     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 404     char *chophere = Nullch;
 405     char *linemark = Nullch;
 406     NV value;
 407     bool gotsome = FALSE;
 408     STRLEN len;
 409     STRLEN fudge = SvPOK(tmpForm)
 410                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 411     bool item_is_utf8 = FALSE;
 412     bool targ_is_utf8 = FALSE;
 413     SV * nsv = Nullsv;
 414     OP * parseres = 0;
 415     const char *fmt;
 416     bool oneline;
 417
 418     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 419         if (SvREADONLY(tmpForm)) {
 420             SvREADONLY_off(tmpForm);
 421             parseres = doparseform(tmpForm);
 422             SvREADONLY_on(tmpForm);
 423         }
 424         else
 425             parseres = doparseform(tmpForm);
 426         if (parseres)
 427             return parseres;
 428     }
 429     SvPV_force(PL_formtarget, len);
 430     if (DO_UTF8(PL_formtarget))
 431         targ_is_utf8 = TRUE;
 432     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 433     t += len;
 434     f = SvPV(tmpForm, len);
 435     /* need to jump to the next word */
 436     s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
 437
 438     fpc = (U32*)s;
 439
 440     for (;;) {
 441         DEBUG_f( {
 442             const char *name = "???";
 443             arg = -1;
 444             switch (*fpc) {
 445             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 446             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 447             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 448             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 449             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 450
 451             case FF_CHECKNL:    name = "CHECKNL";       break;
 452             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 453             case FF_SPACE:      name = "SPACE";         break;
 454             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 455             case FF_ITEM:       name = "ITEM";          break;
 456             case FF_CHOP:       name = "CHOP";          break;
 457             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 458             case FF_NEWLINE:    name = "NEWLINE";       break;
 459             case FF_MORE:       name = "MORE";          break;
 460             case FF_LINEMARK:   name = "LINEMARK";      break;
 461             case FF_END:        name = "END";           break;
 462             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 463             case FF_LINESNGL:   name = "LINESNGL";      break;
 464             }
 465             if (arg >= 0)
 466                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 467             else
 468                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 469         } );
 470         switch (*fpc++) {
 471         case FF_LINEMARK:
 472             linemark = t;
 473             lines++;
 474             gotsome = FALSE;
 475             break;
 476
 477         case FF_LITERAL:
 478             arg = *fpc++;
 479             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 480                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 481                 *t = '\0';
 482                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 483                 t = SvEND(PL_formtarget);
 484                 break;
 485             }
 486             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 487                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 488                 *t = '\0';
 489                 sv_utf8_upgrade(PL_formtarget);
 490                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 491                 t = SvEND(PL_formtarget);
 492                 targ_is_utf8 = TRUE;
 493             }
 494             while (arg--)
 495                 *t++ = *f++;
 496             break;
 497
 498         case FF_SKIP:
 499             f += *fpc++;
 500             break;
 501
 502         case FF_FETCH:
 503             arg = *fpc++;
 504             f += arg;
 505             fieldsize = arg;
 506
 507             if (MARK < SP)
 508                 sv = *++MARK;
 509             else {
 510                 sv = &PL_sv_no;
 511                 if (ckWARN(WARN_SYNTAX))
 512                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 513             }
 514             break;
 515
 516         case FF_CHECKNL:
 517             item = s = SvPV(sv, len);
 518             itemsize = len;
 519             if (DO_UTF8(sv)) {
 520                 itemsize = sv_len_utf8(sv);
 521                 if (itemsize != (I32)len) {
 522                     I32 itembytes;
 523                     if (itemsize > fieldsize) {
 524                         itemsize = fieldsize;
 525                         itembytes = itemsize;
 526                         sv_pos_u2b(sv, &itembytes, 0);
 527                     }
 528                     else
 529                         itembytes = len;
 530                     send = chophere = s + itembytes;
 531                     while (s < send) {
 532                         if (*s & ~31)
 533                             gotsome = TRUE;
 534                         else if (*s == '\n')
 535                             break;
 536                         s++;
 537                     }
 538                     item_is_utf8 = TRUE;
 539                     itemsize = s - item;
 540                     sv_pos_b2u(sv, &itemsize);
 541                     break;
 542                 }
 543             }
 544             item_is_utf8 = FALSE;
 545             if (itemsize > fieldsize)
 546                 itemsize = fieldsize;
 547             send = chophere = s + itemsize;
 548             while (s < send) {
 549                 if (*s & ~31)
 550                     gotsome = TRUE;
 551                 else if (*s == '\n')
 552                     break;
 553                 s++;
 554             }
 555             itemsize = s - item;
 556             break;
 557
 558         case FF_CHECKCHOP:
 559             item = s = SvPV(sv, len);
 560             itemsize = len;
 561             if (DO_UTF8(sv)) {
 562                 itemsize = sv_len_utf8(sv);
 563                 if (itemsize != (I32)len) {
 564                     I32 itembytes;
 565                     if (itemsize <= fieldsize) {
 566                         send = chophere = s + itemsize;
 567                         while (s < send) {
 568                             if (*s == '\r') {
 569                                 itemsize = s - item;
 570                                 chophere = s;
 571                                 break;
 572                             }
 573                             if (*s++ & ~31)
 574                                 gotsome = TRUE;
 575                         }
 576                     }
 577                     else {
 578                         itemsize = fieldsize;
 579                         itembytes = itemsize;
 580                         sv_pos_u2b(sv, &itembytes, 0);
 581                         send = chophere = s + itembytes;
 582                         while (s < send || (s == send && isSPACE(*s))) {
 583                             if (isSPACE(*s)) {
 584                                 if (chopspace)
 585                                     chophere = s;
 586                                 if (*s == '\r')
 587                                     break;
 588                             }
 589                             else {
 590                                 if (*s & ~31)
 591                                     gotsome = TRUE;
 592                                 if (strchr(PL_chopset, *s))
 593                                     chophere = s + 1;
 594                             }
 595                             s++;
 596                         }
 597                         itemsize = chophere - item;
 598                         sv_pos_b2u(sv, &itemsize);
 599                     }
 600                     item_is_utf8 = TRUE;
 601                     break;
 602                 }
 603             }
 604             item_is_utf8 = FALSE;
 605             if (itemsize <= fieldsize) {
 606                 send = chophere = s + itemsize;
 607                 while (s < send) {
 608                     if (*s == '\r') {
 609                         itemsize = s - item;
 610                         chophere = s;
 611                         break;
 612                     }
 613                     if (*s++ & ~31)
 614                         gotsome = TRUE;
 615                 }
 616             }
 617             else {
 618                 itemsize = fieldsize;
 619                 send = chophere = s + itemsize;
 620                 while (s < send || (s == send && isSPACE(*s))) {
 621                     if (isSPACE(*s)) {
 622                         if (chopspace)
 623                             chophere = s;
 624                         if (*s == '\r')
 625                             break;
 626                     }
 627                     else {
 628                         if (*s & ~31)
 629                             gotsome = TRUE;
 630                         if (strchr(PL_chopset, *s))
 631                             chophere = s + 1;
 632                     }
 633                     s++;
 634                 }
 635                 itemsize = chophere - item;
 636             }
 637             break;
 638
 639         case FF_SPACE:
 640             arg = fieldsize - itemsize;
 641             if (arg) {
 642                 fieldsize -= arg;
 643                 while (arg-- > 0)
 644                     *t++ = ' ';
 645             }
 646             break;
 647
 648         case FF_HALFSPACE:
 649             arg = fieldsize - itemsize;
 650             if (arg) {
 651                 arg /= 2;
 652                 fieldsize -= arg;
 653                 while (arg-- > 0)
 654                     *t++ = ' ';
 655             }
 656             break;
 657
 658         case FF_ITEM:
 659             arg = itemsize;
 660             s = item;
 661             if (item_is_utf8) {
 662                 if (!targ_is_utf8) {
 663                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 664                     *t = '\0';
 665                     sv_utf8_upgrade(PL_formtarget);
 666                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 667                     t = SvEND(PL_formtarget);
 668                     targ_is_utf8 = TRUE;
 669                 }
 670                 while (arg--) {
 671                     if (UTF8_IS_CONTINUED(*s)) {
 672                         STRLEN skip = UTF8SKIP(s);
 673                         switch (skip) {
 674                         default:
 675                             Move(s,t,skip,char);
 676                             s += skip;
 677                             t += skip;
 678                             break;
 679                         case 7: *t++ = *s++;
 680                         case 6: *t++ = *s++;
 681                         case 5: *t++ = *s++;
 682                         case 4: *t++ = *s++;
 683                         case 3: *t++ = *s++;
 684                         case 2: *t++ = *s++;
 685                         case 1: *t++ = *s++;
 686                         }
 687                     }
 688                     else {
 689                         if ( !((*t++ = *s++) & ~31) )
 690                             t[-1] = ' ';
 691                     }
 692                 }
 693                 break;
 694             }
 695             if (targ_is_utf8 && !item_is_utf8) {
 696                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 697                 *t = '\0';
 698                 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 699                 for (; t < SvEND(PL_formtarget); t++) {
 700 #ifdef EBCDIC
 701                     int ch = *t;
 702                     if (iscntrl(ch))
 703 #else
 704                     if (!(*t & ~31))
 705 #endif
 706                         *t = ' ';
 707                 }
 708                 break;
 709             }
 710             while (arg--) {
 711 #ifdef EBCDIC
 712                 int ch = *t++ = *s++;
 713                 if (iscntrl(ch))
 714 #else
 715                 if ( !((*t++ = *s++) & ~31) )
 716 #endif
 717                     t[-1] = ' ';
 718             }
 719             break;
 720
 721         case FF_CHOP:
 722             s = chophere;
 723             if (chopspace) {
 724                 while (*s && isSPACE(*s))
 725                     s++;
 726             }
 727             sv_chop(sv,s);
 728             SvSETMAGIC(sv);
 729             break;
 730
 731         case FF_LINESNGL:
 732             chopspace = 0;
 733             oneline = TRUE;
 734             goto ff_line;
 735         case FF_LINEGLOB:
 736             oneline = FALSE;
 737         ff_line:
 738             item = s = SvPV(sv, len);
 739             itemsize = len;
 740             if ((item_is_utf8 = DO_UTF8(sv)))
 741                 itemsize = sv_len_utf8(sv);
 742             if (itemsize) {
 743                 bool chopped = FALSE;
 744                 gotsome = TRUE;
 745                 send = s + len;
 746                 chophere = s + itemsize;
 747                 while (s < send) {
 748                     if (*s++ == '\n') {
 749                         if (oneline) {
 750                             chopped = TRUE;
 751                             chophere = s;
 752                             break;
 753                         } else {
 754                             if (s == send) {
 755                                 itemsize--;
 756                                 chopped = TRUE;
 757                             } else
 758                                 lines++;
 759                         }
 760                     }
 761                 }
 762                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 763                 if (targ_is_utf8)
 764                     SvUTF8_on(PL_formtarget);
 765                 if (oneline) {
 766                     SvCUR_set(sv, chophere - item);
 767                     sv_catsv(PL_formtarget, sv);
 768                     SvCUR_set(sv, itemsize);
 769                 } else
 770                     sv_catsv(PL_formtarget, sv);
 771                 if (chopped)
 772                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 773                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 774                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 775                 if (item_is_utf8)
 776                     targ_is_utf8 = TRUE;
 777             }
 778             break;
 779
 780         case FF_0DECIMAL:
 781             arg = *fpc++;
 782 #if defined(USE_LONG_DOUBLE)
 783             fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
 784 #else
 785             fmt = (arg & 256) ? "%#0*.*f"              : "%0*.*f";
 786 #endif
 787             goto ff_dec;
 788         case FF_DECIMAL:
 789             arg = *fpc++;
 790 #if defined(USE_LONG_DOUBLE)
 791             fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
 792 #else
 793             fmt = (arg & 256) ? "%#*.*f"              : "%*.*f";
 794 #endif
 795         ff_dec:
 796             /* If the field is marked with ^ and the value is undefined,
 797                blank it out. */
 798             if ((arg & 512) && !SvOK(sv)) {
 799                 arg = fieldsize;
 800                 while (arg--)
 801                     *t++ = ' ';
 802                 break;
 803             }
 804             gotsome = TRUE;
 805             value = SvNV(sv);
 806             /* overflow evidence */
 807             if (num_overflow(value, fieldsize, arg)) {
 808                 arg = fieldsize;
 809                 while (arg--)
 810                     *t++ = '#';
 811                 break;
 812             }
 813             /* Formats aren't yet marked for locales, so assume "yes". */
 814             {
 815                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 816                 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
 817                 RESTORE_NUMERIC_STANDARD();
 818             }
 819             t += fieldsize;
 820             break;
 821
 822         case FF_NEWLINE:
 823             f++;
 824             while (t-- > linemark && *t == ' ') ;
 825             t++;
 826             *t++ = '\n';
 827             break;
 828
 829         case FF_BLANK:
 830             arg = *fpc++;
 831             if (gotsome) {
 832                 if (arg) {              /* repeat until fields exhausted? */
 833                     *t = '\0';
 834                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 835                     lines += FmLINES(PL_formtarget);
 836                     if (lines == 200) {
 837                         arg = t - linemark;
 838                         if (strnEQ(linemark, linemark - arg, arg))
 839                             DIE(aTHX_ "Runaway format");
 840                     }
 841                     if (targ_is_utf8)
 842                         SvUTF8_on(PL_formtarget);
 843                     FmLINES(PL_formtarget) = lines;
 844                     SP = ORIGMARK;
 845                     RETURNOP(cLISTOP->op_first);
 846                 }
 847             }
 848             else {
 849                 t = linemark;
 850                 lines--;
 851             }
 852             break;
 853
 854         case FF_MORE:
 855             s = chophere;
 856             send = item + len;
 857             if (chopspace) {
 858                 while (*s && isSPACE(*s) && s < send)
 859                     s++;
 860             }
 861             if (s < send) {
 862                 arg = fieldsize - itemsize;
 863                 if (arg) {
 864                     fieldsize -= arg;
 865                     while (arg-- > 0)
 866                         *t++ = ' ';
 867                 }
 868                 s = t - 3;
 869                 if (strnEQ(s,"   ",3)) {
 870                     while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
 871                         s--;
 872                 }
 873                 *s++ = '.';
 874                 *s++ = '.';
 875                 *s++ = '.';
 876             }
 877             break;
 878
 879         case FF_END:
 880             *t = '\0';
 881             SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 882             if (targ_is_utf8)
 883                 SvUTF8_on(PL_formtarget);
 884             FmLINES(PL_formtarget) += lines;
 885             SP = ORIGMARK;
 886             RETPUSHYES;
 887         }
 888     }
 889 }
 890
 891 PP(pp_grepstart)
 892 {
 893     dSP;
 894     SV *src;
 895
 896     if (PL_stack_base + *PL_markstack_ptr == SP) {
 897         (void)POPMARK;
 898         if (GIMME_V == G_SCALAR)
 899             XPUSHs(sv_2mortal(newSViv(0)));
 900         RETURNOP(PL_op->op_next->op_next);
 901     }
 902     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 903     pp_pushmark();                              /* push dst */
 904     pp_pushmark();                              /* push src */
 905     ENTER;                                      /* enter outer scope */
 906
 907     SAVETMPS;
 908     if (PL_op->op_private & OPpGREP_LEX)
 909         SAVESPTR(PAD_SVl(PL_op->op_targ));
 910     else
 911         SAVE_DEFSV;
 912     ENTER;                                      /* enter inner scope */
 913     SAVEVPTR(PL_curpm);
 914
 915     src = PL_stack_base[*PL_markstack_ptr];
 916     SvTEMP_off(src);
 917     if (PL_op->op_private & OPpGREP_LEX)
 918         PAD_SVl(PL_op->op_targ) = src;
 919     else
 920         DEFSV = src;
 921
 922     PUTBACK;
 923     if (PL_op->op_type == OP_MAPSTART)
 924         pp_pushmark();                  /* push top */
 925     return ((LOGOP*)PL_op->op_next)->op_other;
 926 }
 927
 928 PP(pp_mapstart)
 929 {
 930     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 931 }
 932
 933 PP(pp_mapwhile)
 934 {
 935     dSP;
 936     I32 gimme = GIMME_V;
 937     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 938     I32 count;
 939     I32 shift;
 940     SV** src;
 941     SV** dst;
 942
 943     /* first, move source pointer to the next item in the source list */
 944     ++PL_markstack_ptr[-1];
 945
 946     /* if there are new items, push them into the destination list */
 947     if (items && gimme != G_VOID) {
 948         /* might need to make room back there first */
 949         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 950             /* XXX this implementation is very pessimal because the stack
 951              * is repeatedly extended for every set of items.  Is possible
 952              * to do this without any stack extension or copying at all
 953              * by maintaining a separate list over which the map iterates
 954              * (like foreach does). --gsar */
 955
 956             /* everything in the stack after the destination list moves
 957              * towards the end the stack by the amount of room needed */
 958             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 959
 960             /* items to shift up (accounting for the moved source pointer) */
 961             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 962
 963             /* This optimization is by Ben Tilly and it does
 964              * things differently from what Sarathy (gsar)
 965              * is describing.  The downside of this optimization is
 966              * that leaves "holes" (uninitialized and hopefully unused areas)
 967              * to the Perl stack, but on the other hand this
 968              * shouldn't be a problem.  If Sarathy's idea gets
 969              * implemented, this optimization should become
 970              * irrelevant.  --jhi */
 971             if (shift < count)
 972                 shift = count; /* Avoid shifting too often --Ben Tilly */
 973
 974             EXTEND(SP,shift);
 975             src = SP;
 976             dst = (SP += shift);
 977             PL_markstack_ptr[-1] += shift;
 978             *PL_markstack_ptr += shift;
 979             while (count--)
 980                 *dst-- = *src--;
 981         }
 982         /* copy the new items down to the destination list */
 983         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 984         if (gimme == G_ARRAY) {
 985             while (items-- > 0)
 986                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 987         }
 988         else {
 989             /* scalar context: we don't care about which values map returns
 990              * (we use undef here). And so we certainly don't want to do mortal
 991              * copies of meaningless values. */
 992             while (items-- > 0) {
 993                 (void)POPs;
 994                 *dst-- = &PL_sv_undef;
 995             }
 996         }
 997     }
 998     LEAVE;                                      /* exit inner scope */
 999
1000     /* All done yet? */
1001     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1002
1003         (void)POPMARK;                          /* pop top */
1004         LEAVE;                                  /* exit outer scope */
1005         (void)POPMARK;                          /* pop src */
1006         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1007         (void)POPMARK;                          /* pop dst */
1008         SP = PL_stack_base + POPMARK;           /* pop original mark */
1009         if (gimme == G_SCALAR) {
1010             if (PL_op->op_private & OPpGREP_LEX) {
1011                 SV* sv = sv_newmortal();
1012                 sv_setiv(sv, items);
1013                 PUSHs(sv);
1014             }
1015             else {
1016                 dTARGET;
1017                 XPUSHi(items);
1018             }
1019         }
1020         else if (gimme == G_ARRAY)
1021             SP += items;
1022         RETURN;
1023     }
1024     else {
1025         SV *src;
1026
1027         ENTER;                                  /* enter inner scope */
1028         SAVEVPTR(PL_curpm);
1029
1030         /* set $_ to the new source item */
1031         src = PL_stack_base[PL_markstack_ptr[-1]];
1032         SvTEMP_off(src);
1033         if (PL_op->op_private & OPpGREP_LEX)
1034             PAD_SVl(PL_op->op_targ) = src;
1035         else
1036             DEFSV = src;
1037
1038         RETURNOP(cLOGOP->op_other);
1039     }
1040 }
1041
1042 /* Range stuff. */
1043
1044 PP(pp_range)
1045 {
1046     if (GIMME == G_ARRAY)
1047         return NORMAL;
1048     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1049         return cLOGOP->op_other;
1050     else
1051         return NORMAL;
1052 }
1053
1054 PP(pp_flip)
1055 {
1056     dSP;
1057
1058     if (GIMME == G_ARRAY) {
1059         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1060     }
1061     else {
1062         dTOPss;
1063         SV *targ = PAD_SV(PL_op->op_targ);
1064         int flip = 0;
1065
1066         if (PL_op->op_private & OPpFLIP_LINENUM) {
1067             if (GvIO(PL_last_in_gv)) {
1068                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1069             }
1070             else {
1071                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1072                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1073             }
1074         } else {
1075             flip = SvTRUE(sv);
1076         }
1077         if (flip) {
1078             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1079             if (PL_op->op_flags & OPf_SPECIAL) {
1080                 sv_setiv(targ, 1);
1081                 SETs(targ);
1082                 RETURN;
1083             }
1084             else {
1085                 sv_setiv(targ, 0);
1086                 SP--;
1087                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1088             }
1089         }
1090         sv_setpv(TARG, "");
1091         SETs(targ);
1092         RETURN;
1093     }
1094 }
1095
1096 /* This code tries to decide if "$left .. $right" should use the
1097    magical string increment, or if the range is numeric (we make
1098    an exception for .."0" [#18165]). AMS 20021031. */
1099
1100 #define RANGE_IS_NUMERIC(left,right) ( \
1101         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1102         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1103         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1104           looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1105          && (!SvOK(right) || looks_like_number(right))))
1106
1107 PP(pp_flop)
1108 {
1109     dSP;
1110
1111     if (GIMME == G_ARRAY) {
1112         dPOPPOPssrl;
1113         register IV i, j;
1114         register SV *sv;
1115         IV max;
1116
1117         if (SvGMAGICAL(left))
1118             mg_get(left);
1119         if (SvGMAGICAL(right))
1120             mg_get(right);
1121
1122         if (RANGE_IS_NUMERIC(left,right)) {
1123             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1124                 (SvOK(right) && SvNV(right) > IV_MAX))
1125                 DIE(aTHX_ "Range iterator outside integer range");
1126             i = SvIV(left);
1127             max = SvIV(right);
1128             if (max >= i) {
1129                 j = max - i + 1;
1130                 EXTEND_MORTAL(j);
1131                 EXTEND(SP, j);
1132             }
1133             else
1134                 j = 0;
1135             while (j--) {
1136                 sv = sv_2mortal(newSViv(i++));
1137                 PUSHs(sv);
1138             }
1139         }
1140         else {
1141             SV *final = sv_mortalcopy(right);
1142             STRLEN len, n_a;
1143             char *tmps = SvPV(final, len);
1144
1145             sv = sv_mortalcopy(left);
1146             SvPV_force(sv,n_a);
1147             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1148                 XPUSHs(sv);
1149                 if (strEQ(SvPVX(sv),tmps))
1150                     break;
1151                 sv = sv_2mortal(newSVsv(sv));
1152                 sv_inc(sv);
1153             }
1154         }
1155     }
1156     else {
1157         dTOPss;
1158         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1159         int flop = 0;
1160         sv_inc(targ);
1161
1162         if (PL_op->op_private & OPpFLIP_LINENUM) {
1163             if (GvIO(PL_last_in_gv)) {
1164                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1165             }
1166             else {
1167                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1168                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1169             }
1170         }
1171         else {
1172             flop = SvTRUE(sv);
1173         }
1174
1175         if (flop) {
1176             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1177             sv_catpv(targ, "E0");
1178         }
1179         SETs(targ);
1180     }
1181
1182     RETURN;
1183 }
1184
1185 /* Control. */
1186
1187 static const char *context_name[] = {
1188     "pseudo-block",
1189     "subroutine",
1190     "eval",
1191     "loop",
1192     "substitution",
1193     "block",
1194     "format"
1195 };
1196
1197 STATIC I32
1198 S_dopoptolabel(pTHX_ const char *label)
1199 {
1200     register I32 i;
1201
1202     for (i = cxstack_ix; i >= 0; i--) {
1203         register const PERL_CONTEXT *cx = &cxstack[i];
1204         switch (CxTYPE(cx)) {
1205         case CXt_SUBST:
1206         case CXt_SUB:
1207         case CXt_FORMAT:
1208         case CXt_EVAL:
1209         case CXt_NULL:
1210             if (ckWARN(WARN_EXITING))
1211                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1212                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1213             if (CxTYPE(cx) == CXt_NULL)
1214                 return -1;
1215             break;
1216         case CXt_LOOP:
1217             if (!cx->blk_loop.label ||
1218               strNE(label, cx->blk_loop.label) ) {
1219                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1220                         (long)i, cx->blk_loop.label));
1221                 continue;
1222             }
1223             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1224             return i;
1225         }
1226     }
1227     return i;
1228 }
1229
1230 I32
1231 Perl_dowantarray(pTHX)
1232 {
1233     I32 gimme = block_gimme();
1234     return (gimme == G_VOID) ? G_SCALAR : gimme;
1235 }
1236
1237 I32
1238 Perl_block_gimme(pTHX)
1239 {
1240     const I32 cxix = dopoptosub(cxstack_ix);
1241     if (cxix < 0)
1242         return G_VOID;
1243
1244     switch (cxstack[cxix].blk_gimme) {
1245     case G_VOID:
1246         return G_VOID;
1247     case G_SCALAR:
1248         return G_SCALAR;
1249     case G_ARRAY:
1250         return G_ARRAY;
1251     default:
1252         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1253         /* NOTREACHED */
1254         return 0;
1255     }
1256 }
1257
1258 I32
1259 Perl_is_lvalue_sub(pTHX)
1260 {
1261     const I32 cxix = dopoptosub(cxstack_ix);
1262     assert(cxix >= 0);  /* We should only be called from inside subs */
1263
1264     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1265         return cxstack[cxix].blk_sub.lval;
1266     else
1267         return 0;
1268 }
1269
1270 STATIC I32
1271 S_dopoptosub(pTHX_ I32 startingblock)
1272 {
1273     return dopoptosub_at(cxstack, startingblock);
1274 }
1275
1276 STATIC I32
1277 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1278 {
1279     I32 i;
1280     for (i = startingblock; i >= 0; i--) {
1281         register const PERL_CONTEXT *cx = &cxstk[i];
1282         switch (CxTYPE(cx)) {
1283         default:
1284             continue;
1285         case CXt_EVAL:
1286         case CXt_SUB:
1287         case CXt_FORMAT:
1288             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1289             return i;
1290         }
1291     }
1292     return i;
1293 }
1294
1295 STATIC I32
1296 S_dopoptoeval(pTHX_ I32 startingblock)
1297 {
1298     I32 i;
1299     for (i = startingblock; i >= 0; i--) {
1300         register const PERL_CONTEXT *cx = &cxstack[i];
1301         switch (CxTYPE(cx)) {
1302         default:
1303             continue;
1304         case CXt_EVAL:
1305             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1306             return i;
1307         }
1308     }
1309     return i;
1310 }
1311
1312 STATIC I32
1313 S_dopoptoloop(pTHX_ I32 startingblock)
1314 {
1315     I32 i;
1316     for (i = startingblock; i >= 0; i--) {
1317         register const PERL_CONTEXT *cx = &cxstack[i];
1318         switch (CxTYPE(cx)) {
1319         case CXt_SUBST:
1320         case CXt_SUB:
1321         case CXt_FORMAT:
1322         case CXt_EVAL:
1323         case CXt_NULL:
1324             if (ckWARN(WARN_EXITING))
1325                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1326                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1327             if ((CxTYPE(cx)) == CXt_NULL)
1328                 return -1;
1329             break;
1330         case CXt_LOOP:
1331             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1332             return i;
1333         }
1334     }
1335     return i;
1336 }
1337
1338 void
1339 Perl_dounwind(pTHX_ I32 cxix)
1340 {
1341     I32 optype;
1342
1343     while (cxstack_ix > cxix) {
1344         SV *sv;
1345         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1346         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1347                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1348         /* Note: we don't need to restore the base context info till the end. */
1349         switch (CxTYPE(cx)) {
1350         case CXt_SUBST:
1351             POPSUBST(cx);
1352             continue;  /* not break */
1353         case CXt_SUB:
1354             POPSUB(cx,sv);
1355             LEAVESUB(sv);
1356             break;
1357         case CXt_EVAL:
1358             POPEVAL(cx);
1359             break;
1360         case CXt_LOOP:
1361             POPLOOP(cx);
1362             break;
1363         case CXt_NULL:
1364             break;
1365         case CXt_FORMAT:
1366             POPFORMAT(cx);
1367             break;
1368         }
1369         cxstack_ix--;
1370     }
1371 }
1372
1373 void
1374 Perl_qerror(pTHX_ SV *err)
1375 {
1376     if (PL_in_eval)
1377         sv_catsv(ERRSV, err);
1378     else if (PL_errors)
1379         sv_catsv(PL_errors, err);
1380     else
1381         Perl_warn(aTHX_ "%"SVf, err);
1382     ++PL_error_count;
1383 }
1384
1385 OP *
1386 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1387 {
1388     STRLEN n_a;
1389
1390     if (PL_in_eval) {
1391         I32 cxix;
1392         I32 gimme;
1393         SV **newsp;
1394
1395         if (message) {
1396             if (PL_in_eval & EVAL_KEEPERR) {
1397                 static const char prefix[] = "\t(in cleanup) ";
1398                 SV *err = ERRSV;
1399                 const char *e = Nullch;
1400                 if (!SvPOK(err))
1401                     sv_setpv(err,"");
1402                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1403                     e = SvPV(err, n_a);
1404                     e += n_a - msglen;
1405                     if (*e != *message || strNE(e,message))
1406                         e = Nullch;
1407                 }
1408                 if (!e) {
1409                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1410                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1411                     sv_catpvn(err, message, msglen);
1412                     if (ckWARN(WARN_MISC)) {
1413                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1414                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1415                     }
1416                 }
1417             }
1418             else {
1419                 sv_setpvn(ERRSV, message, msglen);
1420             }
1421         }
1422
1423         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1424                && PL_curstackinfo->si_prev)
1425         {
1426             dounwind(-1);
1427             POPSTACK;
1428         }
1429
1430         if (cxix >= 0) {
1431             I32 optype;
1432             register PERL_CONTEXT *cx;
1433
1434             if (cxix < cxstack_ix)
1435                 dounwind(cxix);
1436
1437             POPBLOCK(cx,PL_curpm);
1438             if (CxTYPE(cx) != CXt_EVAL) {
1439                 if (!message)
1440                     message = SvPVx(ERRSV, msglen);
1441                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1442                 PerlIO_write(Perl_error_log, message, msglen);
1443                 my_exit(1);
1444             }
1445             POPEVAL(cx);
1446
1447             if (gimme == G_SCALAR)
1448                 *++newsp = &PL_sv_undef;
1449             PL_stack_sp = newsp;
1450
1451             LEAVE;
1452
1453             /* LEAVE could clobber PL_curcop (see save_re_context())
1454              * XXX it might be better to find a way to avoid messing with
1455              * PL_curcop in save_re_context() instead, but this is a more
1456              * minimal fix --GSAR */
1457             PL_curcop = cx->blk_oldcop;
1458
1459             if (optype == OP_REQUIRE) {
1460                 const char* msg = SvPVx(ERRSV, n_a);
1461                 SV *nsv = cx->blk_eval.old_namesv;
1462                 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1463                                &PL_sv_undef, 0);
1464                 DIE(aTHX_ "%sCompilation failed in require",
1465                     *msg ? msg : "Unknown error\n");
1466             }
1467             assert(CxTYPE(cx) == CXt_EVAL);
1468             return cx->blk_eval.retop;
1469         }
1470     }
1471     if (!message)
1472         message = SvPVx(ERRSV, msglen);
1473
1474     write_to_stderr(message, msglen);
1475     my_failure_exit();
1476     /* NOTREACHED */
1477     return 0;
1478 }
1479
1480 PP(pp_xor)
1481 {
1482     dSP; dPOPTOPssrl;
1483     if (SvTRUE(left) != SvTRUE(right))
1484         RETSETYES;
1485     else
1486         RETSETNO;
1487 }
1488
1489 PP(pp_andassign)
1490 {
1491     dSP;
1492     if (!SvTRUE(TOPs))
1493         RETURN;
1494     else
1495         RETURNOP(cLOGOP->op_other);
1496 }
1497
1498 PP(pp_orassign)
1499 {
1500     dSP;
1501     if (SvTRUE(TOPs))
1502         RETURN;
1503     else
1504         RETURNOP(cLOGOP->op_other);
1505 }
1506
1507 PP(pp_dorassign)
1508 {
1509     dSP;
1510     register SV* sv;
1511
1512     sv = TOPs;
1513     if (!sv || !SvANY(sv)) {
1514         RETURNOP(cLOGOP->op_other);
1515     }
1516
1517     switch (SvTYPE(sv)) {
1518     case SVt_PVAV:
1519         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1520             RETURN;
1521         break;
1522     case SVt_PVHV:
1523         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1524             RETURN;
1525         break;
1526     case SVt_PVCV:
1527         if (CvROOT(sv) || CvXSUB(sv))
1528             RETURN;
1529         break;
1530     default:
1531         if (SvGMAGICAL(sv))
1532             mg_get(sv);
1533         if (SvOK(sv))
1534             RETURN;
1535     }
1536
1537     RETURNOP(cLOGOP->op_other);
1538 }
1539
1540 PP(pp_caller)
1541 {
1542     dSP;
1543     register I32 cxix = dopoptosub(cxstack_ix);
1544     register PERL_CONTEXT *cx;
1545     register PERL_CONTEXT *ccstack = cxstack;
1546     PERL_SI *top_si = PL_curstackinfo;
1547     I32 dbcxix;
1548     I32 gimme;
1549     const char *stashname;
1550     SV *sv;
1551     I32 count = 0;
1552
1553     if (MAXARG)
1554         count = POPi;
1555
1556     for (;;) {
1557         /* we may be in a higher stacklevel, so dig down deeper */
1558         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1559             top_si = top_si->si_prev;
1560             ccstack = top_si->si_cxstack;
1561             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1562         }
1563         if (cxix < 0) {
1564             if (GIMME != G_ARRAY) {
1565                 EXTEND(SP, 1);
1566                 RETPUSHUNDEF;
1567             }
1568             RETURN;
1569         }
1570         if (PL_DBsub && cxix >= 0 &&
1571                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1572             count++;
1573         if (!count--)
1574             break;
1575         cxix = dopoptosub_at(ccstack, cxix - 1);
1576     }
1577
1578     cx = &ccstack[cxix];
1579     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1580         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1581         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1582            field below is defined for any cx. */
1583         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1584             cx = &ccstack[dbcxix];
1585     }
1586
1587     stashname = CopSTASHPV(cx->blk_oldcop);
1588     if (GIMME != G_ARRAY) {
1589         EXTEND(SP, 1);
1590         if (!stashname)
1591             PUSHs(&PL_sv_undef);
1592         else {
1593             dTARGET;
1594             sv_setpv(TARG, stashname);
1595             PUSHs(TARG);
1596         }
1597         RETURN;
1598     }
1599
1600     EXTEND(SP, 10);
1601
1602     if (!stashname)
1603         PUSHs(&PL_sv_undef);
1604     else
1605         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1606     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1607     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1608     if (!MAXARG)
1609         RETURN;
1610     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1611         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1612         /* So is ccstack[dbcxix]. */
1613         if (isGV(cvgv)) {
1614             sv = NEWSV(49, 0);
1615             gv_efullname3(sv, cvgv, Nullch);
1616             PUSHs(sv_2mortal(sv));
1617             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1618         }
1619         else {
1620             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1621             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1622         }
1623     }
1624     else {
1625         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1626         PUSHs(sv_2mortal(newSViv(0)));
1627     }
1628     gimme = (I32)cx->blk_gimme;
1629     if (gimme == G_VOID)
1630         PUSHs(&PL_sv_undef);
1631     else
1632         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1633     if (CxTYPE(cx) == CXt_EVAL) {
1634         /* eval STRING */
1635         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1636             PUSHs(cx->blk_eval.cur_text);
1637             PUSHs(&PL_sv_no);
1638         }
1639         /* require */
1640         else if (cx->blk_eval.old_namesv) {
1641             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1642             PUSHs(&PL_sv_yes);
1643         }
1644         /* eval BLOCK (try blocks have old_namesv == 0) */
1645         else {
1646             PUSHs(&PL_sv_undef);
1647             PUSHs(&PL_sv_undef);
1648         }
1649     }
1650     else {
1651         PUSHs(&PL_sv_undef);
1652         PUSHs(&PL_sv_undef);
1653     }
1654     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1655         && CopSTASH_eq(PL_curcop, PL_debstash))
1656     {
1657         AV *ary = cx->blk_sub.argarray;
1658         const int off = AvARRAY(ary) - AvALLOC(ary);
1659
1660         if (!PL_dbargs) {
1661             GV* tmpgv;
1662             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1663                                 SVt_PVAV)));
1664             GvMULTI_on(tmpgv);
1665             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1666         }
1667
1668         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1669             av_extend(PL_dbargs, AvFILLp(ary) + off);
1670         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1671         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1672     }
1673     /* XXX only hints propagated via op_private are currently
1674      * visible (others are not easily accessible, since they
1675      * use the global PL_hints) */
1676     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1677                              HINT_PRIVATE_MASK)));
1678     {
1679         SV * mask ;
1680         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1681
1682         if  (old_warnings == pWARN_NONE ||
1683                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1684             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1685         else if (old_warnings == pWARN_ALL ||
1686                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1687             /* Get the bit mask for $warnings::Bits{all}, because
1688              * it could have been extended by warnings::register */
1689             SV **bits_all;
1690             HV *bits = get_hv("warnings::Bits", FALSE);
1691             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1692                 mask = newSVsv(*bits_all);
1693             }
1694             else {
1695                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1696             }
1697         }
1698         else
1699             mask = newSVsv(old_warnings);
1700         PUSHs(sv_2mortal(mask));
1701     }
1702     RETURN;
1703 }
1704
1705 PP(pp_reset)
1706 {
1707     dSP;
1708     const char *tmps;
1709     STRLEN n_a;
1710
1711     if (MAXARG < 1)
1712         tmps = "";
1713     else
1714         tmps = POPpx;
1715     sv_reset(tmps, CopSTASH(PL_curcop));
1716     PUSHs(&PL_sv_yes);
1717     RETURN;
1718 }
1719
1720 PP(pp_lineseq)
1721 {
1722     return NORMAL;
1723 }
1724
1725 /* like pp_nextstate, but used instead when the debugger is active */
1726
1727 PP(pp_dbstate)
1728 {
1729     PL_curcop = (COP*)PL_op;
1730     TAINT_NOT;          /* Each statement is presumed innocent */
1731     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1732     FREETMPS;
1733
1734     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1735             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1736     {
1737         dSP;
1738         register CV *cv;
1739         register PERL_CONTEXT *cx;
1740         I32 gimme = G_ARRAY;
1741         U8 hasargs;
1742         GV *gv;
1743
1744         gv = PL_DBgv;
1745         cv = GvCV(gv);
1746         if (!cv)
1747             DIE(aTHX_ "No DB::DB routine defined");
1748
1749         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1750             /* don't do recursive DB::DB call */
1751             return NORMAL;
1752
1753         ENTER;
1754         SAVETMPS;
1755
1756         SAVEI32(PL_debug);
1757         SAVESTACK_POS();
1758         PL_debug = 0;
1759         hasargs = 0;
1760         SPAGAIN;
1761
1762         PUSHBLOCK(cx, CXt_SUB, SP);
1763         PUSHSUB_DB(cx);
1764         cx->blk_sub.retop = PL_op->op_next;
1765         CvDEPTH(cv)++;
1766         PAD_SET_CUR(CvPADLIST(cv),1);
1767         RETURNOP(CvSTART(cv));
1768     }
1769     else
1770         return NORMAL;
1771 }
1772
1773 PP(pp_scope)
1774 {
1775     return NORMAL;
1776 }
1777
1778 PP(pp_enteriter)
1779 {
1780     dSP; dMARK;
1781     register PERL_CONTEXT *cx;
1782     I32 gimme = GIMME_V;
1783     SV **svp;
1784     U32 cxtype = CXt_LOOP;
1785 #ifdef USE_ITHREADS
1786     void *iterdata;
1787 #endif
1788
1789     ENTER;
1790     SAVETMPS;
1791
1792     if (PL_op->op_targ) {
1793         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1794             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1795             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1796                     SVs_PADSTALE, SVs_PADSTALE);
1797         }
1798 #ifndef USE_ITHREADS
1799         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1800         SAVESPTR(*svp);
1801 #else
1802         SAVEPADSV(PL_op->op_targ);
1803         iterdata = INT2PTR(void*, PL_op->op_targ);
1804         cxtype |= CXp_PADVAR;
1805 #endif
1806     }
1807     else {
1808         GV *gv = (GV*)POPs;
1809         svp = &GvSV(gv);                        /* symbol table variable */
1810         SAVEGENERICSV(*svp);
1811         *svp = NEWSV(0,0);
1812 #ifdef USE_ITHREADS
1813         iterdata = (void*)gv;
1814 #endif
1815     }
1816
1817     ENTER;
1818
1819     PUSHBLOCK(cx, cxtype, SP);
1820 #ifdef USE_ITHREADS
1821     PUSHLOOP(cx, iterdata, MARK);
1822 #else
1823     PUSHLOOP(cx, svp, MARK);
1824 #endif
1825     if (PL_op->op_flags & OPf_STACKED) {
1826         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1827         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1828             dPOPss;
1829             SV *right = (SV*)cx->blk_loop.iterary;
1830             if (RANGE_IS_NUMERIC(sv,right)) {
1831                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1832                     (SvOK(right) && SvNV(right) >= IV_MAX))
1833                     DIE(aTHX_ "Range iterator outside integer range");
1834                 cx->blk_loop.iterix = SvIV(sv);
1835                 cx->blk_loop.itermax = SvIV(right);
1836             }
1837             else {
1838                 STRLEN n_a;
1839                 cx->blk_loop.iterlval = newSVsv(sv);
1840                 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1841                 (void) SvPV(right,n_a);
1842             }
1843         }
1844         else if (PL_op->op_private & OPpITER_REVERSED) {
1845             cx->blk_loop.itermax = -1;
1846             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1847
1848         }
1849     }
1850     else {
1851         cx->blk_loop.iterary = PL_curstack;
1852         AvFILLp(PL_curstack) = SP - PL_stack_base;
1853         if (PL_op->op_private & OPpITER_REVERSED) {
1854             cx->blk_loop.itermax = MARK - PL_stack_base;
1855             cx->blk_loop.iterix = cx->blk_oldsp;
1856         }
1857         else {
1858             cx->blk_loop.iterix = MARK - PL_stack_base;
1859         }
1860     }
1861
1862     RETURN;
1863 }
1864
1865 PP(pp_enterloop)
1866 {
1867     dSP;
1868     register PERL_CONTEXT *cx;
1869     I32 gimme = GIMME_V;
1870
1871     ENTER;
1872     SAVETMPS;
1873     ENTER;
1874
1875     PUSHBLOCK(cx, CXt_LOOP, SP);
1876     PUSHLOOP(cx, 0, SP);
1877
1878     RETURN;
1879 }
1880
1881 PP(pp_leaveloop)
1882 {
1883     dSP;
1884     register PERL_CONTEXT *cx;
1885     I32 gimme;
1886     SV **newsp;
1887     PMOP *newpm;
1888     SV **mark;
1889
1890     POPBLOCK(cx,newpm);
1891     mark = newsp;
1892     newsp = PL_stack_base + cx->blk_loop.resetsp;
1893
1894     TAINT_NOT;
1895     if (gimme == G_VOID)
1896         ; /* do nothing */
1897     else if (gimme == G_SCALAR) {
1898         if (mark < SP)
1899             *++newsp = sv_mortalcopy(*SP);
1900         else
1901             *++newsp = &PL_sv_undef;
1902     }
1903     else {
1904         while (mark < SP) {
1905             *++newsp = sv_mortalcopy(*++mark);
1906             TAINT_NOT;          /* Each item is independent */
1907         }
1908     }
1909     SP = newsp;
1910     PUTBACK;
1911
1912     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1913     PL_curpm = newpm;   /* ... and pop $1 et al */
1914
1915     LEAVE;
1916     LEAVE;
1917
1918     return NORMAL;
1919 }
1920
1921 PP(pp_return)
1922 {
1923     dSP; dMARK;
1924     I32 cxix;
1925     register PERL_CONTEXT *cx;
1926     bool popsub2 = FALSE;
1927     bool clear_errsv = FALSE;
1928     I32 gimme;
1929     SV **newsp;
1930     PMOP *newpm;
1931     I32 optype = 0;
1932     SV *sv;
1933     OP *retop;
1934
1935     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1936         if (cxstack_ix == PL_sortcxix
1937             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1938         {
1939             if (cxstack_ix > PL_sortcxix)
1940                 dounwind(PL_sortcxix);
1941             AvARRAY(PL_curstack)[1] = *SP;
1942             PL_stack_sp = PL_stack_base + 1;
1943             return 0;
1944         }
1945     }
1946
1947     cxix = dopoptosub(cxstack_ix);
1948     if (cxix < 0)
1949         DIE(aTHX_ "Can't return outside a subroutine");
1950     if (cxix < cxstack_ix)
1951         dounwind(cxix);
1952
1953     POPBLOCK(cx,newpm);
1954     switch (CxTYPE(cx)) {
1955     case CXt_SUB:
1956         popsub2 = TRUE;
1957         retop = cx->blk_sub.retop;
1958         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1959         break;
1960     case CXt_EVAL:
1961         if (!(PL_in_eval & EVAL_KEEPERR))
1962             clear_errsv = TRUE;
1963         POPEVAL(cx);
1964         retop = cx->blk_eval.retop;
1965         if (CxTRYBLOCK(cx))
1966             break;
1967         lex_end();
1968         if (optype == OP_REQUIRE &&
1969             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1970         {
1971             /* Unassume the success we assumed earlier. */
1972             SV *nsv = cx->blk_eval.old_namesv;
1973             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1974             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1975         }
1976         break;
1977     case CXt_FORMAT:
1978         POPFORMAT(cx);
1979         retop = cx->blk_sub.retop;
1980         break;
1981     default:
1982         DIE(aTHX_ "panic: return");
1983     }
1984
1985     TAINT_NOT;
1986     if (gimme == G_SCALAR) {
1987         if (MARK < SP) {
1988             if (popsub2) {
1989                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1990                     if (SvTEMP(TOPs)) {
1991                         *++newsp = SvREFCNT_inc(*SP);
1992                         FREETMPS;
1993                         sv_2mortal(*newsp);
1994                     }
1995                     else {
1996                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1997                         FREETMPS;
1998                         *++newsp = sv_mortalcopy(sv);
1999                         SvREFCNT_dec(sv);
2000                     }
2001                 }
2002                 else
2003                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2004             }
2005             else
2006                 *++newsp = sv_mortalcopy(*SP);
2007         }
2008         else
2009             *++newsp = &PL_sv_undef;
2010     }
2011     else if (gimme == G_ARRAY) {
2012         while (++MARK <= SP) {
2013             *++newsp = (popsub2 && SvTEMP(*MARK))
2014                         ? *MARK : sv_mortalcopy(*MARK);
2015             TAINT_NOT;          /* Each item is independent */
2016         }
2017     }
2018     PL_stack_sp = newsp;
2019
2020     LEAVE;
2021     /* Stack values are safe: */
2022     if (popsub2) {
2023         cxstack_ix--;
2024         POPSUB(cx,sv);  /* release CV and @_ ... */
2025     }
2026     else
2027         sv = Nullsv;
2028     PL_curpm = newpm;   /* ... and pop $1 et al */
2029
2030     LEAVESUB(sv);
2031     if (clear_errsv)
2032         sv_setpv(ERRSV,"");
2033     return retop;
2034 }
2035
2036 PP(pp_last)
2037 {
2038     dSP;
2039     I32 cxix;
2040     register PERL_CONTEXT *cx;
2041     I32 pop2 = 0;
2042     I32 gimme;
2043     I32 optype;
2044     OP *nextop;
2045     SV **newsp;
2046     PMOP *newpm;
2047     SV **mark;
2048     SV *sv = Nullsv;
2049
2050     if (PL_op->op_flags & OPf_SPECIAL) {
2051         cxix = dopoptoloop(cxstack_ix);
2052         if (cxix < 0)
2053             DIE(aTHX_ "Can't \"last\" outside a loop block");
2054     }
2055     else {
2056         cxix = dopoptolabel(cPVOP->op_pv);
2057         if (cxix < 0)
2058             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2059     }
2060     if (cxix < cxstack_ix)
2061         dounwind(cxix);
2062
2063     POPBLOCK(cx,newpm);
2064     cxstack_ix++; /* temporarily protect top context */
2065     mark = newsp;
2066     switch (CxTYPE(cx)) {
2067     case CXt_LOOP:
2068         pop2 = CXt_LOOP;
2069         newsp = PL_stack_base + cx->blk_loop.resetsp;
2070         nextop = cx->blk_loop.last_op->op_next;
2071         break;
2072     case CXt_SUB:
2073         pop2 = CXt_SUB;
2074         nextop = cx->blk_sub.retop;
2075         break;
2076     case CXt_EVAL:
2077         POPEVAL(cx);
2078         nextop = cx->blk_eval.retop;
2079         break;
2080     case CXt_FORMAT:
2081         POPFORMAT(cx);
2082         nextop = cx->blk_sub.retop;
2083         break;
2084     default:
2085         DIE(aTHX_ "panic: last");
2086     }
2087
2088     TAINT_NOT;
2089     if (gimme == G_SCALAR) {
2090         if (MARK < SP)
2091             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2092                         ? *SP : sv_mortalcopy(*SP);
2093         else
2094             *++newsp = &PL_sv_undef;
2095     }
2096     else if (gimme == G_ARRAY) {
2097         while (++MARK <= SP) {
2098             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2099                         ? *MARK : sv_mortalcopy(*MARK);
2100             TAINT_NOT;          /* Each item is independent */
2101         }
2102     }
2103     SP = newsp;
2104     PUTBACK;
2105
2106     LEAVE;
2107     cxstack_ix--;
2108     /* Stack values are safe: */
2109     switch (pop2) {
2110     case CXt_LOOP:
2111         POPLOOP(cx);    /* release loop vars ... */
2112         LEAVE;
2113         break;
2114     case CXt_SUB:
2115         POPSUB(cx,sv);  /* release CV and @_ ... */
2116         break;
2117     }
2118     PL_curpm = newpm;   /* ... and pop $1 et al */
2119
2120     LEAVESUB(sv);
2121     return nextop;
2122 }
2123
2124 PP(pp_next)
2125 {
2126     I32 cxix;
2127     register PERL_CONTEXT *cx;
2128     I32 inner;
2129
2130     if (PL_op->op_flags & OPf_SPECIAL) {
2131         cxix = dopoptoloop(cxstack_ix);
2132         if (cxix < 0)
2133             DIE(aTHX_ "Can't \"next\" outside a loop block");
2134     }
2135     else {
2136         cxix = dopoptolabel(cPVOP->op_pv);
2137         if (cxix < 0)
2138             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2139     }
2140     if (cxix < cxstack_ix)
2141         dounwind(cxix);
2142
2143     /* clear off anything above the scope we're re-entering, but
2144      * save the rest until after a possible continue block */
2145     inner = PL_scopestack_ix;
2146     TOPBLOCK(cx);
2147     if (PL_scopestack_ix < inner)
2148         leave_scope(PL_scopestack[PL_scopestack_ix]);
2149     return cx->blk_loop.next_op;
2150 }
2151
2152 PP(pp_redo)
2153 {
2154     I32 cxix;
2155     register PERL_CONTEXT *cx;
2156     I32 oldsave;
2157
2158     if (PL_op->op_flags & OPf_SPECIAL) {
2159         cxix = dopoptoloop(cxstack_ix);
2160         if (cxix < 0)
2161             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2162     }
2163     else {
2164         cxix = dopoptolabel(cPVOP->op_pv);
2165         if (cxix < 0)
2166             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2167     }
2168     if (cxix < cxstack_ix)
2169         dounwind(cxix);
2170
2171     TOPBLOCK(cx);
2172     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2173     LEAVE_SCOPE(oldsave);
2174     FREETMPS;
2175     return cx->blk_loop.redo_op;
2176 }
2177
2178 STATIC OP *
2179 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2180 {
2181     OP *kid = Nullop;
2182     OP **ops = opstack;
2183     static const char too_deep[] = "Target of goto is too deeply nested";
2184
2185     if (ops >= oplimit)
2186         Perl_croak(aTHX_ too_deep);
2187     if (o->op_type == OP_LEAVE ||
2188         o->op_type == OP_SCOPE ||
2189         o->op_type == OP_LEAVELOOP ||
2190         o->op_type == OP_LEAVESUB ||
2191         o->op_type == OP_LEAVETRY)
2192     {
2193         *ops++ = cUNOPo->op_first;
2194         if (ops >= oplimit)
2195             Perl_croak(aTHX_ too_deep);
2196     }
2197     *ops = 0;
2198     if (o->op_flags & OPf_KIDS) {
2199         /* First try all the kids at this level, since that's likeliest. */
2200         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2201             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2202                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2203                 return kid;
2204         }
2205         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2206             if (kid == PL_lastgotoprobe)
2207                 continue;
2208             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2209                 if (ops == opstack)
2210                     *ops++ = kid;
2211                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2212                          ops[-1]->op_type == OP_DBSTATE)
2213                     ops[-1] = kid;
2214                 else
2215                     *ops++ = kid;
2216             }
2217             if ((o = dofindlabel(kid, label, ops, oplimit)))
2218                 return o;
2219         }
2220     }
2221     *ops = 0;
2222     return 0;
2223 }
2224
2225 PP(pp_dump)
2226 {
2227     return pp_goto();
2228     /*NOTREACHED*/
2229 }
2230
2231 PP(pp_goto)
2232 {
2233     dSP;
2234     OP *retop = 0;
2235     I32 ix;
2236     register PERL_CONTEXT *cx;
2237 #define GOTO_DEPTH 64
2238     OP *enterops[GOTO_DEPTH];
2239     const char *label = 0;
2240     const bool do_dump = (PL_op->op_type == OP_DUMP);
2241     static const char must_have_label[] = "goto must have label";
2242
2243     if (PL_op->op_flags & OPf_STACKED) {
2244         SV *sv = POPs;
2245         STRLEN n_a;
2246
2247         /* This egregious kludge implements goto &subroutine */
2248         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2249             I32 cxix;
2250             register PERL_CONTEXT *cx;
2251             CV* cv = (CV*)SvRV(sv);
2252             SV** mark;
2253             I32 items = 0;
2254             I32 oldsave;
2255             bool reified = 0;
2256
2257         retry:
2258             if (!CvROOT(cv) && !CvXSUB(cv)) {
2259                 const GV * const gv = CvGV(cv);
2260                 if (gv) {
2261                     GV *autogv;
2262                     SV *tmpstr;
2263                     /* autoloaded stub? */
2264                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2265                         goto retry;
2266                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2267                                           GvNAMELEN(gv), FALSE);
2268                     if (autogv && (cv = GvCV(autogv)))
2269                         goto retry;
2270                     tmpstr = sv_newmortal();
2271                     gv_efullname3(tmpstr, gv, Nullch);
2272                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2273                 }
2274                 DIE(aTHX_ "Goto undefined subroutine");
2275             }
2276
2277             /* First do some returnish stuff. */
2278             (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2279             FREETMPS;
2280             cxix = dopoptosub(cxstack_ix);
2281             if (cxix < 0)
2282                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2283             if (cxix < cxstack_ix)
2284                 dounwind(cxix);
2285             TOPBLOCK(cx);
2286             if (CxREALEVAL(cx))
2287                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2288             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2289                 /* put @_ back onto stack */
2290                 AV* av = cx->blk_sub.argarray;
2291
2292                 items = AvFILLp(av) + 1;
2293                 EXTEND(SP, items+1); /* @_ could have been extended. */
2294                 Copy(AvARRAY(av), SP + 1, items, SV*);
2295                 SvREFCNT_dec(GvAV(PL_defgv));
2296                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2297                 CLEAR_ARGARRAY(av);
2298                 /* abandon @_ if it got reified */
2299                 if (AvREAL(av)) {
2300                     reified = 1;
2301                     SvREFCNT_dec(av);
2302                     av = newAV();
2303                     av_extend(av, items-1);
2304                     AvFLAGS(av) = AVf_REIFY;
2305                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2306                 }
2307             }
2308             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2309                 AV* av;
2310                 av = GvAV(PL_defgv);
2311                 items = AvFILLp(av) + 1;
2312                 EXTEND(SP, items+1); /* @_ could have been extended. */
2313                 Copy(AvARRAY(av), SP + 1, items, SV*);
2314             }
2315             mark = SP;
2316             SP += items;
2317             if (CxTYPE(cx) == CXt_SUB &&
2318                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2319                 SvREFCNT_dec(cx->blk_sub.cv);
2320             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2321             LEAVE_SCOPE(oldsave);
2322
2323             /* Now do some callish stuff. */
2324             SAVETMPS;
2325             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2326             if (CvXSUB(cv)) {
2327                 if (reified) {
2328                     I32 index;
2329                     for (index=0; index<items; index++)
2330                         sv_2mortal(SP[-index]);
2331                 }
2332 #ifdef PERL_XSUB_OLDSTYLE
2333                 if (CvOLDSTYLE(cv)) {
2334                     I32 (*fp3)(int,int,int);
2335                     while (SP > mark) {
2336                         SP[1] = SP[0];
2337                         SP--;
2338                     }
2339                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2340                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2341                                    mark - PL_stack_base + 1,
2342                                    items);
2343                     SP = PL_stack_base + items;
2344                 }
2345                 else
2346 #endif /* PERL_XSUB_OLDSTYLE */
2347                 {
2348                     SV **newsp;
2349                     I32 gimme;
2350
2351                     /* Push a mark for the start of arglist */
2352                     PUSHMARK(mark);
2353                     PUTBACK;
2354                     (void)(*CvXSUB(cv))(aTHX_ cv);
2355                     /* Pop the current context like a decent sub should */
2356                     POPBLOCK(cx, PL_curpm);
2357                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2358                 }
2359                 LEAVE;
2360                 assert(CxTYPE(cx) == CXt_SUB);
2361                 return cx->blk_sub.retop;
2362             }
2363             else {
2364                 AV* padlist = CvPADLIST(cv);
2365                 if (CxTYPE(cx) == CXt_EVAL) {
2366                     PL_in_eval = cx->blk_eval.old_in_eval;
2367                     PL_eval_root = cx->blk_eval.old_eval_root;
2368                     cx->cx_type = CXt_SUB;
2369                     cx->blk_sub.hasargs = 0;
2370                 }
2371                 cx->blk_sub.cv = cv;
2372                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2373
2374                 CvDEPTH(cv)++;
2375                 if (CvDEPTH(cv) < 2)
2376                     (void)SvREFCNT_inc(cv);
2377                 else {
2378                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2379                         sub_crush_depth(cv);
2380                     pad_push(padlist, CvDEPTH(cv));
2381                 }
2382                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2383                 if (cx->blk_sub.hasargs)
2384                 {
2385                     AV* av = (AV*)PAD_SVl(0);
2386                     SV** ary;
2387
2388                     cx->blk_sub.savearray = GvAV(PL_defgv);
2389                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2390                     CX_CURPAD_SAVE(cx->blk_sub);
2391                     cx->blk_sub.argarray = av;
2392
2393                     if (items >= AvMAX(av) + 1) {
2394                         ary = AvALLOC(av);
2395                         if (AvARRAY(av) != ary) {
2396                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2397                             SvPV_set(av, (char*)ary);
2398                         }
2399                         if (items >= AvMAX(av) + 1) {
2400                             AvMAX(av) = items - 1;
2401                             Renew(ary,items+1,SV*);
2402                             AvALLOC(av) = ary;
2403                             SvPV_set(av, (char*)ary);
2404                         }
2405                     }
2406                     ++mark;
2407                     Copy(mark,AvARRAY(av),items,SV*);
2408                     AvFILLp(av) = items - 1;
2409                     assert(!AvREAL(av));
2410                     if (reified) {
2411                         /* transfer 'ownership' of refcnts to new @_ */
2412                         AvREAL_on(av);
2413                         AvREIFY_off(av);
2414                     }
2415                     while (items--) {
2416                         if (*mark)
2417                             SvTEMP_off(*mark);
2418                         mark++;
2419                     }
2420                 }
2421                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2422                     /*
2423                      * We do not care about using sv to call CV;
2424                      * it's for informational purposes only.
2425                      */
2426                     SV *sv = GvSV(PL_DBsub);
2427                     CV *gotocv;
2428
2429                     save_item(sv);
2430                     if (PERLDB_SUB_NN) {
2431                         int type = SvTYPE(sv);
2432                         if (type < SVt_PVIV && type != SVt_IV)
2433                             sv_upgrade(sv, SVt_PVIV);
2434                         (void)SvIOK_on(sv);
2435                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2436                     } else {
2437                         gv_efullname3(sv, CvGV(cv), Nullch);
2438                     }
2439                     if (  PERLDB_GOTO
2440                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2441                         PUSHMARK( PL_stack_sp );
2442                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2443                         PL_stack_sp--;
2444                     }
2445                 }
2446                 RETURNOP(CvSTART(cv));
2447             }
2448         }
2449         else {
2450             label = SvPV(sv,n_a);
2451             if (!(do_dump || *label))
2452                 DIE(aTHX_ must_have_label);
2453         }
2454     }
2455     else if (PL_op->op_flags & OPf_SPECIAL) {
2456         if (! do_dump)
2457             DIE(aTHX_ must_have_label);
2458     }
2459     else
2460         label = cPVOP->op_pv;
2461
2462     if (label && *label) {
2463         OP *gotoprobe = 0;
2464         bool leaving_eval = FALSE;
2465         bool in_block = FALSE;
2466         PERL_CONTEXT *last_eval_cx = 0;
2467
2468         /* find label */
2469
2470         PL_lastgotoprobe = 0;
2471         *enterops = 0;
2472         for (ix = cxstack_ix; ix >= 0; ix--) {
2473             cx = &cxstack[ix];
2474             switch (CxTYPE(cx)) {
2475             case CXt_EVAL:
2476                 leaving_eval = TRUE;
2477                 if (!CxTRYBLOCK(cx)) {
2478                     gotoprobe = (last_eval_cx ?
2479                                 last_eval_cx->blk_eval.old_eval_root :
2480                                 PL_eval_root);
2481                     last_eval_cx = cx;
2482                     break;
2483                 }
2484                 /* else fall through */
2485             case CXt_LOOP:
2486                 gotoprobe = cx->blk_oldcop->op_sibling;
2487                 break;
2488             case CXt_SUBST:
2489                 continue;
2490             case CXt_BLOCK:
2491                 if (ix) {
2492                     gotoprobe = cx->blk_oldcop->op_sibling;
2493                     in_block = TRUE;
2494                 } else
2495                     gotoprobe = PL_main_root;
2496                 break;
2497             case CXt_SUB:
2498                 if (CvDEPTH(cx->blk_sub.cv)) {
2499                     gotoprobe = CvROOT(cx->blk_sub.cv);
2500                     break;
2501                 }
2502                 /* FALL THROUGH */
2503             case CXt_FORMAT:
2504             case CXt_NULL:
2505                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2506             default:
2507                 if (ix)
2508                     DIE(aTHX_ "panic: goto");
2509                 gotoprobe = PL_main_root;
2510                 break;
2511             }
2512             if (gotoprobe) {
2513                 retop = dofindlabel(gotoprobe, label,
2514                                     enterops, enterops + GOTO_DEPTH);
2515                 if (retop)
2516                     break;
2517             }
2518             PL_lastgotoprobe = gotoprobe;
2519         }
2520         if (!retop)
2521             DIE(aTHX_ "Can't find label %s", label);
2522
2523         /* if we're leaving an eval, check before we pop any frames
2524            that we're not going to punt, otherwise the error
2525            won't be caught */
2526
2527         if (leaving_eval && *enterops && enterops[1]) {
2528             I32 i;
2529             for (i = 1; enterops[i]; i++)
2530                 if (enterops[i]->op_type == OP_ENTERITER)
2531                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2532         }
2533
2534         /* pop unwanted frames */
2535
2536         if (ix < cxstack_ix) {
2537             I32 oldsave;
2538
2539             if (ix < 0)
2540                 ix = 0;
2541             dounwind(ix);
2542             TOPBLOCK(cx);
2543             oldsave = PL_scopestack[PL_scopestack_ix];
2544             LEAVE_SCOPE(oldsave);
2545         }
2546
2547         /* push wanted frames */
2548
2549         if (*enterops && enterops[1]) {
2550             OP *oldop = PL_op;
2551             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2552             for (; enterops[ix]; ix++) {
2553                 PL_op = enterops[ix];
2554                 /* Eventually we may want to stack the needed arguments
2555                  * for each op.  For now, we punt on the hard ones. */
2556                 if (PL_op->op_type == OP_ENTERITER)
2557                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2558                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2559             }
2560             PL_op = oldop;
2561         }
2562     }
2563
2564     if (do_dump) {
2565 #ifdef VMS
2566         if (!retop) retop = PL_main_start;
2567 #endif
2568         PL_restartop = retop;
2569         PL_do_undump = TRUE;
2570
2571         my_unexec();
2572
2573         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2574         PL_do_undump = FALSE;
2575     }
2576
2577     RETURNOP(retop);
2578 }
2579
2580 PP(pp_exit)
2581 {
2582     dSP;
2583     I32 anum;
2584
2585     if (MAXARG < 1)
2586         anum = 0;
2587     else {
2588         anum = SvIVx(POPs);
2589 #ifdef VMS
2590         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2591             anum = 0;
2592         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2593 #endif
2594     }
2595     PL_exit_flags |= PERL_EXIT_EXPECTED;
2596     my_exit(anum);
2597     PUSHs(&PL_sv_undef);
2598     RETURN;
2599 }
2600
2601 #ifdef NOTYET
2602 PP(pp_nswitch)
2603 {
2604     dSP;
2605     NV value = SvNVx(GvSV(cCOP->cop_gv));
2606     register I32 match = I_32(value);
2607
2608     if (value < 0.0) {
2609         if (((NV)match) > value)
2610             --match;            /* was fractional--truncate other way */
2611     }
2612     match -= cCOP->uop.scop.scop_offset;
2613     if (match < 0)
2614         match = 0;
2615     else if (match > cCOP->uop.scop.scop_max)
2616         match = cCOP->uop.scop.scop_max;
2617     PL_op = cCOP->uop.scop.scop_next[match];
2618     RETURNOP(PL_op);
2619 }
2620
2621 PP(pp_cswitch)
2622 {
2623     dSP;
2624     register I32 match;
2625
2626     if (PL_multiline)
2627         PL_op = PL_op->op_next;                 /* can't assume anything */
2628     else {
2629         STRLEN n_a;
2630         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2631         match -= cCOP->uop.scop.scop_offset;
2632         if (match < 0)
2633             match = 0;
2634         else if (match > cCOP->uop.scop.scop_max)
2635             match = cCOP->uop.scop.scop_max;
2636         PL_op = cCOP->uop.scop.scop_next[match];
2637     }
2638     RETURNOP(PL_op);
2639 }
2640 #endif
2641
2642 /* Eval. */
2643
2644 STATIC void
2645 S_save_lines(pTHX_ AV *array, SV *sv)
2646 {
2647     register const char *s = SvPVX(sv);
2648     register const char *send = SvPVX(sv) + SvCUR(sv);
2649     register const char *t;
2650     register I32 line = 1;
2651
2652     while (s && s < send) {
2653         SV *tmpstr = NEWSV(85,0);
2654
2655         sv_upgrade(tmpstr, SVt_PVMG);
2656         t = strchr(s, '\n');
2657         if (t)
2658             t++;
2659         else
2660             t = send;
2661
2662         sv_setpvn(tmpstr, s, t - s);
2663         av_store(array, line++, tmpstr);
2664         s = t;
2665     }
2666 }
2667
2668 STATIC void *
2669 S_docatch_body(pTHX)
2670 {
2671     CALLRUNOPS(aTHX);
2672     return NULL;
2673 }
2674
2675 STATIC OP *
2676 S_docatch(pTHX_ OP *o)
2677 {
2678     int ret;
2679     OP * const oldop = PL_op;
2680     OP *retop;
2681     volatile PERL_SI *cursi = PL_curstackinfo;
2682     dJMPENV;
2683
2684 #ifdef DEBUGGING
2685     assert(CATCH_GET == TRUE);
2686 #endif
2687     PL_op = o;
2688
2689     /* Normally, the leavetry at the end of this block of ops will
2690      * pop an op off the return stack and continue there. By setting
2691      * the op to Nullop, we force an exit from the inner runops()
2692      * loop. DAPM.
2693      */
2694     assert(cxstack_ix >= 0);
2695     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2696     retop = cxstack[cxstack_ix].blk_eval.retop;
2697     cxstack[cxstack_ix].blk_eval.retop = Nullop;
2698
2699     JMPENV_PUSH(ret);
2700     switch (ret) {
2701     case 0:
2702  redo_body:
2703         docatch_body();
2704         break;
2705     case 3:
2706         /* die caught by an inner eval - continue inner loop */
2707         if (PL_restartop && cursi == PL_curstackinfo) {
2708             PL_op = PL_restartop;
2709             PL_restartop = 0;
2710             goto redo_body;
2711         }
2712         /* a die in this eval - continue in outer loop */
2713         if (!PL_restartop)
2714             break;
2715         /* FALL THROUGH */
2716     default:
2717         JMPENV_POP;
2718         PL_op = oldop;
2719         JMPENV_JUMP(ret);
2720         /* NOTREACHED */
2721     }
2722     JMPENV_POP;
2723     PL_op = oldop;
2724     return retop;
2725 }
2726
2727 OP *
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2732 {
2733     dSP;                                /* Make POPBLOCK work. */
2734     PERL_CONTEXT *cx;
2735     SV **newsp;
2736     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2737     I32 optype;
2738     OP dummy;
2739     OP *rop;
2740     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741     char *tmpbuf = tbuf;
2742     char *safestr;
2743     int runtime;
2744     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2745
2746     ENTER;
2747     lex_start(sv);
2748     SAVETMPS;
2749     /* switch to eval mode */
2750
2751     if (IN_PERL_COMPILETIME) {
2752         SAVECOPSTASH_FREE(&PL_compiling);
2753         CopSTASH_set(&PL_compiling, PL_curstash);
2754     }
2755     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2756         SV *sv = sv_newmortal();
2757         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2758                        code, (unsigned long)++PL_evalseq,
2759                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2760         tmpbuf = SvPVX(sv);
2761     }
2762     else
2763         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2764     SAVECOPFILE_FREE(&PL_compiling);
2765     CopFILE_set(&PL_compiling, tmpbuf+2);
2766     SAVECOPLINE(&PL_compiling);
2767     CopLINE_set(&PL_compiling, 1);
2768     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2769        deleting the eval's FILEGV from the stash before gv_check() runs
2770        (i.e. before run-time proper). To work around the coredump that
2771        ensues, we always turn GvMULTI_on for any globals that were
2772        introduced within evals. See force_ident(). GSAR 96-10-12 */
2773     safestr = savepv(tmpbuf);
2774     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2775     SAVEHINTS();
2776 #ifdef OP_IN_REGISTER
2777     PL_opsave = op;
2778 #else
2779     SAVEVPTR(PL_op);
2780 #endif
2781
2782     /* we get here either during compilation, or via pp_regcomp at runtime */
2783     runtime = IN_PERL_RUNTIME;
2784     if (runtime)
2785         runcv = find_runcv(NULL);
2786
2787     PL_op = &dummy;
2788     PL_op->op_type = OP_ENTEREVAL;
2789     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2790     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2791     PUSHEVAL(cx, 0, Nullgv);
2792
2793     if (runtime)
2794         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2795     else
2796         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2797     POPBLOCK(cx,PL_curpm);
2798     POPEVAL(cx);
2799
2800     (*startop)->op_type = OP_NULL;
2801     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2802     lex_end();
2803     /* XXX DAPM do this properly one year */
2804     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2805     LEAVE;
2806     if (IN_PERL_COMPILETIME)
2807         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2808 #ifdef OP_IN_REGISTER
2809     op = PL_opsave;
2810 #endif
2811     return rop;
2812 }
2813
2814
2815 /*
2816 =for apidoc find_runcv
2817
2818 Locate the CV corresponding to the currently executing sub or eval.
2819 If db_seqp is non_null, skip CVs that are in the DB package and populate
2820 *db_seqp with the cop sequence number at the point that the DB:: code was
2821 entered. (allows debuggers to eval in the scope of the breakpoint rather
2822 than in in the scope of the debugger itself).
2823
2824 =cut
2825 */
2826
2827 CV*
2828 Perl_find_runcv(pTHX_ U32 *db_seqp)
2829 {
2830     PERL_SI      *si;
2831
2832     if (db_seqp)
2833         *db_seqp = PL_curcop->cop_seq;
2834     for (si = PL_curstackinfo; si; si = si->si_prev) {
2835         I32 ix;
2836         for (ix = si->si_cxix; ix >= 0; ix--) {
2837             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2838             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2839                 CV *cv = cx->blk_sub.cv;
2840                 /* skip DB:: code */
2841                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2842                     *db_seqp = cx->blk_oldcop->cop_seq;
2843                     continue;
2844                 }
2845                 return cv;
2846             }
2847             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2848                 return PL_compcv;
2849         }
2850     }
2851     return PL_main_cv;
2852 }
2853
2854
2855 /* Compile a require/do, an eval '', or a /(?{...})/.
2856  * In the last case, startop is non-null, and contains the address of
2857  * a pointer that should be set to the just-compiled code.
2858  * outside is the lexically enclosing CV (if any) that invoked us.
2859  */
2860
2861 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2862 STATIC OP *
2863 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2864 {
2865     dSP;
2866     OP *saveop = PL_op;
2867
2868     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2869                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2870                   : EVAL_INEVAL);
2871
2872     PUSHMARK(SP);
2873
2874     SAVESPTR(PL_compcv);
2875     PL_compcv = (CV*)NEWSV(1104,0);
2876     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2877     CvEVAL_on(PL_compcv);
2878     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2879     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2880
2881     CvOUTSIDE_SEQ(PL_compcv) = seq;
2882     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2883
2884     /* set up a scratch pad */
2885
2886     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2887
2888
2889     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2890
2891     /* make sure we compile in the right package */
2892
2893     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2894         SAVESPTR(PL_curstash);
2895         PL_curstash = CopSTASH(PL_curcop);
2896     }
2897     SAVESPTR(PL_beginav);
2898     PL_beginav = newAV();
2899     SAVEFREESV(PL_beginav);
2900     SAVEI32(PL_error_count);
2901
2902     /* try to compile it */
2903
2904     PL_eval_root = Nullop;
2905     PL_error_count = 0;
2906     PL_curcop = &PL_compiling;
2907     PL_curcop->cop_arybase = 0;
2908     if (saveop && saveop->op_flags & OPf_SPECIAL)
2909         PL_in_eval |= EVAL_KEEPERR;
2910     else
2911         sv_setpv(ERRSV,"");
2912     if (yyparse() || PL_error_count || !PL_eval_root) {
2913         SV **newsp;                     /* Used by POPBLOCK. */
2914        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2915         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2916         STRLEN n_a;
2917
2918         PL_op = saveop;
2919         if (PL_eval_root) {
2920             op_free(PL_eval_root);
2921             PL_eval_root = Nullop;
2922         }
2923         SP = PL_stack_base + POPMARK;           /* pop original mark */
2924         if (!startop) {
2925             POPBLOCK(cx,PL_curpm);
2926             POPEVAL(cx);
2927         }
2928         lex_end();
2929         LEAVE;
2930         if (optype == OP_REQUIRE) {
2931             const char* msg = SvPVx(ERRSV, n_a);
2932            SV *nsv = cx->blk_eval.old_namesv;
2933            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2934                           &PL_sv_undef, 0);
2935             DIE(aTHX_ "%sCompilation failed in require",
2936                 *msg ? msg : "Unknown error\n");
2937         }
2938         else if (startop) {
2939             const char* msg = SvPVx(ERRSV, n_a);
2940
2941             POPBLOCK(cx,PL_curpm);
2942             POPEVAL(cx);
2943             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2944                        (*msg ? msg : "Unknown error\n"));
2945         }
2946         else {
2947             const char* msg = SvPVx(ERRSV, n_a);
2948             if (!*msg) {
2949                 sv_setpv(ERRSV, "Compilation error");
2950             }
2951         }
2952         RETPUSHUNDEF;
2953     }
2954     CopLINE_set(&PL_compiling, 0);
2955     if (startop) {
2956         *startop = PL_eval_root;
2957     } else
2958         SAVEFREEOP(PL_eval_root);
2959
2960     /* Set the context for this new optree.
2961      * If the last op is an OP_REQUIRE, force scalar context.
2962      * Otherwise, propagate the context from the eval(). */
2963     if (PL_eval_root->op_type == OP_LEAVEEVAL
2964             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2965             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2966             == OP_REQUIRE)
2967         scalar(PL_eval_root);
2968     else if (gimme & G_VOID)
2969         scalarvoid(PL_eval_root);
2970     else if (gimme & G_ARRAY)
2971         list(PL_eval_root);
2972     else
2973         scalar(PL_eval_root);
2974
2975     DEBUG_x(dump_eval());
2976
2977     /* Register with debugger: */
2978     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2979         CV *cv = get_cv("DB::postponed", FALSE);
2980         if (cv) {
2981             dSP;
2982             PUSHMARK(SP);
2983             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2984             PUTBACK;
2985             call_sv((SV*)cv, G_DISCARD);
2986         }
2987     }
2988
2989     /* compiled okay, so do it */
2990
2991     CvDEPTH(PL_compcv) = 1;
2992     SP = PL_stack_base + POPMARK;               /* pop original mark */
2993     PL_op = saveop;                     /* The caller may need it. */
2994     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2995
2996     RETURNOP(PL_eval_start);
2997 }
2998
2999 STATIC PerlIO *
3000 S_doopen_pm(pTHX_ const char *name, const char *mode)
3001 {
3002 #ifndef PERL_DISABLE_PMC
3003     STRLEN namelen = strlen(name);
3004     PerlIO *fp;
3005
3006     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3007         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3008         const char * const pmc = SvPV_nolen(pmcsv);
3009         Stat_t pmstat;
3010         Stat_t pmcstat;
3011         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3012             fp = PerlIO_open(name, mode);
3013         }
3014         else {
3015             if (PerlLIO_stat(name, &pmstat) < 0 ||
3016                 pmstat.st_mtime < pmcstat.st_mtime)
3017             {
3018                 fp = PerlIO_open(pmc, mode);
3019             }
3020             else {
3021                 fp = PerlIO_open(name, mode);
3022             }
3023         }
3024         SvREFCNT_dec(pmcsv);
3025     }
3026     else {
3027         fp = PerlIO_open(name, mode);
3028     }
3029     return fp;
3030 #else
3031     return PerlIO_open(name, mode);
3032 #endif /* !PERL_DISABLE_PMC */
3033 }
3034
3035 PP(pp_require)
3036 {
3037     dSP;
3038     register PERL_CONTEXT *cx;
3039     SV *sv;
3040     char *name;
3041     STRLEN len;
3042     char *tryname = Nullch;
3043     SV *namesv = Nullsv;
3044     SV** svp;
3045     I32 gimme = GIMME_V;
3046     PerlIO *tryrsfp = 0;
3047     STRLEN n_a;
3048     int filter_has_file = 0;
3049     GV *filter_child_proc = 0;
3050     SV *filter_state = 0;
3051     SV *filter_sub = 0;
3052     SV *hook_sv = 0;
3053     SV *encoding;
3054     OP *op;
3055
3056     sv = POPs;
3057     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3058         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3059                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3060                         "v-string in use/require non-portable");
3061
3062         sv = new_version(sv);
3063         if (!sv_derived_from(PL_patchlevel, "version"))
3064             (void *)upg_version(PL_patchlevel);
3065         if ( vcmp(sv,PL_patchlevel) > 0 )
3066             DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3067                 vstringify(sv), vstringify(PL_patchlevel));
3068
3069             RETPUSHYES;
3070     }
3071     name = SvPV(sv, len);
3072     if (!(name && len > 0 && *name))
3073         DIE(aTHX_ "Null filename used");
3074     TAINT_PROPER("require");
3075     if (PL_op->op_type == OP_REQUIRE &&
3076        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3077        if (*svp != &PL_sv_undef)
3078            RETPUSHYES;
3079        else
3080            DIE(aTHX_ "Compilation failed in require");
3081     }
3082
3083     /* prepare to compile file */
3084
3085     if (path_is_absolute(name)) {
3086         tryname = name;
3087         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3088     }
3089 #ifdef MACOS_TRADITIONAL
3090     if (!tryrsfp) {
3091         char newname[256];
3092
3093         MacPerl_CanonDir(name, newname, 1);
3094         if (path_is_absolute(newname)) {
3095             tryname = newname;
3096             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3097         }
3098     }
3099 #endif
3100     if (!tryrsfp) {
3101         AV *ar = GvAVn(PL_incgv);
3102         I32 i;
3103 #ifdef VMS
3104         char *unixname;
3105         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3106 #endif
3107         {
3108             namesv = NEWSV(806, 0);
3109             for (i = 0; i <= AvFILL(ar); i++) {
3110                 SV *dirsv = *av_fetch(ar, i, TRUE);
3111
3112                 if (SvROK(dirsv)) {
3113                     int count;
3114                     SV *loader = dirsv;
3115
3116                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3117                         && !sv_isobject(loader))
3118                     {
3119                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3120                     }
3121
3122                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3123                                    PTR2UV(SvRV(dirsv)), name);
3124                     tryname = SvPVX(namesv);
3125                     tryrsfp = 0;
3126
3127                     ENTER;
3128                     SAVETMPS;
3129                     EXTEND(SP, 2);
3130
3131                     PUSHMARK(SP);
3132                     PUSHs(dirsv);
3133                     PUSHs(sv);
3134                     PUTBACK;
3135                     if (sv_isobject(loader))
3136                         count = call_method("INC", G_ARRAY);
3137                     else
3138                         count = call_sv(loader, G_ARRAY);
3139                     SPAGAIN;
3140
3141                     if (count > 0) {
3142                         int i = 0;
3143                         SV *arg;
3144
3145                         SP -= count - 1;
3146                         arg = SP[i++];
3147
3148                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3149                             arg = SvRV(arg);
3150                         }
3151
3152                         if (SvTYPE(arg) == SVt_PVGV) {
3153                             IO *io = GvIO((GV *)arg);
3154
3155                             ++filter_has_file;
3156
3157                             if (io) {
3158                                 tryrsfp = IoIFP(io);
3159                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3160                                     /* reading from a child process doesn't
3161                                        nest -- when returning from reading
3162                                        the inner module, the outer one is
3163                                        unreadable (closed?)  I've tried to
3164                                        save the gv to manage the lifespan of
3165                                        the pipe, but this didn't help. XXX */
3166                                     filter_child_proc = (GV *)arg;
3167                                     (void)SvREFCNT_inc(filter_child_proc);
3168                                 }
3169                                 else {
3170                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3171                                         PerlIO_close(IoOFP(io));
3172                                     }
3173                                     IoIFP(io) = Nullfp;
3174                                     IoOFP(io) = Nullfp;
3175                                 }
3176                             }
3177
3178                             if (i < count) {
3179                                 arg = SP[i++];
3180                             }
3181                         }
3182
3183                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3184                             filter_sub = arg;
3185                             (void)SvREFCNT_inc(filter_sub);
3186
3187                             if (i < count) {
3188                                 filter_state = SP[i];
3189                                 (void)SvREFCNT_inc(filter_state);
3190                             }
3191
3192                             if (tryrsfp == 0) {
3193                                 tryrsfp = PerlIO_open("/dev/null",
3194                                                       PERL_SCRIPT_MODE);
3195                             }
3196                         }
3197                         SP--;
3198                     }
3199
3200                     PUTBACK;
3201                     FREETMPS;
3202                     LEAVE;
3203
3204                     if (tryrsfp) {
3205                         hook_sv = dirsv;
3206                         break;
3207                     }
3208
3209                     filter_has_file = 0;
3210                     if (filter_child_proc) {
3211                         SvREFCNT_dec(filter_child_proc);
3212                         filter_child_proc = 0;
3213                     }
3214                     if (filter_state) {
3215                         SvREFCNT_dec(filter_state);
3216                         filter_state = 0;
3217                     }
3218                     if (filter_sub) {
3219                         SvREFCNT_dec(filter_sub);
3220                         filter_sub = 0;
3221                     }
3222                 }
3223                 else {
3224                   if (!path_is_absolute(name)
3225 #ifdef MACOS_TRADITIONAL
3226                         /* We consider paths of the form :a:b ambiguous and interpret them first
3227                            as global then as local
3228                         */
3229                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3230 #endif
3231                   ) {
3232                     char *dir = SvPVx(dirsv, n_a);
3233 #ifdef MACOS_TRADITIONAL
3234                     char buf1[256];
3235                     char buf2[256];
3236
3237                     MacPerl_CanonDir(name, buf2, 1);
3238                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3239 #else
3240 #ifdef VMS
3241                     char *unixdir;
3242                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3243                         continue;
3244                     sv_setpv(namesv, unixdir);
3245                     sv_catpv(namesv, unixname);
3246 #else
3247                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3248 #endif
3249 #endif
3250                     TAINT_PROPER("require");
3251                     tryname = SvPVX(namesv);
3252                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3253                     if (tryrsfp) {
3254                         if (tryname[0] == '.' && tryname[1] == '/')
3255                             tryname += 2;
3256                         break;
3257                     }
3258                   }
3259                 }
3260             }
3261         }
3262     }
3263     SAVECOPFILE_FREE(&PL_compiling);
3264     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3265     SvREFCNT_dec(namesv);
3266     if (!tryrsfp) {
3267         if (PL_op->op_type == OP_REQUIRE) {
3268             char *msgstr = name;
3269             if (namesv) {                       /* did we lookup @INC? */
3270                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3271                 SV *dirmsgsv = NEWSV(0, 0);
3272                 AV *ar = GvAVn(PL_incgv);
3273                 I32 i;
3274                 sv_catpvn(msg, " in @INC", 8);
3275                 if (instr(SvPVX(msg), ".h "))
3276                     sv_catpv(msg, " (change .h to .ph maybe?)");
3277                 if (instr(SvPVX(msg), ".ph "))
3278                     sv_catpv(msg, " (did you run h2ph?)");
3279                 sv_catpv(msg, " (@INC contains:");
3280                 for (i = 0; i <= AvFILL(ar); i++) {
3281                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3282                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3283                     sv_catsv(msg, dirmsgsv);
3284                 }
3285                 sv_catpvn(msg, ")", 1);
3286                 SvREFCNT_dec(dirmsgsv);
3287                 msgstr = SvPV_nolen(msg);
3288             }
3289             DIE(aTHX_ "Can't locate %s", msgstr);
3290         }
3291
3292         RETPUSHUNDEF;
3293     }
3294     else
3295         SETERRNO(0, SS_NORMAL);
3296
3297     /* Assume success here to prevent recursive requirement. */
3298     len = strlen(name);
3299     /* Check whether a hook in @INC has already filled %INC */
3300     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3301         (void)hv_store(GvHVn(PL_incgv), name, len,
3302                        (hook_sv ? SvREFCNT_inc(hook_sv)
3303                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3304                        0 );
3305     }
3306
3307     ENTER;
3308     SAVETMPS;
3309     lex_start(sv_2mortal(newSVpvn("",0)));
3310     SAVEGENERICSV(PL_rsfp_filters);
3311     PL_rsfp_filters = Nullav;
3312
3313     PL_rsfp = tryrsfp;
3314     SAVEHINTS();
3315     PL_hints = 0;
3316     SAVESPTR(PL_compiling.cop_warnings);
3317     if (PL_dowarn & G_WARN_ALL_ON)
3318         PL_compiling.cop_warnings = pWARN_ALL ;
3319     else if (PL_dowarn & G_WARN_ALL_OFF)
3320         PL_compiling.cop_warnings = pWARN_NONE ;
3321     else if (PL_taint_warn)
3322         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3323     else
3324         PL_compiling.cop_warnings = pWARN_STD ;
3325     SAVESPTR(PL_compiling.cop_io);
3326     PL_compiling.cop_io = Nullsv;
3327
3328     if (filter_sub || filter_child_proc) {
3329         SV *datasv = filter_add(run_user_filter, Nullsv);
3330         IoLINES(datasv) = filter_has_file;
3331         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3332         IoTOP_GV(datasv) = (GV *)filter_state;
3333         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3334     }
3335
3336     /* switch to eval mode */
3337     PUSHBLOCK(cx, CXt_EVAL, SP);
3338     PUSHEVAL(cx, name, Nullgv);
3339     cx->blk_eval.retop = PL_op->op_next;
3340
3341     SAVECOPLINE(&PL_compiling);
3342     CopLINE_set(&PL_compiling, 0);
3343
3344     PUTBACK;
3345
3346     /* Store and reset encoding. */
3347     encoding = PL_encoding;
3348     PL_encoding = Nullsv;
3349
3350     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3351
3352     /* Restore encoding. */
3353     PL_encoding = encoding;
3354
3355     return op;
3356 }
3357
3358 PP(pp_dofile)
3359 {
3360     return pp_require();
3361 }
3362
3363 PP(pp_entereval)
3364 {
3365     dSP;
3366     register PERL_CONTEXT *cx;
3367     dPOPss;
3368     I32 gimme = GIMME_V, was = PL_sub_generation;
3369     char tbuf[TYPE_DIGITS(long) + 12];
3370     char *tmpbuf = tbuf;
3371     char *safestr;
3372     STRLEN len;
3373     OP *ret;
3374     CV* runcv;
3375     U32 seq;
3376
3377     if (!SvPV(sv,len))
3378         RETPUSHUNDEF;
3379     TAINT_PROPER("eval");
3380
3381     ENTER;
3382     lex_start(sv);
3383     SAVETMPS;
3384
3385     /* switch to eval mode */
3386
3387     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3388         SV *sv = sv_newmortal();
3389         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3390                        (unsigned long)++PL_evalseq,
3391                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3392         tmpbuf = SvPVX(sv);
3393     }
3394     else
3395         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3396     SAVECOPFILE_FREE(&PL_compiling);
3397     CopFILE_set(&PL_compiling, tmpbuf+2);
3398     SAVECOPLINE(&PL_compiling);
3399     CopLINE_set(&PL_compiling, 1);
3400     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3401        deleting the eval's FILEGV from the stash before gv_check() runs
3402        (i.e. before run-time proper). To work around the coredump that
3403        ensues, we always turn GvMULTI_on for any globals that were
3404        introduced within evals. See force_ident(). GSAR 96-10-12 */
3405     safestr = savepv(tmpbuf);
3406     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3407     SAVEHINTS();
3408     PL_hints = PL_op->op_targ;
3409     SAVESPTR(PL_compiling.cop_warnings);
3410     if (specialWARN(PL_curcop->cop_warnings))
3411         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3412     else {
3413         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3414         SAVEFREESV(PL_compiling.cop_warnings);
3415     }
3416     SAVESPTR(PL_compiling.cop_io);
3417     if (specialCopIO(PL_curcop->cop_io))
3418         PL_compiling.cop_io = PL_curcop->cop_io;
3419     else {
3420         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3421         SAVEFREESV(PL_compiling.cop_io);
3422     }
3423     /* special case: an eval '' executed within the DB package gets lexically
3424      * placed in the first non-DB CV rather than the current CV - this
3425      * allows the debugger to execute code, find lexicals etc, in the
3426      * scope of the code being debugged. Passing &seq gets find_runcv
3427      * to do the dirty work for us */
3428     runcv = find_runcv(&seq);
3429
3430     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3431     PUSHEVAL(cx, 0, Nullgv);
3432     cx->blk_eval.retop = PL_op->op_next;
3433
3434     /* prepare to compile string */
3435
3436     if (PERLDB_LINE && PL_curstash != PL_debstash)
3437         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3438     PUTBACK;
3439     ret = doeval(gimme, NULL, runcv, seq);
3440     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3441         && ret != PL_op->op_next) {     /* Successive compilation. */
3442         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3443     }
3444     return DOCATCH(ret);
3445 }
3446
3447 PP(pp_leaveeval)
3448 {
3449     dSP;
3450     register SV **mark;
3451     SV **newsp;
3452     PMOP *newpm;
3453     I32 gimme;
3454     register PERL_CONTEXT *cx;
3455     OP *retop;
3456     const U8 save_flags = PL_op -> op_flags;
3457     I32 optype;
3458
3459     POPBLOCK(cx,newpm);
3460     POPEVAL(cx);
3461     retop = cx->blk_eval.retop;
3462
3463     TAINT_NOT;
3464     if (gimme == G_VOID)
3465         MARK = newsp;
3466     else if (gimme == G_SCALAR) {
3467         MARK = newsp + 1;
3468         if (MARK <= SP) {
3469             if (SvFLAGS(TOPs) & SVs_TEMP)
3470                 *MARK = TOPs;
3471             else
3472                 *MARK = sv_mortalcopy(TOPs);
3473         }
3474         else {
3475             MEXTEND(mark,0);
3476             *MARK = &PL_sv_undef;
3477         }
3478         SP = MARK;
3479     }
3480     else {
3481         /* in case LEAVE wipes old return values */
3482         for (mark = newsp + 1; mark <= SP; mark++) {
3483             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3484                 *mark = sv_mortalcopy(*mark);
3485                 TAINT_NOT;      /* Each item is independent */
3486             }
3487         }
3488     }
3489     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3490
3491 #ifdef DEBUGGING
3492     assert(CvDEPTH(PL_compcv) == 1);
3493 #endif
3494     CvDEPTH(PL_compcv) = 0;
3495     lex_end();
3496
3497     if (optype == OP_REQUIRE &&
3498         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3499     {
3500         /* Unassume the success we assumed earlier. */
3501         SV *nsv = cx->blk_eval.old_namesv;
3502         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3503         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3504         /* die_where() did LEAVE, or we won't be here */
3505     }
3506     else {
3507         LEAVE;
3508         if (!(save_flags & OPf_SPECIAL))
3509             sv_setpv(ERRSV,"");
3510     }
3511
3512     RETURNOP(retop);
3513 }
3514
3515 PP(pp_entertry)
3516 {
3517     dSP;
3518     register PERL_CONTEXT *cx;
3519     I32 gimme = GIMME_V;
3520
3521     ENTER;
3522     SAVETMPS;
3523
3524     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3525     PUSHEVAL(cx, 0, 0);
3526     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3527
3528     PL_in_eval = EVAL_INEVAL;
3529     sv_setpv(ERRSV,"");
3530     PUTBACK;
3531     return DOCATCH(PL_op->op_next);
3532 }
3533
3534 PP(pp_leavetry)
3535 {
3536     dSP;
3537     register SV **mark;
3538     SV **newsp;
3539     PMOP *newpm;
3540     OP* retop;
3541     I32 gimme;
3542     register PERL_CONTEXT *cx;
3543     I32 optype;
3544
3545     POPBLOCK(cx,newpm);
3546     POPEVAL(cx);
3547     retop = cx->blk_eval.retop;
3548
3549     TAINT_NOT;
3550     if (gimme == G_VOID)
3551         SP = newsp;
3552     else if (gimme == G_SCALAR) {
3553         MARK = newsp + 1;
3554         if (MARK <= SP) {
3555             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3556                 *MARK = TOPs;
3557             else
3558                 *MARK = sv_mortalcopy(TOPs);
3559         }
3560         else {
3561             MEXTEND(mark,0);
3562             *MARK = &PL_sv_undef;
3563         }
3564         SP = MARK;
3565     }
3566     else {
3567         /* in case LEAVE wipes old return values */
3568         for (mark = newsp + 1; mark <= SP; mark++) {
3569             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3570                 *mark = sv_mortalcopy(*mark);
3571                 TAINT_NOT;      /* Each item is independent */
3572             }
3573         }
3574     }
3575     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3576
3577     LEAVE;
3578     sv_setpv(ERRSV,"");
3579     RETURNOP(retop);
3580 }
3581
3582 STATIC OP *
3583 S_doparseform(pTHX_ SV *sv)
3584 {
3585     STRLEN len;
3586     register char *s = SvPV_force(sv, len);
3587     register char *send = s + len;
3588     register char *base = Nullch;
3589     register I32 skipspaces = 0;
3590     bool noblank   = FALSE;
3591     bool repeat    = FALSE;
3592     bool postspace = FALSE;
3593     U32 *fops;
3594     register U32 *fpc;
3595     U32 *linepc = 0;
3596     register I32 arg;
3597     bool ischop;
3598     bool unchopnum = FALSE;
3599     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3600
3601     if (len == 0)
3602         Perl_croak(aTHX_ "Null picture in formline");
3603
3604     /* estimate the buffer size needed */
3605     for (base = s; s <= send; s++) {
3606         if (*s == '\n' || *s == '@' || *s == '^')
3607             maxops += 10;
3608     }
3609     s = base;
3610     base = Nullch;
3611
3612     New(804, fops, maxops, U32);
3613     fpc = fops;
3614
3615     if (s < send) {
3616         linepc = fpc;
3617         *fpc++ = FF_LINEMARK;
3618         noblank = repeat = FALSE;
3619         base = s;
3620     }
3621
3622     while (s <= send) {
3623         switch (*s++) {
3624         default:
3625             skipspaces = 0;
3626             continue;
3627
3628         case '~':
3629             if (*s == '~') {
3630                 repeat = TRUE;
3631                 *s = ' ';
3632             }
3633             noblank = TRUE;
3634             s[-1] = ' ';
3635             /* FALL THROUGH */
3636         case ' ': case '\t':
3637             skipspaces++;
3638             continue;
3639         case 0:
3640             if (s < send) {
3641                 skipspaces = 0;
3642                 continue;
3643             } /* else FALL THROUGH */
3644         case '\n':
3645             arg = s - base;
3646             skipspaces++;
3647             arg -= skipspaces;
3648             if (arg) {
3649                 if (postspace)
3650                     *fpc++ = FF_SPACE;
3651                 *fpc++ = FF_LITERAL;
3652                 *fpc++ = (U16)arg;
3653             }
3654             postspace = FALSE;
3655             if (s <= send)
3656                 skipspaces--;
3657             if (skipspaces) {
3658                 *fpc++ = FF_SKIP;
3659                 *fpc++ = (U16)skipspaces;
3660             }
3661             skipspaces = 0;
3662             if (s <= send)
3663                 *fpc++ = FF_NEWLINE;
3664             if (noblank) {
3665                 *fpc++ = FF_BLANK;
3666                 if (repeat)
3667                     arg = fpc - linepc + 1;
3668                 else
3669                     arg = 0;
3670                 *fpc++ = (U16)arg;
3671             }
3672             if (s < send) {
3673                 linepc = fpc;
3674                 *fpc++ = FF_LINEMARK;
3675                 noblank = repeat = FALSE;
3676                 base = s;
3677             }
3678             else
3679                 s++;
3680             continue;
3681
3682         case '@':
3683         case '^':
3684             ischop = s[-1] == '^';
3685
3686             if (postspace) {
3687                 *fpc++ = FF_SPACE;
3688                 postspace = FALSE;
3689             }
3690             arg = (s - base) - 1;
3691             if (arg) {
3692                 *fpc++ = FF_LITERAL;
3693                 *fpc++ = (U16)arg;
3694             }
3695
3696             base = s - 1;
3697             *fpc++ = FF_FETCH;
3698             if (*s == '*') {
3699                 s++;
3700                 *fpc++ = 2;  /* skip the @* or ^* */
3701                 if (ischop) {
3702                     *fpc++ = FF_LINESNGL;
3703                     *fpc++ = FF_CHOP;
3704                 } else
3705                     *fpc++ = FF_LINEGLOB;
3706             }
3707             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3708                 arg = ischop ? 512 : 0;
3709                 base = s - 1;
3710                 while (*s == '#')
3711                     s++;
3712                 if (*s == '.') {
3713                     const char * const f = ++s;
3714                     while (*s == '#')
3715                         s++;
3716                     arg |= 256 + (s - f);
3717                 }
3718                 *fpc++ = s - base;              /* fieldsize for FETCH */
3719                 *fpc++ = FF_DECIMAL;
3720                 *fpc++ = (U16)arg;
3721                 unchopnum |= ! ischop;
3722             }
3723             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3724                 arg = ischop ? 512 : 0;
3725                 base = s - 1;
3726                 s++;                                /* skip the '0' first */
3727                 while (*s == '#')
3728                     s++;
3729                 if (*s == '.') {
3730                     const char * const f = ++s;
3731                     while (*s == '#')
3732                         s++;
3733                     arg |= 256 + (s - f);
3734                 }
3735                 *fpc++ = s - base;                /* fieldsize for FETCH */
3736                 *fpc++ = FF_0DECIMAL;
3737                 *fpc++ = (U16)arg;
3738                 unchopnum |= ! ischop;
3739             }
3740             else {
3741                 I32 prespace = 0;
3742                 bool ismore = FALSE;
3743
3744                 if (*s == '>') {
3745                     while (*++s == '>') ;
3746                     prespace = FF_SPACE;
3747                 }
3748                 else if (*s == '|') {
3749                     while (*++s == '|') ;
3750                     prespace = FF_HALFSPACE;
3751                     postspace = TRUE;
3752                 }
3753                 else {
3754                     if (*s == '<')
3755                         while (*++s == '<') ;
3756                     postspace = TRUE;
3757                 }
3758                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3759                     s += 3;
3760                     ismore = TRUE;
3761                 }
3762                 *fpc++ = s - base;              /* fieldsize for FETCH */
3763
3764                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3765
3766                 if (prespace)
3767                     *fpc++ = (U16)prespace;
3768                 *fpc++ = FF_ITEM;
3769                 if (ismore)
3770                     *fpc++ = FF_MORE;
3771                 if (ischop)
3772                     *fpc++ = FF_CHOP;
3773             }
3774             base = s;
3775             skipspaces = 0;
3776             continue;
3777         }
3778     }
3779     *fpc++ = FF_END;
3780
3781     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3782     arg = fpc - fops;
3783     { /* need to jump to the next word */
3784         int z;
3785         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3786         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3787         s = SvPVX(sv) + SvCUR(sv) + z;
3788     }
3789     Copy(fops, s, arg, U32);
3790     Safefree(fops);
3791     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3792     SvCOMPILED_on(sv);
3793
3794     if (unchopnum && repeat)
3795         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3796     return 0;
3797 }
3798
3799
3800 STATIC bool
3801 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3802 {
3803     /* Can value be printed in fldsize chars, using %*.*f ? */
3804     NV pwr = 1;
3805     NV eps = 0.5;
3806     bool res = FALSE;
3807     int intsize = fldsize - (value < 0 ? 1 : 0);
3808
3809     if (frcsize & 256)
3810         intsize--;
3811     frcsize &= 255;
3812     intsize -= frcsize;
3813
3814     while (intsize--) pwr *= 10.0;
3815     while (frcsize--) eps /= 10.0;
3816
3817     if( value >= 0 ){
3818         if (value + eps >= pwr)
3819             res = TRUE;
3820     } else {
3821         if (value - eps <= -pwr)
3822             res = TRUE;
3823     }
3824     return res;
3825 }
3826
3827 static I32
3828 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3829 {
3830     SV *datasv = FILTER_DATA(idx);
3831     int filter_has_file = IoLINES(datasv);
3832     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3833     SV *filter_state = (SV *)IoTOP_GV(datasv);
3834     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3835     int len = 0;
3836
3837     /* I was having segfault trouble under Linux 2.2.5 after a
3838        parse error occured.  (Had to hack around it with a test
3839        for PL_error_count == 0.)  Solaris doesn't segfault --
3840        not sure where the trouble is yet.  XXX */
3841
3842     if (filter_has_file) {
3843         len = FILTER_READ(idx+1, buf_sv, maxlen);
3844     }
3845
3846     if (filter_sub && len >= 0) {
3847         dSP;
3848         int count;
3849
3850         ENTER;
3851         SAVE_DEFSV;
3852         SAVETMPS;
3853         EXTEND(SP, 2);
3854
3855         DEFSV = buf_sv;
3856         PUSHMARK(SP);
3857         PUSHs(sv_2mortal(newSViv(maxlen)));
3858         if (filter_state) {
3859             PUSHs(filter_state);
3860         }
3861         PUTBACK;
3862         count = call_sv(filter_sub, G_SCALAR);
3863         SPAGAIN;
3864
3865         if (count > 0) {
3866             SV *out = POPs;
3867             if (SvOK(out)) {
3868                 len = SvIV(out);
3869             }
3870         }
3871
3872         PUTBACK;
3873         FREETMPS;
3874         LEAVE;
3875     }
3876
3877     if (len <= 0) {
3878         IoLINES(datasv) = 0;
3879         if (filter_child_proc) {
3880             SvREFCNT_dec(filter_child_proc);
3881             IoFMT_GV(datasv) = Nullgv;
3882         }
3883         if (filter_state) {
3884             SvREFCNT_dec(filter_state);
3885             IoTOP_GV(datasv) = Nullgv;
3886         }
3887         if (filter_sub) {
3888             SvREFCNT_dec(filter_sub);
3889             IoBOTTOM_GV(datasv) = Nullgv;
3890         }
3891         filter_del(run_user_filter);
3892     }
3893
3894     return len;
3895 }
3896
3897 /* perhaps someone can come up with a better name for
3898    this?  it is not really "absolute", per se ... */
3899 static bool
3900 S_path_is_absolute(pTHX_ const char *name)
3901 {
3902     if (PERL_FILE_IS_ABSOLUTE(name)
3903 #ifdef MACOS_TRADITIONAL
3904         || (*name == ':'))
3905 #else
3906         || (*name == '.' && (name[1] == '/' ||
3907                              (name[1] == '.' && name[2] == '/'))))
3908 #endif
3909     {
3910         return TRUE;
3911     }
3912     else
3913         return FALSE;
3914 }
3915
3916 /*
3917  * Local variables:
3918  * c-indentation-style: bsd
3919  * c-basic-offset: 4
3920  * indent-tabs-mode: t
3921  * End:
3922  *
3923  * vim: shiftwidth=4:
3924 */