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, 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             SvPVX(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             SvPVX(dstr) = 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     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             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 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_ char *label)
1199 {
1200     register I32 i;
1201     register PERL_CONTEXT *cx;
1202
1203     for (i = cxstack_ix; i >= 0; i--) {
1204         cx = &cxstack[i];
1205         switch (CxTYPE(cx)) {
1206         case CXt_SUBST:
1207         case CXt_SUB:
1208         case CXt_FORMAT:
1209         case CXt_EVAL:
1210         case CXt_NULL:
1211             if (ckWARN(WARN_EXITING))
1212                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1213                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1214             if (CxTYPE(cx) == CXt_NULL)
1215                 return -1;
1216             break;
1217         case CXt_LOOP:
1218             if (!cx->blk_loop.label ||
1219               strNE(label, cx->blk_loop.label) ) {
1220                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1221                         (long)i, cx->blk_loop.label));
1222                 continue;
1223             }
1224             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1225             return i;
1226         }
1227     }
1228     return i;
1229 }
1230
1231 I32
1232 Perl_dowantarray(pTHX)
1233 {
1234     I32 gimme = block_gimme();
1235     return (gimme == G_VOID) ? G_SCALAR : gimme;
1236 }
1237
1238 I32
1239 Perl_block_gimme(pTHX)
1240 {
1241     I32 cxix;
1242
1243     cxix = dopoptosub(cxstack_ix);
1244     if (cxix < 0)
1245         return G_VOID;
1246
1247     switch (cxstack[cxix].blk_gimme) {
1248     case G_VOID:
1249         return G_VOID;
1250     case G_SCALAR:
1251         return G_SCALAR;
1252     case G_ARRAY:
1253         return G_ARRAY;
1254     default:
1255         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1256         /* NOTREACHED */
1257         return 0;
1258     }
1259 }
1260
1261 I32
1262 Perl_is_lvalue_sub(pTHX)
1263 {
1264     I32 cxix;
1265
1266     cxix = dopoptosub(cxstack_ix);
1267     assert(cxix >= 0);  /* We should only be called from inside subs */
1268
1269     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1270         return cxstack[cxix].blk_sub.lval;
1271     else
1272         return 0;
1273 }
1274
1275 STATIC I32
1276 S_dopoptosub(pTHX_ I32 startingblock)
1277 {
1278     return dopoptosub_at(cxstack, startingblock);
1279 }
1280
1281 STATIC I32
1282 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1283 {
1284     I32 i;
1285     register PERL_CONTEXT *cx;
1286     for (i = startingblock; i >= 0; i--) {
1287         cx = &cxstk[i];
1288         switch (CxTYPE(cx)) {
1289         default:
1290             continue;
1291         case CXt_EVAL:
1292         case CXt_SUB:
1293         case CXt_FORMAT:
1294             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1295             return i;
1296         }
1297     }
1298     return i;
1299 }
1300
1301 STATIC I32
1302 S_dopoptoeval(pTHX_ I32 startingblock)
1303 {
1304     I32 i;
1305     register PERL_CONTEXT *cx;
1306     for (i = startingblock; i >= 0; i--) {
1307         cx = &cxstack[i];
1308         switch (CxTYPE(cx)) {
1309         default:
1310             continue;
1311         case CXt_EVAL:
1312             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1313             return i;
1314         }
1315     }
1316     return i;
1317 }
1318
1319 STATIC I32
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1321 {
1322     I32 i;
1323     register PERL_CONTEXT *cx;
1324     for (i = startingblock; i >= 0; i--) {
1325         cx = &cxstack[i];
1326         switch (CxTYPE(cx)) {
1327         case CXt_SUBST:
1328         case CXt_SUB:
1329         case CXt_FORMAT:
1330         case CXt_EVAL:
1331         case CXt_NULL:
1332             if (ckWARN(WARN_EXITING))
1333                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335             if ((CxTYPE(cx)) == CXt_NULL)
1336                 return -1;
1337             break;
1338         case CXt_LOOP:
1339             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1340             return i;
1341         }
1342     }
1343     return i;
1344 }
1345
1346 void
1347 Perl_dounwind(pTHX_ I32 cxix)
1348 {
1349     register PERL_CONTEXT *cx;
1350     I32 optype;
1351
1352     while (cxstack_ix > cxix) {
1353         SV *sv;
1354         cx = &cxstack[cxstack_ix];
1355         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1356                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1357         /* Note: we don't need to restore the base context info till the end. */
1358         switch (CxTYPE(cx)) {
1359         case CXt_SUBST:
1360             POPSUBST(cx);
1361             continue;  /* not break */
1362         case CXt_SUB:
1363             POPSUB(cx,sv);
1364             LEAVESUB(sv);
1365             break;
1366         case CXt_EVAL:
1367             POPEVAL(cx);
1368             break;
1369         case CXt_LOOP:
1370             POPLOOP(cx);
1371             break;
1372         case CXt_NULL:
1373             break;
1374         case CXt_FORMAT:
1375             POPFORMAT(cx);
1376             break;
1377         }
1378         cxstack_ix--;
1379     }
1380 }
1381
1382 void
1383 Perl_qerror(pTHX_ SV *err)
1384 {
1385     if (PL_in_eval)
1386         sv_catsv(ERRSV, err);
1387     else if (PL_errors)
1388         sv_catsv(PL_errors, err);
1389     else
1390         Perl_warn(aTHX_ "%"SVf, err);
1391     ++PL_error_count;
1392 }
1393
1394 OP *
1395 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1396 {
1397     STRLEN n_a;
1398
1399     if (PL_in_eval) {
1400         I32 cxix;
1401         register PERL_CONTEXT *cx;
1402         I32 gimme;
1403         SV **newsp;
1404
1405         if (message) {
1406             if (PL_in_eval & EVAL_KEEPERR) {
1407                 static char prefix[] = "\t(in cleanup) ";
1408                 SV *err = ERRSV;
1409                 char *e = Nullch;
1410                 if (!SvPOK(err))
1411                     sv_setpv(err,"");
1412                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1413                     e = SvPV(err, n_a);
1414                     e += n_a - msglen;
1415                     if (*e != *message || strNE(e,message))
1416                         e = Nullch;
1417                 }
1418                 if (!e) {
1419                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1420                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1421                     sv_catpvn(err, message, msglen);
1422                     if (ckWARN(WARN_MISC)) {
1423                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1424                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1425                     }
1426                 }
1427             }
1428             else {
1429                 sv_setpvn(ERRSV, message, msglen);
1430             }
1431         }
1432
1433         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1434                && PL_curstackinfo->si_prev)
1435         {
1436             dounwind(-1);
1437             POPSTACK;
1438         }
1439
1440         if (cxix >= 0) {
1441             I32 optype;
1442
1443             if (cxix < cxstack_ix)
1444                 dounwind(cxix);
1445
1446             POPBLOCK(cx,PL_curpm);
1447             if (CxTYPE(cx) != CXt_EVAL) {
1448                 if (!message)
1449                     message = SvPVx(ERRSV, msglen);
1450                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1451                 PerlIO_write(Perl_error_log, message, msglen);
1452                 my_exit(1);
1453             }
1454             POPEVAL(cx);
1455
1456             if (gimme == G_SCALAR)
1457                 *++newsp = &PL_sv_undef;
1458             PL_stack_sp = newsp;
1459
1460             LEAVE;
1461
1462             /* LEAVE could clobber PL_curcop (see save_re_context())
1463              * XXX it might be better to find a way to avoid messing with
1464              * PL_curcop in save_re_context() instead, but this is a more
1465              * minimal fix --GSAR */
1466             PL_curcop = cx->blk_oldcop;
1467
1468             if (optype == OP_REQUIRE) {
1469                 char* msg = SvPVx(ERRSV, n_a);
1470                SV *nsv = cx->blk_eval.old_namesv;
1471                (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1472                                &PL_sv_undef, 0);
1473                 DIE(aTHX_ "%sCompilation failed in require",
1474                     *msg ? msg : "Unknown error\n");
1475             }
1476             assert(CxTYPE(cx) == CXt_EVAL);
1477             return cx->blk_eval.retop;
1478         }
1479     }
1480     if (!message)
1481         message = SvPVx(ERRSV, msglen);
1482
1483     write_to_stderr(message, msglen);
1484     my_failure_exit();
1485     /* NOTREACHED */
1486     return 0;
1487 }
1488
1489 PP(pp_xor)
1490 {
1491     dSP; dPOPTOPssrl;
1492     if (SvTRUE(left) != SvTRUE(right))
1493         RETSETYES;
1494     else
1495         RETSETNO;
1496 }
1497
1498 PP(pp_andassign)
1499 {
1500     dSP;
1501     if (!SvTRUE(TOPs))
1502         RETURN;
1503     else
1504         RETURNOP(cLOGOP->op_other);
1505 }
1506
1507 PP(pp_orassign)
1508 {
1509     dSP;
1510     if (SvTRUE(TOPs))
1511         RETURN;
1512     else
1513         RETURNOP(cLOGOP->op_other);
1514 }
1515
1516 PP(pp_dorassign)
1517 {
1518     dSP;
1519     register SV* sv;
1520
1521     sv = TOPs;
1522     if (!sv || !SvANY(sv)) {
1523         RETURNOP(cLOGOP->op_other);
1524     }
1525
1526     switch (SvTYPE(sv)) {
1527     case SVt_PVAV:
1528         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1529             RETURN;
1530         break;
1531     case SVt_PVHV:
1532         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1533             RETURN;
1534         break;
1535     case SVt_PVCV:
1536         if (CvROOT(sv) || CvXSUB(sv))
1537             RETURN;
1538         break;
1539     default:
1540         if (SvGMAGICAL(sv))
1541             mg_get(sv);
1542         if (SvOK(sv))
1543             RETURN;
1544     }
1545
1546     RETURNOP(cLOGOP->op_other);
1547 }
1548
1549 PP(pp_caller)
1550 {
1551     dSP;
1552     register I32 cxix = dopoptosub(cxstack_ix);
1553     register PERL_CONTEXT *cx;
1554     register PERL_CONTEXT *ccstack = cxstack;
1555     PERL_SI *top_si = PL_curstackinfo;
1556     I32 dbcxix;
1557     I32 gimme;
1558     char *stashname;
1559     SV *sv;
1560     I32 count = 0;
1561
1562     if (MAXARG)
1563         count = POPi;
1564
1565     for (;;) {
1566         /* we may be in a higher stacklevel, so dig down deeper */
1567         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1568             top_si = top_si->si_prev;
1569             ccstack = top_si->si_cxstack;
1570             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1571         }
1572         if (cxix < 0) {
1573             if (GIMME != G_ARRAY) {
1574                 EXTEND(SP, 1);
1575                 RETPUSHUNDEF;
1576             }
1577             RETURN;
1578         }
1579         if (PL_DBsub && cxix >= 0 &&
1580                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1581             count++;
1582         if (!count--)
1583             break;
1584         cxix = dopoptosub_at(ccstack, cxix - 1);
1585     }
1586
1587     cx = &ccstack[cxix];
1588     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1589         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1590         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1591            field below is defined for any cx. */
1592         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1593             cx = &ccstack[dbcxix];
1594     }
1595
1596     stashname = CopSTASHPV(cx->blk_oldcop);
1597     if (GIMME != G_ARRAY) {
1598         EXTEND(SP, 1);
1599         if (!stashname)
1600             PUSHs(&PL_sv_undef);
1601         else {
1602             dTARGET;
1603             sv_setpv(TARG, stashname);
1604             PUSHs(TARG);
1605         }
1606         RETURN;
1607     }
1608
1609     EXTEND(SP, 10);
1610
1611     if (!stashname)
1612         PUSHs(&PL_sv_undef);
1613     else
1614         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1615     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1616     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1617     if (!MAXARG)
1618         RETURN;
1619     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1620         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1621         /* So is ccstack[dbcxix]. */
1622         if (isGV(cvgv)) {
1623             sv = NEWSV(49, 0);
1624             gv_efullname3(sv, cvgv, Nullch);
1625             PUSHs(sv_2mortal(sv));
1626             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1627         }
1628         else {
1629             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1630             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1631         }
1632     }
1633     else {
1634         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1635         PUSHs(sv_2mortal(newSViv(0)));
1636     }
1637     gimme = (I32)cx->blk_gimme;
1638     if (gimme == G_VOID)
1639         PUSHs(&PL_sv_undef);
1640     else
1641         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1642     if (CxTYPE(cx) == CXt_EVAL) {
1643         /* eval STRING */
1644         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1645             PUSHs(cx->blk_eval.cur_text);
1646             PUSHs(&PL_sv_no);
1647         }
1648         /* require */
1649         else if (cx->blk_eval.old_namesv) {
1650             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1651             PUSHs(&PL_sv_yes);
1652         }
1653         /* eval BLOCK (try blocks have old_namesv == 0) */
1654         else {
1655             PUSHs(&PL_sv_undef);
1656             PUSHs(&PL_sv_undef);
1657         }
1658     }
1659     else {
1660         PUSHs(&PL_sv_undef);
1661         PUSHs(&PL_sv_undef);
1662     }
1663     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1664         && CopSTASH_eq(PL_curcop, PL_debstash))
1665     {
1666         AV *ary = cx->blk_sub.argarray;
1667         int off = AvARRAY(ary) - AvALLOC(ary);
1668
1669         if (!PL_dbargs) {
1670             GV* tmpgv;
1671             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1672                                 SVt_PVAV)));
1673             GvMULTI_on(tmpgv);
1674             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1675         }
1676
1677         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1678             av_extend(PL_dbargs, AvFILLp(ary) + off);
1679         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1680         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1681     }
1682     /* XXX only hints propagated via op_private are currently
1683      * visible (others are not easily accessible, since they
1684      * use the global PL_hints) */
1685     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1686                              HINT_PRIVATE_MASK)));
1687     {
1688         SV * mask ;
1689         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1690
1691         if  (old_warnings == pWARN_NONE ||
1692                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1693             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1694         else if (old_warnings == pWARN_ALL ||
1695                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1696             /* Get the bit mask for $warnings::Bits{all}, because
1697              * it could have been extended by warnings::register */
1698             SV **bits_all;
1699             HV *bits = get_hv("warnings::Bits", FALSE);
1700             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1701                 mask = newSVsv(*bits_all);
1702             }
1703             else {
1704                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1705             }
1706         }
1707         else
1708             mask = newSVsv(old_warnings);
1709         PUSHs(sv_2mortal(mask));
1710     }
1711     RETURN;
1712 }
1713
1714 PP(pp_reset)
1715 {
1716     dSP;
1717     char *tmps;
1718     STRLEN n_a;
1719
1720     if (MAXARG < 1)
1721         tmps = "";
1722     else
1723         tmps = POPpx;
1724     sv_reset(tmps, CopSTASH(PL_curcop));
1725     PUSHs(&PL_sv_yes);
1726     RETURN;
1727 }
1728
1729 PP(pp_lineseq)
1730 {
1731     return NORMAL;
1732 }
1733
1734 /* like pp_nextstate, but used instead when the debugger is active */
1735
1736 PP(pp_dbstate)
1737 {
1738     PL_curcop = (COP*)PL_op;
1739     TAINT_NOT;          /* Each statement is presumed innocent */
1740     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1741     FREETMPS;
1742
1743     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1744             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1745     {
1746         dSP;
1747         register CV *cv;
1748         register PERL_CONTEXT *cx;
1749         I32 gimme = G_ARRAY;
1750         U8 hasargs;
1751         GV *gv;
1752
1753         gv = PL_DBgv;
1754         cv = GvCV(gv);
1755         if (!cv)
1756             DIE(aTHX_ "No DB::DB routine defined");
1757
1758         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1759             /* don't do recursive DB::DB call */
1760             return NORMAL;
1761
1762         ENTER;
1763         SAVETMPS;
1764
1765         SAVEI32(PL_debug);
1766         SAVESTACK_POS();
1767         PL_debug = 0;
1768         hasargs = 0;
1769         SPAGAIN;
1770
1771         PUSHBLOCK(cx, CXt_SUB, SP);
1772         PUSHSUB_DB(cx);
1773         cx->blk_sub.retop = PL_op->op_next;
1774         CvDEPTH(cv)++;
1775         PAD_SET_CUR(CvPADLIST(cv),1);
1776         RETURNOP(CvSTART(cv));
1777     }
1778     else
1779         return NORMAL;
1780 }
1781
1782 PP(pp_scope)
1783 {
1784     return NORMAL;
1785 }
1786
1787 PP(pp_enteriter)
1788 {
1789     dSP; dMARK;
1790     register PERL_CONTEXT *cx;
1791     I32 gimme = GIMME_V;
1792     SV **svp;
1793     U32 cxtype = CXt_LOOP;
1794 #ifdef USE_ITHREADS
1795     void *iterdata;
1796 #endif
1797
1798     ENTER;
1799     SAVETMPS;
1800
1801     if (PL_op->op_targ) {
1802         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1803             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1804             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1805                     SVs_PADSTALE, SVs_PADSTALE);
1806         }
1807 #ifndef USE_ITHREADS
1808         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1809         SAVESPTR(*svp);
1810 #else
1811         SAVEPADSV(PL_op->op_targ);
1812         iterdata = INT2PTR(void*, PL_op->op_targ);
1813         cxtype |= CXp_PADVAR;
1814 #endif
1815     }
1816     else {
1817         GV *gv = (GV*)POPs;
1818         svp = &GvSV(gv);                        /* symbol table variable */
1819         SAVEGENERICSV(*svp);
1820         *svp = NEWSV(0,0);
1821 #ifdef USE_ITHREADS
1822         iterdata = (void*)gv;
1823 #endif
1824     }
1825
1826     ENTER;
1827
1828     PUSHBLOCK(cx, cxtype, SP);
1829 #ifdef USE_ITHREADS
1830     PUSHLOOP(cx, iterdata, MARK);
1831 #else
1832     PUSHLOOP(cx, svp, MARK);
1833 #endif
1834     if (PL_op->op_flags & OPf_STACKED) {
1835         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1836         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1837             dPOPss;
1838             SV *right = (SV*)cx->blk_loop.iterary;
1839             if (RANGE_IS_NUMERIC(sv,right)) {
1840                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1841                     (SvOK(right) && SvNV(right) >= IV_MAX))
1842                     DIE(aTHX_ "Range iterator outside integer range");
1843                 cx->blk_loop.iterix = SvIV(sv);
1844                 cx->blk_loop.itermax = SvIV(right);
1845             }
1846             else {
1847                 STRLEN n_a;
1848                 cx->blk_loop.iterlval = newSVsv(sv);
1849                 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1850                 (void) SvPV(right,n_a);
1851             }
1852         }
1853         else if (PL_op->op_private & OPpITER_REVERSED) {
1854             cx->blk_loop.itermax = -1;
1855             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1856
1857         }
1858     }
1859     else {
1860         cx->blk_loop.iterary = PL_curstack;
1861         AvFILLp(PL_curstack) = SP - PL_stack_base;
1862         if (PL_op->op_private & OPpITER_REVERSED) {
1863             cx->blk_loop.itermax = MARK - PL_stack_base;
1864             cx->blk_loop.iterix = cx->blk_oldsp;
1865         }
1866         else {
1867             cx->blk_loop.iterix = MARK - PL_stack_base;
1868         }
1869     }
1870
1871     RETURN;
1872 }
1873
1874 PP(pp_enterloop)
1875 {
1876     dSP;
1877     register PERL_CONTEXT *cx;
1878     I32 gimme = GIMME_V;
1879
1880     ENTER;
1881     SAVETMPS;
1882     ENTER;
1883
1884     PUSHBLOCK(cx, CXt_LOOP, SP);
1885     PUSHLOOP(cx, 0, SP);
1886
1887     RETURN;
1888 }
1889
1890 PP(pp_leaveloop)
1891 {
1892     dSP;
1893     register PERL_CONTEXT *cx;
1894     I32 gimme;
1895     SV **newsp;
1896     PMOP *newpm;
1897     SV **mark;
1898
1899     POPBLOCK(cx,newpm);
1900     mark = newsp;
1901     newsp = PL_stack_base + cx->blk_loop.resetsp;
1902
1903     TAINT_NOT;
1904     if (gimme == G_VOID)
1905         ; /* do nothing */
1906     else if (gimme == G_SCALAR) {
1907         if (mark < SP)
1908             *++newsp = sv_mortalcopy(*SP);
1909         else
1910             *++newsp = &PL_sv_undef;
1911     }
1912     else {
1913         while (mark < SP) {
1914             *++newsp = sv_mortalcopy(*++mark);
1915             TAINT_NOT;          /* Each item is independent */
1916         }
1917     }
1918     SP = newsp;
1919     PUTBACK;
1920
1921     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1922     PL_curpm = newpm;   /* ... and pop $1 et al */
1923
1924     LEAVE;
1925     LEAVE;
1926
1927     return NORMAL;
1928 }
1929
1930 PP(pp_return)
1931 {
1932     dSP; dMARK;
1933     I32 cxix;
1934     register PERL_CONTEXT *cx;
1935     bool popsub2 = FALSE;
1936     bool clear_errsv = FALSE;
1937     I32 gimme;
1938     SV **newsp;
1939     PMOP *newpm;
1940     I32 optype = 0;
1941     SV *sv;
1942     OP *retop;
1943
1944     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1945         if (cxstack_ix == PL_sortcxix
1946             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1947         {
1948             if (cxstack_ix > PL_sortcxix)
1949                 dounwind(PL_sortcxix);
1950             AvARRAY(PL_curstack)[1] = *SP;
1951             PL_stack_sp = PL_stack_base + 1;
1952             return 0;
1953         }
1954     }
1955
1956     cxix = dopoptosub(cxstack_ix);
1957     if (cxix < 0)
1958         DIE(aTHX_ "Can't return outside a subroutine");
1959     if (cxix < cxstack_ix)
1960         dounwind(cxix);
1961
1962     POPBLOCK(cx,newpm);
1963     switch (CxTYPE(cx)) {
1964     case CXt_SUB:
1965         popsub2 = TRUE;
1966         retop = cx->blk_sub.retop;
1967         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1968         break;
1969     case CXt_EVAL:
1970         if (!(PL_in_eval & EVAL_KEEPERR))
1971             clear_errsv = TRUE;
1972         POPEVAL(cx);
1973         retop = cx->blk_eval.retop;
1974         if (CxTRYBLOCK(cx))
1975             break;
1976         lex_end();
1977         if (optype == OP_REQUIRE &&
1978             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1979         {
1980             /* Unassume the success we assumed earlier. */
1981             SV *nsv = cx->blk_eval.old_namesv;
1982             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1983             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1984         }
1985         break;
1986     case CXt_FORMAT:
1987         POPFORMAT(cx);
1988         retop = cx->blk_sub.retop;
1989         break;
1990     default:
1991         DIE(aTHX_ "panic: return");
1992     }
1993
1994     TAINT_NOT;
1995     if (gimme == G_SCALAR) {
1996         if (MARK < SP) {
1997             if (popsub2) {
1998                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1999                     if (SvTEMP(TOPs)) {
2000                         *++newsp = SvREFCNT_inc(*SP);
2001                         FREETMPS;
2002                         sv_2mortal(*newsp);
2003                     }
2004                     else {
2005                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2006                         FREETMPS;
2007                         *++newsp = sv_mortalcopy(sv);
2008                         SvREFCNT_dec(sv);
2009                     }
2010                 }
2011                 else
2012                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2013             }
2014             else
2015                 *++newsp = sv_mortalcopy(*SP);
2016         }
2017         else
2018             *++newsp = &PL_sv_undef;
2019     }
2020     else if (gimme == G_ARRAY) {
2021         while (++MARK <= SP) {
2022             *++newsp = (popsub2 && SvTEMP(*MARK))
2023                         ? *MARK : sv_mortalcopy(*MARK);
2024             TAINT_NOT;          /* Each item is independent */
2025         }
2026     }
2027     PL_stack_sp = newsp;
2028
2029     LEAVE;
2030     /* Stack values are safe: */
2031     if (popsub2) {
2032         cxstack_ix--;
2033         POPSUB(cx,sv);  /* release CV and @_ ... */
2034     }
2035     else
2036         sv = Nullsv;
2037     PL_curpm = newpm;   /* ... and pop $1 et al */
2038
2039     LEAVESUB(sv);
2040     if (clear_errsv)
2041         sv_setpv(ERRSV,"");
2042     return retop;
2043 }
2044
2045 PP(pp_last)
2046 {
2047     dSP;
2048     I32 cxix;
2049     register PERL_CONTEXT *cx;
2050     I32 pop2 = 0;
2051     I32 gimme;
2052     I32 optype;
2053     OP *nextop;
2054     SV **newsp;
2055     PMOP *newpm;
2056     SV **mark;
2057     SV *sv = Nullsv;
2058
2059     if (PL_op->op_flags & OPf_SPECIAL) {
2060         cxix = dopoptoloop(cxstack_ix);
2061         if (cxix < 0)
2062             DIE(aTHX_ "Can't \"last\" outside a loop block");
2063     }
2064     else {
2065         cxix = dopoptolabel(cPVOP->op_pv);
2066         if (cxix < 0)
2067             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2068     }
2069     if (cxix < cxstack_ix)
2070         dounwind(cxix);
2071
2072     POPBLOCK(cx,newpm);
2073     cxstack_ix++; /* temporarily protect top context */
2074     mark = newsp;
2075     switch (CxTYPE(cx)) {
2076     case CXt_LOOP:
2077         pop2 = CXt_LOOP;
2078         newsp = PL_stack_base + cx->blk_loop.resetsp;
2079         nextop = cx->blk_loop.last_op->op_next;
2080         break;
2081     case CXt_SUB:
2082         pop2 = CXt_SUB;
2083         nextop = cx->blk_sub.retop;
2084         break;
2085     case CXt_EVAL:
2086         POPEVAL(cx);
2087         nextop = cx->blk_eval.retop;
2088         break;
2089     case CXt_FORMAT:
2090         POPFORMAT(cx);
2091         nextop = cx->blk_sub.retop;
2092         break;
2093     default:
2094         DIE(aTHX_ "panic: last");
2095     }
2096
2097     TAINT_NOT;
2098     if (gimme == G_SCALAR) {
2099         if (MARK < SP)
2100             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2101                         ? *SP : sv_mortalcopy(*SP);
2102         else
2103             *++newsp = &PL_sv_undef;
2104     }
2105     else if (gimme == G_ARRAY) {
2106         while (++MARK <= SP) {
2107             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2108                         ? *MARK : sv_mortalcopy(*MARK);
2109             TAINT_NOT;          /* Each item is independent */
2110         }
2111     }
2112     SP = newsp;
2113     PUTBACK;
2114
2115     LEAVE;
2116     cxstack_ix--;
2117     /* Stack values are safe: */
2118     switch (pop2) {
2119     case CXt_LOOP:
2120         POPLOOP(cx);    /* release loop vars ... */
2121         LEAVE;
2122         break;
2123     case CXt_SUB:
2124         POPSUB(cx,sv);  /* release CV and @_ ... */
2125         break;
2126     }
2127     PL_curpm = newpm;   /* ... and pop $1 et al */
2128
2129     LEAVESUB(sv);
2130     return nextop;
2131 }
2132
2133 PP(pp_next)
2134 {
2135     I32 cxix;
2136     register PERL_CONTEXT *cx;
2137     I32 inner;
2138
2139     if (PL_op->op_flags & OPf_SPECIAL) {
2140         cxix = dopoptoloop(cxstack_ix);
2141         if (cxix < 0)
2142             DIE(aTHX_ "Can't \"next\" outside a loop block");
2143     }
2144     else {
2145         cxix = dopoptolabel(cPVOP->op_pv);
2146         if (cxix < 0)
2147             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2148     }
2149     if (cxix < cxstack_ix)
2150         dounwind(cxix);
2151
2152     /* clear off anything above the scope we're re-entering, but
2153      * save the rest until after a possible continue block */
2154     inner = PL_scopestack_ix;
2155     TOPBLOCK(cx);
2156     if (PL_scopestack_ix < inner)
2157         leave_scope(PL_scopestack[PL_scopestack_ix]);
2158     return cx->blk_loop.next_op;
2159 }
2160
2161 PP(pp_redo)
2162 {
2163     I32 cxix;
2164     register PERL_CONTEXT *cx;
2165     I32 oldsave;
2166
2167     if (PL_op->op_flags & OPf_SPECIAL) {
2168         cxix = dopoptoloop(cxstack_ix);
2169         if (cxix < 0)
2170             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2171     }
2172     else {
2173         cxix = dopoptolabel(cPVOP->op_pv);
2174         if (cxix < 0)
2175             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2176     }
2177     if (cxix < cxstack_ix)
2178         dounwind(cxix);
2179
2180     TOPBLOCK(cx);
2181     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2182     LEAVE_SCOPE(oldsave);
2183     FREETMPS;
2184     return cx->blk_loop.redo_op;
2185 }
2186
2187 STATIC OP *
2188 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2189 {
2190     OP *kid = Nullop;
2191     OP **ops = opstack;
2192     static char too_deep[] = "Target of goto is too deeply nested";
2193
2194     if (ops >= oplimit)
2195         Perl_croak(aTHX_ too_deep);
2196     if (o->op_type == OP_LEAVE ||
2197         o->op_type == OP_SCOPE ||
2198         o->op_type == OP_LEAVELOOP ||
2199         o->op_type == OP_LEAVESUB ||
2200         o->op_type == OP_LEAVETRY)
2201     {
2202         *ops++ = cUNOPo->op_first;
2203         if (ops >= oplimit)
2204             Perl_croak(aTHX_ too_deep);
2205     }
2206     *ops = 0;
2207     if (o->op_flags & OPf_KIDS) {
2208         /* First try all the kids at this level, since that's likeliest. */
2209         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2210             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2211                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2212                 return kid;
2213         }
2214         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2215             if (kid == PL_lastgotoprobe)
2216                 continue;
2217             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2218                 if (ops == opstack)
2219                     *ops++ = kid;
2220                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2221                          ops[-1]->op_type == OP_DBSTATE)
2222                     ops[-1] = kid;
2223                 else
2224                     *ops++ = kid;
2225             }
2226             if ((o = dofindlabel(kid, label, ops, oplimit)))
2227                 return o;
2228         }
2229     }
2230     *ops = 0;
2231     return 0;
2232 }
2233
2234 PP(pp_dump)
2235 {
2236     return pp_goto();
2237     /*NOTREACHED*/
2238 }
2239
2240 PP(pp_goto)
2241 {
2242     dSP;
2243     OP *retop = 0;
2244     I32 ix;
2245     register PERL_CONTEXT *cx;
2246 #define GOTO_DEPTH 64
2247     OP *enterops[GOTO_DEPTH];
2248     char *label;
2249     int do_dump = (PL_op->op_type == OP_DUMP);
2250     static char must_have_label[] = "goto must have label";
2251     AV *oldav = Nullav;
2252
2253     label = 0;
2254     if (PL_op->op_flags & OPf_STACKED) {
2255         SV *sv = POPs;
2256         STRLEN n_a;
2257
2258         /* This egregious kludge implements goto &subroutine */
2259         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2260             I32 cxix;
2261             register PERL_CONTEXT *cx;
2262             CV* cv = (CV*)SvRV(sv);
2263             SV** mark;
2264             I32 items = 0;
2265             I32 oldsave;
2266
2267         retry:
2268             if (!CvROOT(cv) && !CvXSUB(cv)) {
2269                 GV *gv = CvGV(cv);
2270                 GV *autogv;
2271                 if (gv) {
2272                     SV *tmpstr;
2273                     /* autoloaded stub? */
2274                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2275                         goto retry;
2276                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2277                                           GvNAMELEN(gv), FALSE);
2278                     if (autogv && (cv = GvCV(autogv)))
2279                         goto retry;
2280                     tmpstr = sv_newmortal();
2281                     gv_efullname3(tmpstr, gv, Nullch);
2282                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2283                 }
2284                 DIE(aTHX_ "Goto undefined subroutine");
2285             }
2286
2287             /* First do some returnish stuff. */
2288             SvREFCNT_inc(cv); /* avoid premature free during unwind */
2289             FREETMPS;
2290             cxix = dopoptosub(cxstack_ix);
2291             if (cxix < 0)
2292                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2293             if (cxix < cxstack_ix)
2294                 dounwind(cxix);
2295             TOPBLOCK(cx);
2296             if (CxREALEVAL(cx))
2297                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2298             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2299                 /* put @_ back onto stack */
2300                 AV* av = cx->blk_sub.argarray;
2301
2302                 items = AvFILLp(av) + 1;
2303                 EXTEND(SP, items+1); /* @_ could have been extended. */
2304                 Copy(AvARRAY(av), SP + 1, items, SV*);
2305                 SvREFCNT_dec(GvAV(PL_defgv));
2306                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2307                 /* abandon @_ if it got reified */
2308                 if (AvREAL(av)) {
2309                     oldav = av; /* delay until return */
2310                     av = newAV();
2311                     av_extend(av, items-1);
2312                     AvFLAGS(av) = AVf_REIFY;
2313                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2314                 }
2315                 else
2316                     CLEAR_ARGARRAY(av);
2317             }
2318             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2319                 AV* av;
2320                 av = GvAV(PL_defgv);
2321                 items = AvFILLp(av) + 1;
2322                 EXTEND(SP, items+1); /* @_ could have been extended. */
2323                 Copy(AvARRAY(av), SP + 1, items, SV*);
2324             }
2325             mark = SP;
2326             SP += items;
2327             if (CxTYPE(cx) == CXt_SUB &&
2328                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2329                 SvREFCNT_dec(cx->blk_sub.cv);
2330             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2331             LEAVE_SCOPE(oldsave);
2332
2333             /* Now do some callish stuff. */
2334             SAVETMPS;
2335             /* For reified @_, delay freeing till return from new sub */
2336             if (oldav)
2337                 SAVEFREESV((SV*)oldav);
2338             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2339             if (CvXSUB(cv)) {
2340 #ifdef PERL_XSUB_OLDSTYLE
2341                 if (CvOLDSTYLE(cv)) {
2342                     I32 (*fp3)(int,int,int);
2343                     while (SP > mark) {
2344                         SP[1] = SP[0];
2345                         SP--;
2346                     }
2347                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2348                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2349                                    mark - PL_stack_base + 1,
2350                                    items);
2351                     SP = PL_stack_base + items;
2352                 }
2353                 else
2354 #endif /* PERL_XSUB_OLDSTYLE */
2355                 {
2356                     SV **newsp;
2357                     I32 gimme;
2358
2359                     /* Push a mark for the start of arglist */
2360                     PUSHMARK(mark);
2361                     PUTBACK;
2362                     (void)(*CvXSUB(cv))(aTHX_ cv);
2363                     /* Pop the current context like a decent sub should */
2364                     POPBLOCK(cx, PL_curpm);
2365                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2366                 }
2367                 LEAVE;
2368                 assert(CxTYPE(cx) == CXt_SUB);
2369                 return cx->blk_sub.retop;
2370             }
2371             else {
2372                 AV* padlist = CvPADLIST(cv);
2373                 if (CxTYPE(cx) == CXt_EVAL) {
2374                     PL_in_eval = cx->blk_eval.old_in_eval;
2375                     PL_eval_root = cx->blk_eval.old_eval_root;
2376                     cx->cx_type = CXt_SUB;
2377                     cx->blk_sub.hasargs = 0;
2378                 }
2379                 cx->blk_sub.cv = cv;
2380                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2381
2382                 CvDEPTH(cv)++;
2383                 if (CvDEPTH(cv) < 2)
2384                     (void)SvREFCNT_inc(cv);
2385                 else {
2386                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2387                         sub_crush_depth(cv);
2388                     pad_push(padlist, CvDEPTH(cv), 1);
2389                 }
2390                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2391                 if (cx->blk_sub.hasargs)
2392                 {
2393                     AV* av = (AV*)PAD_SVl(0);
2394                     SV** ary;
2395
2396                     cx->blk_sub.savearray = GvAV(PL_defgv);
2397                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2398                     CX_CURPAD_SAVE(cx->blk_sub);
2399                     cx->blk_sub.argarray = av;
2400
2401                     if (items >= AvMAX(av) + 1) {
2402                         ary = AvALLOC(av);
2403                         if (AvARRAY(av) != ary) {
2404                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2405                             SvPVX(av) = (char*)ary;
2406                         }
2407                         if (items >= AvMAX(av) + 1) {
2408                             AvMAX(av) = items - 1;
2409                             Renew(ary,items+1,SV*);
2410                             AvALLOC(av) = ary;
2411                             SvPVX(av) = (char*)ary;
2412                         }
2413                     }
2414                     ++mark;
2415                     Copy(mark,AvARRAY(av),items,SV*);
2416                     AvFILLp(av) = items - 1;
2417                     assert(!AvREAL(av));
2418                     while (items--) {
2419                         if (*mark)
2420                             SvTEMP_off(*mark);
2421                         mark++;
2422                     }
2423                 }
2424                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2425                     /*
2426                      * We do not care about using sv to call CV;
2427                      * it's for informational purposes only.
2428                      */
2429                     SV *sv = GvSV(PL_DBsub);
2430                     CV *gotocv;
2431
2432                     if (PERLDB_SUB_NN) {
2433                         (void)SvUPGRADE(sv, SVt_PVIV);
2434                         (void)SvIOK_on(sv);
2435                         SAVEIV(SvIVX(sv));
2436                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2437                     } else {
2438                         save_item(sv);
2439                         gv_efullname3(sv, CvGV(cv), Nullch);
2440                     }
2441                     if (  PERLDB_GOTO
2442                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2443                         PUSHMARK( PL_stack_sp );
2444                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2445                         PL_stack_sp--;
2446                     }
2447                 }
2448                 RETURNOP(CvSTART(cv));
2449             }
2450         }
2451         else {
2452             label = SvPV(sv,n_a);
2453             if (!(do_dump || *label))
2454                 DIE(aTHX_ must_have_label);
2455         }
2456     }
2457     else if (PL_op->op_flags & OPf_SPECIAL) {
2458         if (! do_dump)
2459             DIE(aTHX_ must_have_label);
2460     }
2461     else
2462         label = cPVOP->op_pv;
2463
2464     if (label && *label) {
2465         OP *gotoprobe = 0;
2466         bool leaving_eval = FALSE;
2467         bool in_block = FALSE;
2468         PERL_CONTEXT *last_eval_cx = 0;
2469
2470         /* find label */
2471
2472         PL_lastgotoprobe = 0;
2473         *enterops = 0;
2474         for (ix = cxstack_ix; ix >= 0; ix--) {
2475             cx = &cxstack[ix];
2476             switch (CxTYPE(cx)) {
2477             case CXt_EVAL:
2478                 leaving_eval = TRUE;
2479                 if (!CxTRYBLOCK(cx)) {
2480                     gotoprobe = (last_eval_cx ?
2481                                 last_eval_cx->blk_eval.old_eval_root :
2482                                 PL_eval_root);
2483                     last_eval_cx = cx;
2484                     break;
2485                 }
2486                 /* else fall through */
2487             case CXt_LOOP:
2488                 gotoprobe = cx->blk_oldcop->op_sibling;
2489                 break;
2490             case CXt_SUBST:
2491                 continue;
2492             case CXt_BLOCK:
2493                 if (ix) {
2494                     gotoprobe = cx->blk_oldcop->op_sibling;
2495                     in_block = TRUE;
2496                 } else
2497                     gotoprobe = PL_main_root;
2498                 break;
2499             case CXt_SUB:
2500                 if (CvDEPTH(cx->blk_sub.cv)) {
2501                     gotoprobe = CvROOT(cx->blk_sub.cv);
2502                     break;
2503                 }
2504                 /* FALL THROUGH */
2505             case CXt_FORMAT:
2506             case CXt_NULL:
2507                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2508             default:
2509                 if (ix)
2510                     DIE(aTHX_ "panic: goto");
2511                 gotoprobe = PL_main_root;
2512                 break;
2513             }
2514             if (gotoprobe) {
2515                 retop = dofindlabel(gotoprobe, label,
2516                                     enterops, enterops + GOTO_DEPTH);
2517                 if (retop)
2518                     break;
2519             }
2520             PL_lastgotoprobe = gotoprobe;
2521         }
2522         if (!retop)
2523             DIE(aTHX_ "Can't find label %s", label);
2524
2525         /* if we're leaving an eval, check before we pop any frames
2526            that we're not going to punt, otherwise the error
2527            won't be caught */
2528
2529         if (leaving_eval && *enterops && enterops[1]) {
2530             I32 i;
2531             for (i = 1; enterops[i]; i++)
2532                 if (enterops[i]->op_type == OP_ENTERITER)
2533                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2534         }
2535
2536         /* pop unwanted frames */
2537
2538         if (ix < cxstack_ix) {
2539             I32 oldsave;
2540
2541             if (ix < 0)
2542                 ix = 0;
2543             dounwind(ix);
2544             TOPBLOCK(cx);
2545             oldsave = PL_scopestack[PL_scopestack_ix];
2546             LEAVE_SCOPE(oldsave);
2547         }
2548
2549         /* push wanted frames */
2550
2551         if (*enterops && enterops[1]) {
2552             OP *oldop = PL_op;
2553             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2554             for (; enterops[ix]; ix++) {
2555                 PL_op = enterops[ix];
2556                 /* Eventually we may want to stack the needed arguments
2557                  * for each op.  For now, we punt on the hard ones. */
2558                 if (PL_op->op_type == OP_ENTERITER)
2559                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2560                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2561             }
2562             PL_op = oldop;
2563         }
2564     }
2565
2566     if (do_dump) {
2567 #ifdef VMS
2568         if (!retop) retop = PL_main_start;
2569 #endif
2570         PL_restartop = retop;
2571         PL_do_undump = TRUE;
2572
2573         my_unexec();
2574
2575         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2576         PL_do_undump = FALSE;
2577     }
2578
2579     RETURNOP(retop);
2580 }
2581
2582 PP(pp_exit)
2583 {
2584     dSP;
2585     I32 anum;
2586
2587     if (MAXARG < 1)
2588         anum = 0;
2589     else {
2590         anum = SvIVx(POPs);
2591 #ifdef VMS
2592         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2593             anum = 0;
2594         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2595 #endif
2596     }
2597     PL_exit_flags |= PERL_EXIT_EXPECTED;
2598     my_exit(anum);
2599     PUSHs(&PL_sv_undef);
2600     RETURN;
2601 }
2602
2603 #ifdef NOTYET
2604 PP(pp_nswitch)
2605 {
2606     dSP;
2607     NV value = SvNVx(GvSV(cCOP->cop_gv));
2608     register I32 match = I_32(value);
2609
2610     if (value < 0.0) {
2611         if (((NV)match) > value)
2612             --match;            /* was fractional--truncate other way */
2613     }
2614     match -= cCOP->uop.scop.scop_offset;
2615     if (match < 0)
2616         match = 0;
2617     else if (match > cCOP->uop.scop.scop_max)
2618         match = cCOP->uop.scop.scop_max;
2619     PL_op = cCOP->uop.scop.scop_next[match];
2620     RETURNOP(PL_op);
2621 }
2622
2623 PP(pp_cswitch)
2624 {
2625     dSP;
2626     register I32 match;
2627
2628     if (PL_multiline)
2629         PL_op = PL_op->op_next;                 /* can't assume anything */
2630     else {
2631         STRLEN n_a;
2632         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2633         match -= cCOP->uop.scop.scop_offset;
2634         if (match < 0)
2635             match = 0;
2636         else if (match > cCOP->uop.scop.scop_max)
2637             match = cCOP->uop.scop.scop_max;
2638         PL_op = cCOP->uop.scop.scop_next[match];
2639     }
2640     RETURNOP(PL_op);
2641 }
2642 #endif
2643
2644 /* Eval. */
2645
2646 STATIC void
2647 S_save_lines(pTHX_ AV *array, SV *sv)
2648 {
2649     register char *s = SvPVX(sv);
2650     register char *send = SvPVX(sv) + SvCUR(sv);
2651     register char *t;
2652     register I32 line = 1;
2653
2654     while (s && s < send) {
2655         SV *tmpstr = NEWSV(85,0);
2656
2657         sv_upgrade(tmpstr, SVt_PVMG);
2658         t = strchr(s, '\n');
2659         if (t)
2660             t++;
2661         else
2662             t = send;
2663
2664         sv_setpvn(tmpstr, s, t - s);
2665         av_store(array, line++, tmpstr);
2666         s = t;
2667     }
2668 }
2669
2670 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2671 STATIC void *
2672 S_docatch_body(pTHX_ va_list args)
2673 {
2674     return docatch_body();
2675 }
2676 #endif
2677
2678 STATIC void *
2679 S_docatch_body(pTHX)
2680 {
2681     CALLRUNOPS(aTHX);
2682     return NULL;
2683 }
2684
2685 STATIC OP *
2686 S_docatch(pTHX_ OP *o)
2687 {
2688     int ret;
2689     OP *oldop = PL_op;
2690     OP *retop;
2691     volatile PERL_SI *cursi = PL_curstackinfo;
2692     dJMPENV;
2693
2694 #ifdef DEBUGGING
2695     assert(CATCH_GET == TRUE);
2696 #endif
2697     PL_op = o;
2698
2699     /* Normally, the leavetry at the end of this block of ops will
2700      * pop an op off the return stack and continue there. By setting
2701      * the op to Nullop, we force an exit from the inner runops()
2702      * loop. DAPM.
2703      */
2704     assert(cxstack_ix >= 0);
2705     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2706     retop = cxstack[cxstack_ix].blk_eval.retop;
2707     cxstack[cxstack_ix].blk_eval.retop = Nullop;
2708
2709 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2710  redo_body:
2711     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2712 #else
2713     JMPENV_PUSH(ret);
2714 #endif
2715     switch (ret) {
2716     case 0:
2717 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2718  redo_body:
2719         docatch_body();
2720 #endif
2721         break;
2722     case 3:
2723         /* die caught by an inner eval - continue inner loop */
2724         if (PL_restartop && cursi == PL_curstackinfo) {
2725             PL_op = PL_restartop;
2726             PL_restartop = 0;
2727             goto redo_body;
2728         }
2729         /* a die in this eval - continue in outer loop */
2730         if (!PL_restartop)
2731             break;
2732         /* FALL THROUGH */
2733     default:
2734         JMPENV_POP;
2735         PL_op = oldop;
2736         JMPENV_JUMP(ret);
2737         /* NOTREACHED */
2738     }
2739     JMPENV_POP;
2740     PL_op = oldop;
2741     return retop;
2742 }
2743
2744 OP *
2745 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2746 /* sv Text to convert to OP tree. */
2747 /* startop op_free() this to undo. */
2748 /* code Short string id of the caller. */
2749 {
2750     dSP;                                /* Make POPBLOCK work. */
2751     PERL_CONTEXT *cx;
2752     SV **newsp;
2753     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2754     I32 optype;
2755     OP dummy;
2756     OP *rop;
2757     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2758     char *tmpbuf = tbuf;
2759     char *safestr;
2760     int runtime;
2761     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2762
2763     ENTER;
2764     lex_start(sv);
2765     SAVETMPS;
2766     /* switch to eval mode */
2767
2768     if (IN_PERL_COMPILETIME) {
2769         SAVECOPSTASH_FREE(&PL_compiling);
2770         CopSTASH_set(&PL_compiling, PL_curstash);
2771     }
2772     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2773         SV *sv = sv_newmortal();
2774         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2775                        code, (unsigned long)++PL_evalseq,
2776                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2777         tmpbuf = SvPVX(sv);
2778     }
2779     else
2780         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2781     SAVECOPFILE_FREE(&PL_compiling);
2782     CopFILE_set(&PL_compiling, tmpbuf+2);
2783     SAVECOPLINE(&PL_compiling);
2784     CopLINE_set(&PL_compiling, 1);
2785     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2786        deleting the eval's FILEGV from the stash before gv_check() runs
2787        (i.e. before run-time proper). To work around the coredump that
2788        ensues, we always turn GvMULTI_on for any globals that were
2789        introduced within evals. See force_ident(). GSAR 96-10-12 */
2790     safestr = savepv(tmpbuf);
2791     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2792     SAVEHINTS();
2793 #ifdef OP_IN_REGISTER
2794     PL_opsave = op;
2795 #else
2796     SAVEVPTR(PL_op);
2797 #endif
2798
2799     /* we get here either during compilation, or via pp_regcomp at runtime */
2800     runtime = IN_PERL_RUNTIME;
2801     if (runtime)
2802         runcv = find_runcv(NULL);
2803
2804     PL_op = &dummy;
2805     PL_op->op_type = OP_ENTEREVAL;
2806     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2807     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2808     PUSHEVAL(cx, 0, Nullgv);
2809
2810     if (runtime)
2811         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2812     else
2813         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2814     POPBLOCK(cx,PL_curpm);
2815     POPEVAL(cx);
2816
2817     (*startop)->op_type = OP_NULL;
2818     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2819     lex_end();
2820     /* XXX DAPM do this properly one year */
2821     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2822     LEAVE;
2823     if (IN_PERL_COMPILETIME)
2824         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2825 #ifdef OP_IN_REGISTER
2826     op = PL_opsave;
2827 #endif
2828     return rop;
2829 }
2830
2831
2832 /*
2833 =for apidoc find_runcv
2834
2835 Locate the CV corresponding to the currently executing sub or eval.
2836 If db_seqp is non_null, skip CVs that are in the DB package and populate
2837 *db_seqp with the cop sequence number at the point that the DB:: code was
2838 entered. (allows debuggers to eval in the scope of the breakpoint rather
2839 than in in the scope of the debugger itself).
2840
2841 =cut
2842 */
2843
2844 CV*
2845 Perl_find_runcv(pTHX_ U32 *db_seqp)
2846 {
2847     I32          ix;
2848     PERL_SI      *si;
2849     PERL_CONTEXT *cx;
2850
2851     if (db_seqp)
2852         *db_seqp = PL_curcop->cop_seq;
2853     for (si = PL_curstackinfo; si; si = si->si_prev) {
2854         for (ix = si->si_cxix; ix >= 0; ix--) {
2855             cx = &(si->si_cxstack[ix]);
2856             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2857                 CV *cv = cx->blk_sub.cv;
2858                 /* skip DB:: code */
2859                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2860                     *db_seqp = cx->blk_oldcop->cop_seq;
2861                     continue;
2862                 }
2863                 return cv;
2864             }
2865             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2866                 return PL_compcv;
2867         }
2868     }
2869     return PL_main_cv;
2870 }
2871
2872
2873 /* Compile a require/do, an eval '', or a /(?{...})/.
2874  * In the last case, startop is non-null, and contains the address of
2875  * a pointer that should be set to the just-compiled code.
2876  * outside is the lexically enclosing CV (if any) that invoked us.
2877  */
2878
2879 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2880 STATIC OP *
2881 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2882 {
2883     dSP;
2884     OP *saveop = PL_op;
2885
2886     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2887                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2888                   : EVAL_INEVAL);
2889
2890     PUSHMARK(SP);
2891
2892     SAVESPTR(PL_compcv);
2893     PL_compcv = (CV*)NEWSV(1104,0);
2894     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2895     CvEVAL_on(PL_compcv);
2896     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2897     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2898
2899     CvOUTSIDE_SEQ(PL_compcv) = seq;
2900     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2901
2902     /* set up a scratch pad */
2903
2904     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2905
2906
2907     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2908
2909     /* make sure we compile in the right package */
2910
2911     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2912         SAVESPTR(PL_curstash);
2913         PL_curstash = CopSTASH(PL_curcop);
2914     }
2915     SAVESPTR(PL_beginav);
2916     PL_beginav = newAV();
2917     SAVEFREESV(PL_beginav);
2918     SAVEI32(PL_error_count);
2919
2920     /* try to compile it */
2921
2922     PL_eval_root = Nullop;
2923     PL_error_count = 0;
2924     PL_curcop = &PL_compiling;
2925     PL_curcop->cop_arybase = 0;
2926     if (saveop && saveop->op_flags & OPf_SPECIAL)
2927         PL_in_eval |= EVAL_KEEPERR;
2928     else
2929         sv_setpv(ERRSV,"");
2930     if (yyparse() || PL_error_count || !PL_eval_root) {
2931         SV **newsp;                     /* Used by POPBLOCK. */
2932        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2933         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2934         STRLEN n_a;
2935
2936         PL_op = saveop;
2937         if (PL_eval_root) {
2938             op_free(PL_eval_root);
2939             PL_eval_root = Nullop;
2940         }
2941         SP = PL_stack_base + POPMARK;           /* pop original mark */
2942         if (!startop) {
2943             POPBLOCK(cx,PL_curpm);
2944             POPEVAL(cx);
2945         }
2946         lex_end();
2947         LEAVE;
2948         if (optype == OP_REQUIRE) {
2949             char* msg = SvPVx(ERRSV, n_a);
2950            SV *nsv = cx->blk_eval.old_namesv;
2951            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2952                           &PL_sv_undef, 0);
2953             DIE(aTHX_ "%sCompilation failed in require",
2954                 *msg ? msg : "Unknown error\n");
2955         }
2956         else if (startop) {
2957             char* msg = SvPVx(ERRSV, n_a);
2958
2959             POPBLOCK(cx,PL_curpm);
2960             POPEVAL(cx);
2961             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2962                        (*msg ? msg : "Unknown error\n"));
2963         }
2964         else {
2965             char* msg = SvPVx(ERRSV, n_a);
2966             if (!*msg) {
2967                 sv_setpv(ERRSV, "Compilation error");
2968             }
2969         }
2970         RETPUSHUNDEF;
2971     }
2972     CopLINE_set(&PL_compiling, 0);
2973     if (startop) {
2974         *startop = PL_eval_root;
2975     } else
2976         SAVEFREEOP(PL_eval_root);
2977
2978     /* Set the context for this new optree.
2979      * If the last op is an OP_REQUIRE, force scalar context.
2980      * Otherwise, propagate the context from the eval(). */
2981     if (PL_eval_root->op_type == OP_LEAVEEVAL
2982             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2983             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2984             == OP_REQUIRE)
2985         scalar(PL_eval_root);
2986     else if (gimme & G_VOID)
2987         scalarvoid(PL_eval_root);
2988     else if (gimme & G_ARRAY)
2989         list(PL_eval_root);
2990     else
2991         scalar(PL_eval_root);
2992
2993     DEBUG_x(dump_eval());
2994
2995     /* Register with debugger: */
2996     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2997         CV *cv = get_cv("DB::postponed", FALSE);
2998         if (cv) {
2999             dSP;
3000             PUSHMARK(SP);
3001             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3002             PUTBACK;
3003             call_sv((SV*)cv, G_DISCARD);
3004         }
3005     }
3006
3007     /* compiled okay, so do it */
3008
3009     CvDEPTH(PL_compcv) = 1;
3010     SP = PL_stack_base + POPMARK;               /* pop original mark */
3011     PL_op = saveop;                     /* The caller may need it. */
3012     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3013
3014     RETURNOP(PL_eval_start);
3015 }
3016
3017 STATIC PerlIO *
3018 S_doopen_pm(pTHX_ const char *name, const char *mode)
3019 {
3020 #ifndef PERL_DISABLE_PMC
3021     STRLEN namelen = strlen(name);
3022     PerlIO *fp;
3023
3024     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3025         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3026         char *pmc = SvPV_nolen(pmcsv);
3027         Stat_t pmstat;
3028         Stat_t pmcstat;
3029         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3030             fp = PerlIO_open(name, mode);
3031         }
3032         else {
3033             if (PerlLIO_stat(name, &pmstat) < 0 ||
3034                 pmstat.st_mtime < pmcstat.st_mtime)
3035             {
3036                 fp = PerlIO_open(pmc, mode);
3037             }
3038             else {
3039                 fp = PerlIO_open(name, mode);
3040             }
3041         }
3042         SvREFCNT_dec(pmcsv);
3043     }
3044     else {
3045         fp = PerlIO_open(name, mode);
3046     }
3047     return fp;
3048 #else
3049     return PerlIO_open(name, mode);
3050 #endif /* !PERL_DISABLE_PMC */
3051 }
3052
3053 PP(pp_require)
3054 {
3055     dSP;
3056     register PERL_CONTEXT *cx;
3057     SV *sv;
3058     char *name;
3059     STRLEN len;
3060     char *tryname = Nullch;
3061     SV *namesv = Nullsv;
3062     SV** svp;
3063     I32 gimme = GIMME_V;
3064     PerlIO *tryrsfp = 0;
3065     STRLEN n_a;
3066     int filter_has_file = 0;
3067     GV *filter_child_proc = 0;
3068     SV *filter_state = 0;
3069     SV *filter_sub = 0;
3070     SV *hook_sv = 0;
3071     SV *encoding;
3072     OP *op;
3073
3074     sv = POPs;
3075     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3076         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3077                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3078                         "v-string in use/require non-portable");
3079
3080         sv = new_version(sv);
3081         if (!sv_derived_from(PL_patchlevel, "version"))
3082             (void *)upg_version(PL_patchlevel);
3083         if ( vcmp(sv,PL_patchlevel) > 0 )
3084             DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
3085                 vstringify(sv), vstringify(PL_patchlevel));
3086
3087             RETPUSHYES;
3088     }
3089     name = SvPV(sv, len);
3090     if (!(name && len > 0 && *name))
3091         DIE(aTHX_ "Null filename used");
3092     TAINT_PROPER("require");
3093     if (PL_op->op_type == OP_REQUIRE &&
3094        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3095        if (*svp != &PL_sv_undef)
3096            RETPUSHYES;
3097        else
3098            DIE(aTHX_ "Compilation failed in require");
3099     }
3100
3101     /* prepare to compile file */
3102
3103     if (path_is_absolute(name)) {
3104         tryname = name;
3105         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3106     }
3107 #ifdef MACOS_TRADITIONAL
3108     if (!tryrsfp) {
3109         char newname[256];
3110
3111         MacPerl_CanonDir(name, newname, 1);
3112         if (path_is_absolute(newname)) {
3113             tryname = newname;
3114             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3115         }
3116     }
3117 #endif
3118     if (!tryrsfp) {
3119         AV *ar = GvAVn(PL_incgv);
3120         I32 i;
3121 #ifdef VMS
3122         char *unixname;
3123         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3124 #endif
3125         {
3126             namesv = NEWSV(806, 0);
3127             for (i = 0; i <= AvFILL(ar); i++) {
3128                 SV *dirsv = *av_fetch(ar, i, TRUE);
3129
3130                 if (SvROK(dirsv)) {
3131                     int count;
3132                     SV *loader = dirsv;
3133
3134                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3135                         && !sv_isobject(loader))
3136                     {
3137                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3138                     }
3139
3140                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3141                                    PTR2UV(SvRV(dirsv)), name);
3142                     tryname = SvPVX(namesv);
3143                     tryrsfp = 0;
3144
3145                     ENTER;
3146                     SAVETMPS;
3147                     EXTEND(SP, 2);
3148
3149                     PUSHMARK(SP);
3150                     PUSHs(dirsv);
3151                     PUSHs(sv);
3152                     PUTBACK;
3153                     if (sv_isobject(loader))
3154                         count = call_method("INC", G_ARRAY);
3155                     else
3156                         count = call_sv(loader, G_ARRAY);
3157                     SPAGAIN;
3158
3159                     if (count > 0) {
3160                         int i = 0;
3161                         SV *arg;
3162
3163                         SP -= count - 1;
3164                         arg = SP[i++];
3165
3166                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3167                             arg = SvRV(arg);
3168                         }
3169
3170                         if (SvTYPE(arg) == SVt_PVGV) {
3171                             IO *io = GvIO((GV *)arg);
3172
3173                             ++filter_has_file;
3174
3175                             if (io) {
3176                                 tryrsfp = IoIFP(io);
3177                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3178                                     /* reading from a child process doesn't
3179                                        nest -- when returning from reading
3180                                        the inner module, the outer one is
3181                                        unreadable (closed?)  I've tried to
3182                                        save the gv to manage the lifespan of
3183                                        the pipe, but this didn't help. XXX */
3184                                     filter_child_proc = (GV *)arg;
3185                                     (void)SvREFCNT_inc(filter_child_proc);
3186                                 }
3187                                 else {
3188                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3189                                         PerlIO_close(IoOFP(io));
3190                                     }
3191                                     IoIFP(io) = Nullfp;
3192                                     IoOFP(io) = Nullfp;
3193                                 }
3194                             }
3195
3196                             if (i < count) {
3197                                 arg = SP[i++];
3198                             }
3199                         }
3200
3201                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3202                             filter_sub = arg;
3203                             (void)SvREFCNT_inc(filter_sub);
3204
3205                             if (i < count) {
3206                                 filter_state = SP[i];
3207                                 (void)SvREFCNT_inc(filter_state);
3208                             }
3209
3210                             if (tryrsfp == 0) {
3211                                 tryrsfp = PerlIO_open("/dev/null",
3212                                                       PERL_SCRIPT_MODE);
3213                             }
3214                         }
3215                         SP--;
3216                     }
3217
3218                     PUTBACK;
3219                     FREETMPS;
3220                     LEAVE;
3221
3222                     if (tryrsfp) {
3223                         hook_sv = dirsv;
3224                         break;
3225                     }
3226
3227                     filter_has_file = 0;
3228                     if (filter_child_proc) {
3229                         SvREFCNT_dec(filter_child_proc);
3230                         filter_child_proc = 0;
3231                     }
3232                     if (filter_state) {
3233                         SvREFCNT_dec(filter_state);
3234                         filter_state = 0;
3235                     }
3236                     if (filter_sub) {
3237                         SvREFCNT_dec(filter_sub);
3238                         filter_sub = 0;
3239                     }
3240                 }
3241                 else {
3242                   if (!path_is_absolute(name)
3243 #ifdef MACOS_TRADITIONAL
3244                         /* We consider paths of the form :a:b ambiguous and interpret them first
3245                            as global then as local
3246                         */
3247                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3248 #endif
3249                   ) {
3250                     char *dir = SvPVx(dirsv, n_a);
3251 #ifdef MACOS_TRADITIONAL
3252                     char buf1[256];
3253                     char buf2[256];
3254
3255                     MacPerl_CanonDir(name, buf2, 1);
3256                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3257 #else
3258 #ifdef VMS
3259                     char *unixdir;
3260                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3261                         continue;
3262                     sv_setpv(namesv, unixdir);
3263                     sv_catpv(namesv, unixname);
3264 #else
3265                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3266 #endif
3267 #endif
3268                     TAINT_PROPER("require");
3269                     tryname = SvPVX(namesv);
3270                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3271                     if (tryrsfp) {
3272                         if (tryname[0] == '.' && tryname[1] == '/')
3273                             tryname += 2;
3274                         break;
3275                     }
3276                   }
3277                 }
3278             }
3279         }
3280     }
3281     SAVECOPFILE_FREE(&PL_compiling);
3282     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3283     SvREFCNT_dec(namesv);
3284     if (!tryrsfp) {
3285         if (PL_op->op_type == OP_REQUIRE) {
3286             char *msgstr = name;
3287             if (namesv) {                       /* did we lookup @INC? */
3288                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3289                 SV *dirmsgsv = NEWSV(0, 0);
3290                 AV *ar = GvAVn(PL_incgv);
3291                 I32 i;
3292                 sv_catpvn(msg, " in @INC", 8);
3293                 if (instr(SvPVX(msg), ".h "))
3294                     sv_catpv(msg, " (change .h to .ph maybe?)");
3295                 if (instr(SvPVX(msg), ".ph "))
3296                     sv_catpv(msg, " (did you run h2ph?)");
3297                 sv_catpv(msg, " (@INC contains:");
3298                 for (i = 0; i <= AvFILL(ar); i++) {
3299                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3300                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3301                     sv_catsv(msg, dirmsgsv);
3302                 }
3303                 sv_catpvn(msg, ")", 1);
3304                 SvREFCNT_dec(dirmsgsv);
3305                 msgstr = SvPV_nolen(msg);
3306             }
3307             DIE(aTHX_ "Can't locate %s", msgstr);
3308         }
3309
3310         RETPUSHUNDEF;
3311     }
3312     else
3313         SETERRNO(0, SS_NORMAL);
3314
3315     /* Assume success here to prevent recursive requirement. */
3316     len = strlen(name);
3317     /* Check whether a hook in @INC has already filled %INC */
3318     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3319         (void)hv_store(GvHVn(PL_incgv), name, len,
3320                        (hook_sv ? SvREFCNT_inc(hook_sv)
3321                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3322                        0 );
3323     }
3324
3325     ENTER;
3326     SAVETMPS;
3327     lex_start(sv_2mortal(newSVpvn("",0)));
3328     SAVEGENERICSV(PL_rsfp_filters);
3329     PL_rsfp_filters = Nullav;
3330
3331     PL_rsfp = tryrsfp;
3332     SAVEHINTS();
3333     PL_hints = 0;
3334     SAVESPTR(PL_compiling.cop_warnings);
3335     if (PL_dowarn & G_WARN_ALL_ON)
3336         PL_compiling.cop_warnings = pWARN_ALL ;
3337     else if (PL_dowarn & G_WARN_ALL_OFF)
3338         PL_compiling.cop_warnings = pWARN_NONE ;
3339     else if (PL_taint_warn)
3340         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3341     else
3342         PL_compiling.cop_warnings = pWARN_STD ;
3343     SAVESPTR(PL_compiling.cop_io);
3344     PL_compiling.cop_io = Nullsv;
3345
3346     if (filter_sub || filter_child_proc) {
3347         SV *datasv = filter_add(run_user_filter, Nullsv);
3348         IoLINES(datasv) = filter_has_file;
3349         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3350         IoTOP_GV(datasv) = (GV *)filter_state;
3351         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3352     }
3353
3354     /* switch to eval mode */
3355     PUSHBLOCK(cx, CXt_EVAL, SP);
3356     PUSHEVAL(cx, name, Nullgv);
3357     cx->blk_eval.retop = PL_op->op_next;
3358
3359     SAVECOPLINE(&PL_compiling);
3360     CopLINE_set(&PL_compiling, 0);
3361
3362     PUTBACK;
3363
3364     /* Store and reset encoding. */
3365     encoding = PL_encoding;
3366     PL_encoding = Nullsv;
3367
3368     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3369
3370     /* Restore encoding. */
3371     PL_encoding = encoding;
3372
3373     return op;
3374 }
3375
3376 PP(pp_dofile)
3377 {
3378     return pp_require();
3379 }
3380
3381 PP(pp_entereval)
3382 {
3383     dSP;
3384     register PERL_CONTEXT *cx;
3385     dPOPss;
3386     I32 gimme = GIMME_V, was = PL_sub_generation;
3387     char tbuf[TYPE_DIGITS(long) + 12];
3388     char *tmpbuf = tbuf;
3389     char *safestr;
3390     STRLEN len;
3391     OP *ret;
3392     CV* runcv;
3393     U32 seq;
3394
3395     if (!SvPV(sv,len))
3396         RETPUSHUNDEF;
3397     TAINT_PROPER("eval");
3398
3399     ENTER;
3400     lex_start(sv);
3401     SAVETMPS;
3402
3403     /* switch to eval mode */
3404
3405     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3406         SV *sv = sv_newmortal();
3407         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3408                        (unsigned long)++PL_evalseq,
3409                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3410         tmpbuf = SvPVX(sv);
3411     }
3412     else
3413         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3414     SAVECOPFILE_FREE(&PL_compiling);
3415     CopFILE_set(&PL_compiling, tmpbuf+2);
3416     SAVECOPLINE(&PL_compiling);
3417     CopLINE_set(&PL_compiling, 1);
3418     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3419        deleting the eval's FILEGV from the stash before gv_check() runs
3420        (i.e. before run-time proper). To work around the coredump that
3421        ensues, we always turn GvMULTI_on for any globals that were
3422        introduced within evals. See force_ident(). GSAR 96-10-12 */
3423     safestr = savepv(tmpbuf);
3424     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3425     SAVEHINTS();
3426     PL_hints = PL_op->op_targ;
3427     SAVESPTR(PL_compiling.cop_warnings);
3428     if (specialWARN(PL_curcop->cop_warnings))
3429         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3430     else {
3431         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3432         SAVEFREESV(PL_compiling.cop_warnings);
3433     }
3434     SAVESPTR(PL_compiling.cop_io);
3435     if (specialCopIO(PL_curcop->cop_io))
3436         PL_compiling.cop_io = PL_curcop->cop_io;
3437     else {
3438         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3439         SAVEFREESV(PL_compiling.cop_io);
3440     }
3441     /* special case: an eval '' executed within the DB package gets lexically
3442      * placed in the first non-DB CV rather than the current CV - this
3443      * allows the debugger to execute code, find lexicals etc, in the
3444      * scope of the code being debugged. Passing &seq gets find_runcv
3445      * to do the dirty work for us */
3446     runcv = find_runcv(&seq);
3447
3448     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3449     PUSHEVAL(cx, 0, Nullgv);
3450     cx->blk_eval.retop = PL_op->op_next;
3451
3452     /* prepare to compile string */
3453
3454     if (PERLDB_LINE && PL_curstash != PL_debstash)
3455         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3456     PUTBACK;
3457     ret = doeval(gimme, NULL, runcv, seq);
3458     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3459         && ret != PL_op->op_next) {     /* Successive compilation. */
3460         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3461     }
3462     return DOCATCH(ret);
3463 }
3464
3465 PP(pp_leaveeval)
3466 {
3467     dSP;
3468     register SV **mark;
3469     SV **newsp;
3470     PMOP *newpm;
3471     I32 gimme;
3472     register PERL_CONTEXT *cx;
3473     OP *retop;
3474     U8 save_flags = PL_op -> op_flags;
3475     I32 optype;
3476
3477     POPBLOCK(cx,newpm);
3478     POPEVAL(cx);
3479     retop = cx->blk_eval.retop;
3480
3481     TAINT_NOT;
3482     if (gimme == G_VOID)
3483         MARK = newsp;
3484     else if (gimme == G_SCALAR) {
3485         MARK = newsp + 1;
3486         if (MARK <= SP) {
3487             if (SvFLAGS(TOPs) & SVs_TEMP)
3488                 *MARK = TOPs;
3489             else
3490                 *MARK = sv_mortalcopy(TOPs);
3491         }
3492         else {
3493             MEXTEND(mark,0);
3494             *MARK = &PL_sv_undef;
3495         }
3496         SP = MARK;
3497     }
3498     else {
3499         /* in case LEAVE wipes old return values */
3500         for (mark = newsp + 1; mark <= SP; mark++) {
3501             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3502                 *mark = sv_mortalcopy(*mark);
3503                 TAINT_NOT;      /* Each item is independent */
3504             }
3505         }
3506     }
3507     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3508
3509 #ifdef DEBUGGING
3510     assert(CvDEPTH(PL_compcv) == 1);
3511 #endif
3512     CvDEPTH(PL_compcv) = 0;
3513     lex_end();
3514
3515     if (optype == OP_REQUIRE &&
3516         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3517     {
3518         /* Unassume the success we assumed earlier. */
3519         SV *nsv = cx->blk_eval.old_namesv;
3520         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3521         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3522         /* die_where() did LEAVE, or we won't be here */
3523     }
3524     else {
3525         LEAVE;
3526         if (!(save_flags & OPf_SPECIAL))
3527             sv_setpv(ERRSV,"");
3528     }
3529
3530     RETURNOP(retop);
3531 }
3532
3533 PP(pp_entertry)
3534 {
3535     dSP;
3536     register PERL_CONTEXT *cx;
3537     I32 gimme = GIMME_V;
3538
3539     ENTER;
3540     SAVETMPS;
3541
3542     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3543     PUSHEVAL(cx, 0, 0);
3544     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3545
3546     PL_in_eval = EVAL_INEVAL;
3547     sv_setpv(ERRSV,"");
3548     PUTBACK;
3549     return DOCATCH(PL_op->op_next);
3550 }
3551
3552 PP(pp_leavetry)
3553 {
3554     dSP;
3555     register SV **mark;
3556     SV **newsp;
3557     PMOP *newpm;
3558     OP* retop;
3559     I32 gimme;
3560     register PERL_CONTEXT *cx;
3561     I32 optype;
3562
3563     POPBLOCK(cx,newpm);
3564     POPEVAL(cx);
3565     retop = cx->blk_eval.retop;
3566
3567     TAINT_NOT;
3568     if (gimme == G_VOID)
3569         SP = newsp;
3570     else if (gimme == G_SCALAR) {
3571         MARK = newsp + 1;
3572         if (MARK <= SP) {
3573             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3574                 *MARK = TOPs;
3575             else
3576                 *MARK = sv_mortalcopy(TOPs);
3577         }
3578         else {
3579             MEXTEND(mark,0);
3580             *MARK = &PL_sv_undef;
3581         }
3582         SP = MARK;
3583     }
3584     else {
3585         /* in case LEAVE wipes old return values */
3586         for (mark = newsp + 1; mark <= SP; mark++) {
3587             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3588                 *mark = sv_mortalcopy(*mark);
3589                 TAINT_NOT;      /* Each item is independent */
3590             }
3591         }
3592     }
3593     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3594
3595     LEAVE;
3596     sv_setpv(ERRSV,"");
3597     RETURNOP(retop);
3598 }
3599
3600 STATIC OP *
3601 S_doparseform(pTHX_ SV *sv)
3602 {
3603     STRLEN len;
3604     register char *s = SvPV_force(sv, len);
3605     register char *send = s + len;
3606     register char *base = Nullch;
3607     register I32 skipspaces = 0;
3608     bool noblank   = FALSE;
3609     bool repeat    = FALSE;
3610     bool postspace = FALSE;
3611     U32 *fops;
3612     register U32 *fpc;
3613     U32 *linepc = 0;
3614     register I32 arg;
3615     bool ischop;
3616     bool unchopnum = FALSE;
3617     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3618
3619     if (len == 0)
3620         Perl_croak(aTHX_ "Null picture in formline");
3621
3622     /* estimate the buffer size needed */
3623     for (base = s; s <= send; s++) {
3624         if (*s == '\n' || *s == '@' || *s == '^')
3625             maxops += 10;
3626     }
3627     s = base;
3628     base = Nullch;
3629
3630     New(804, fops, maxops, U32);
3631     fpc = fops;
3632
3633     if (s < send) {
3634         linepc = fpc;
3635         *fpc++ = FF_LINEMARK;
3636         noblank = repeat = FALSE;
3637         base = s;
3638     }
3639
3640     while (s <= send) {
3641         switch (*s++) {
3642         default:
3643             skipspaces = 0;
3644             continue;
3645
3646         case '~':
3647             if (*s == '~') {
3648                 repeat = TRUE;
3649                 *s = ' ';
3650             }
3651             noblank = TRUE;
3652             s[-1] = ' ';
3653             /* FALL THROUGH */
3654         case ' ': case '\t':
3655             skipspaces++;
3656             continue;
3657         case 0:
3658             if (s < send) {
3659                 skipspaces = 0;
3660                 continue;
3661             } /* else FALL THROUGH */
3662         case '\n':
3663             arg = s - base;
3664             skipspaces++;
3665             arg -= skipspaces;
3666             if (arg) {
3667                 if (postspace)
3668                     *fpc++ = FF_SPACE;
3669                 *fpc++ = FF_LITERAL;
3670                 *fpc++ = (U16)arg;
3671             }
3672             postspace = FALSE;
3673             if (s <= send)
3674                 skipspaces--;
3675             if (skipspaces) {
3676                 *fpc++ = FF_SKIP;
3677                 *fpc++ = (U16)skipspaces;
3678             }
3679             skipspaces = 0;
3680             if (s <= send)
3681                 *fpc++ = FF_NEWLINE;
3682             if (noblank) {
3683                 *fpc++ = FF_BLANK;
3684                 if (repeat)
3685                     arg = fpc - linepc + 1;
3686                 else
3687                     arg = 0;
3688                 *fpc++ = (U16)arg;
3689             }
3690             if (s < send) {
3691                 linepc = fpc;
3692                 *fpc++ = FF_LINEMARK;
3693                 noblank = repeat = FALSE;
3694                 base = s;
3695             }
3696             else
3697                 s++;
3698             continue;
3699
3700         case '@':
3701         case '^':
3702             ischop = s[-1] == '^';
3703
3704             if (postspace) {
3705                 *fpc++ = FF_SPACE;
3706                 postspace = FALSE;
3707             }
3708             arg = (s - base) - 1;
3709             if (arg) {
3710                 *fpc++ = FF_LITERAL;
3711                 *fpc++ = (U16)arg;
3712             }
3713
3714             base = s - 1;
3715             *fpc++ = FF_FETCH;
3716             if (*s == '*') {
3717                 s++;
3718                 *fpc++ = 2;  /* skip the @* or ^* */
3719                 if (ischop) {
3720                     *fpc++ = FF_LINESNGL;
3721                     *fpc++ = FF_CHOP;
3722                 } else
3723                     *fpc++ = FF_LINEGLOB;
3724             }
3725             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3726                 arg = ischop ? 512 : 0;
3727                 base = s - 1;
3728                 while (*s == '#')
3729                     s++;
3730                 if (*s == '.') {
3731                     char *f;
3732                     s++;
3733                     f = s;
3734                     while (*s == '#')
3735                         s++;
3736                     arg |= 256 + (s - f);
3737                 }
3738                 *fpc++ = s - base;              /* fieldsize for FETCH */
3739                 *fpc++ = FF_DECIMAL;
3740                 *fpc++ = (U16)arg;
3741                 unchopnum |= ! ischop;
3742             }
3743             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3744                 arg = ischop ? 512 : 0;
3745                 base = s - 1;
3746                 s++;                                /* skip the '0' first */
3747                 while (*s == '#')
3748                     s++;
3749                 if (*s == '.') {
3750                     char *f;
3751                     s++;
3752                     f = s;
3753                     while (*s == '#')
3754                         s++;
3755                     arg |= 256 + (s - f);
3756                 }
3757                 *fpc++ = s - base;                /* fieldsize for FETCH */
3758                 *fpc++ = FF_0DECIMAL;
3759                 *fpc++ = (U16)arg;
3760                 unchopnum |= ! ischop;
3761             }
3762             else {
3763                 I32 prespace = 0;
3764                 bool ismore = FALSE;
3765
3766                 if (*s == '>') {
3767                     while (*++s == '>') ;
3768                     prespace = FF_SPACE;
3769                 }
3770                 else if (*s == '|') {
3771                     while (*++s == '|') ;
3772                     prespace = FF_HALFSPACE;
3773                     postspace = TRUE;
3774                 }
3775                 else {
3776                     if (*s == '<')
3777                         while (*++s == '<') ;
3778                     postspace = TRUE;
3779                 }
3780                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3781                     s += 3;
3782                     ismore = TRUE;
3783                 }
3784                 *fpc++ = s - base;              /* fieldsize for FETCH */
3785
3786                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3787
3788                 if (prespace)
3789                     *fpc++ = (U16)prespace;
3790                 *fpc++ = FF_ITEM;
3791                 if (ismore)
3792                     *fpc++ = FF_MORE;
3793                 if (ischop)
3794                     *fpc++ = FF_CHOP;
3795             }
3796             base = s;
3797             skipspaces = 0;
3798             continue;
3799         }
3800     }
3801     *fpc++ = FF_END;
3802
3803     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3804     arg = fpc - fops;
3805     { /* need to jump to the next word */
3806         int z;
3807         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3808         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3809         s = SvPVX(sv) + SvCUR(sv) + z;
3810     }
3811     Copy(fops, s, arg, U32);
3812     Safefree(fops);
3813     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3814     SvCOMPILED_on(sv);
3815
3816     if (unchopnum && repeat)
3817         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3818     return 0;
3819 }
3820
3821
3822 STATIC bool
3823 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3824 {
3825     /* Can value be printed in fldsize chars, using %*.*f ? */
3826     NV pwr = 1;
3827     NV eps = 0.5;
3828     bool res = FALSE;
3829     int intsize = fldsize - (value < 0 ? 1 : 0);
3830
3831     if (frcsize & 256)
3832         intsize--;
3833     frcsize &= 255;
3834     intsize -= frcsize;
3835
3836     while (intsize--) pwr *= 10.0;
3837     while (frcsize--) eps /= 10.0;
3838
3839     if( value >= 0 ){
3840         if (value + eps >= pwr)
3841             res = TRUE;
3842     } else {
3843         if (value - eps <= -pwr)
3844             res = TRUE;
3845     }
3846     return res;
3847 }
3848
3849 static I32
3850 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3851 {
3852     SV *datasv = FILTER_DATA(idx);
3853     int filter_has_file = IoLINES(datasv);
3854     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3855     SV *filter_state = (SV *)IoTOP_GV(datasv);
3856     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3857     int len = 0;
3858
3859     /* I was having segfault trouble under Linux 2.2.5 after a
3860        parse error occured.  (Had to hack around it with a test
3861        for PL_error_count == 0.)  Solaris doesn't segfault --
3862        not sure where the trouble is yet.  XXX */
3863
3864     if (filter_has_file) {
3865         len = FILTER_READ(idx+1, buf_sv, maxlen);
3866     }
3867
3868     if (filter_sub && len >= 0) {
3869         dSP;
3870         int count;
3871
3872         ENTER;
3873         SAVE_DEFSV;
3874         SAVETMPS;
3875         EXTEND(SP, 2);
3876
3877         DEFSV = buf_sv;
3878         PUSHMARK(SP);
3879         PUSHs(sv_2mortal(newSViv(maxlen)));
3880         if (filter_state) {
3881             PUSHs(filter_state);
3882         }
3883         PUTBACK;
3884         count = call_sv(filter_sub, G_SCALAR);
3885         SPAGAIN;
3886
3887         if (count > 0) {
3888             SV *out = POPs;
3889             if (SvOK(out)) {
3890                 len = SvIV(out);
3891             }
3892         }
3893
3894         PUTBACK;
3895         FREETMPS;
3896         LEAVE;
3897     }
3898
3899     if (len <= 0) {
3900         IoLINES(datasv) = 0;
3901         if (filter_child_proc) {
3902             SvREFCNT_dec(filter_child_proc);
3903             IoFMT_GV(datasv) = Nullgv;
3904         }
3905         if (filter_state) {
3906             SvREFCNT_dec(filter_state);
3907             IoTOP_GV(datasv) = Nullgv;
3908         }
3909         if (filter_sub) {
3910             SvREFCNT_dec(filter_sub);
3911             IoBOTTOM_GV(datasv) = Nullgv;
3912         }
3913         filter_del(run_user_filter);
3914     }
3915
3916     return len;
3917 }
3918
3919 /* perhaps someone can come up with a better name for
3920    this?  it is not really "absolute", per se ... */
3921 static bool
3922 S_path_is_absolute(pTHX_ char *name)
3923 {
3924     if (PERL_FILE_IS_ABSOLUTE(name)
3925 #ifdef MACOS_TRADITIONAL
3926         || (*name == ':'))
3927 #else
3928         || (*name == '.' && (name[1] == '/' ||
3929                              (name[1] == '.' && name[2] == '/'))))
3930 #endif
3931     {
3932         return TRUE;
3933     }
3934     else
3935         return FALSE;
3936 }