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
2252     label = 0;
2253     if (PL_op->op_flags & OPf_STACKED) {
2254         SV *sv = POPs;
2255         STRLEN n_a;
2256
2257         /* This egregious kludge implements goto &subroutine */
2258         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2259             I32 cxix;
2260             register PERL_CONTEXT *cx;
2261             CV* cv = (CV*)SvRV(sv);
2262             SV** mark;
2263             I32 items = 0;
2264             I32 oldsave;
2265             bool reified = 0;
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                 CLEAR_ARGARRAY(av);
2308                 /* abandon @_ if it got reified */
2309                 if (AvREAL(av)) {
2310                     reified = 1;
2311                     SvREFCNT_dec(av);
2312                     av = newAV();
2313                     av_extend(av, items-1);
2314                     AvFLAGS(av) = AVf_REIFY;
2315                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2316                 }
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             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2336             if (CvXSUB(cv)) {
2337                 if (reified) {
2338                     I32 index;
2339                     for (index=0; index<items; index++)
2340                         sv_2mortal(SP[-index]);
2341                 }
2342 #ifdef PERL_XSUB_OLDSTYLE
2343                 if (CvOLDSTYLE(cv)) {
2344                     I32 (*fp3)(int,int,int);
2345                     while (SP > mark) {
2346                         SP[1] = SP[0];
2347                         SP--;
2348                     }
2349                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2350                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2351                                    mark - PL_stack_base + 1,
2352                                    items);
2353                     SP = PL_stack_base + items;
2354                 }
2355                 else
2356 #endif /* PERL_XSUB_OLDSTYLE */
2357                 {
2358                     SV **newsp;
2359                     I32 gimme;
2360
2361                     /* Push a mark for the start of arglist */
2362                     PUSHMARK(mark);
2363                     PUTBACK;
2364                     (void)(*CvXSUB(cv))(aTHX_ cv);
2365                     /* Pop the current context like a decent sub should */
2366                     POPBLOCK(cx, PL_curpm);
2367                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2368                 }
2369                 LEAVE;
2370                 assert(CxTYPE(cx) == CXt_SUB);
2371                 return cx->blk_sub.retop;
2372             }
2373             else {
2374                 AV* padlist = CvPADLIST(cv);
2375                 if (CxTYPE(cx) == CXt_EVAL) {
2376                     PL_in_eval = cx->blk_eval.old_in_eval;
2377                     PL_eval_root = cx->blk_eval.old_eval_root;
2378                     cx->cx_type = CXt_SUB;
2379                     cx->blk_sub.hasargs = 0;
2380                 }
2381                 cx->blk_sub.cv = cv;
2382                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2383
2384                 CvDEPTH(cv)++;
2385                 if (CvDEPTH(cv) < 2)
2386                     (void)SvREFCNT_inc(cv);
2387                 else {
2388                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2389                         sub_crush_depth(cv);
2390                     pad_push(padlist, CvDEPTH(cv), 1);
2391                 }
2392                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2393                 if (cx->blk_sub.hasargs)
2394                 {
2395                     AV* av = (AV*)PAD_SVl(0);
2396                     SV** ary;
2397
2398                     cx->blk_sub.savearray = GvAV(PL_defgv);
2399                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2400                     CX_CURPAD_SAVE(cx->blk_sub);
2401                     cx->blk_sub.argarray = av;
2402
2403                     if (items >= AvMAX(av) + 1) {
2404                         ary = AvALLOC(av);
2405                         if (AvARRAY(av) != ary) {
2406                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407                             SvPVX(av) = (char*)ary;
2408                         }
2409                         if (items >= AvMAX(av) + 1) {
2410                             AvMAX(av) = items - 1;
2411                             Renew(ary,items+1,SV*);
2412                             AvALLOC(av) = ary;
2413                             SvPVX(av) = (char*)ary;
2414                         }
2415                     }
2416                     ++mark;
2417                     Copy(mark,AvARRAY(av),items,SV*);
2418                     AvFILLp(av) = items - 1;
2419                     assert(!AvREAL(av));
2420                     if (reified) {
2421                         /* transfer 'ownership' of refcnts to new @_ */
2422                         AvREAL_on(av);
2423                         AvREIFY_off(av);
2424                     }
2425                     while (items--) {
2426                         if (*mark)
2427                             SvTEMP_off(*mark);
2428                         mark++;
2429                     }
2430                 }
2431                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2432                     /*
2433                      * We do not care about using sv to call CV;
2434                      * it's for informational purposes only.
2435                      */
2436                     SV *sv = GvSV(PL_DBsub);
2437                     CV *gotocv;
2438
2439                     if (PERLDB_SUB_NN) {
2440                         (void)SvUPGRADE(sv, SVt_PVIV);
2441                         (void)SvIOK_on(sv);
2442                         SAVEIV(SvIVX(sv));
2443                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2444                     } else {
2445                         save_item(sv);
2446                         gv_efullname3(sv, CvGV(cv), Nullch);
2447                     }
2448                     if (  PERLDB_GOTO
2449                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2450                         PUSHMARK( PL_stack_sp );
2451                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2452                         PL_stack_sp--;
2453                     }
2454                 }
2455                 RETURNOP(CvSTART(cv));
2456             }
2457         }
2458         else {
2459             label = SvPV(sv,n_a);
2460             if (!(do_dump || *label))
2461                 DIE(aTHX_ must_have_label);
2462         }
2463     }
2464     else if (PL_op->op_flags & OPf_SPECIAL) {
2465         if (! do_dump)
2466             DIE(aTHX_ must_have_label);
2467     }
2468     else
2469         label = cPVOP->op_pv;
2470
2471     if (label && *label) {
2472         OP *gotoprobe = 0;
2473         bool leaving_eval = FALSE;
2474         bool in_block = FALSE;
2475         PERL_CONTEXT *last_eval_cx = 0;
2476
2477         /* find label */
2478
2479         PL_lastgotoprobe = 0;
2480         *enterops = 0;
2481         for (ix = cxstack_ix; ix >= 0; ix--) {
2482             cx = &cxstack[ix];
2483             switch (CxTYPE(cx)) {
2484             case CXt_EVAL:
2485                 leaving_eval = TRUE;
2486                 if (!CxTRYBLOCK(cx)) {
2487                     gotoprobe = (last_eval_cx ?
2488                                 last_eval_cx->blk_eval.old_eval_root :
2489                                 PL_eval_root);
2490                     last_eval_cx = cx;
2491                     break;
2492                 }
2493                 /* else fall through */
2494             case CXt_LOOP:
2495                 gotoprobe = cx->blk_oldcop->op_sibling;
2496                 break;
2497             case CXt_SUBST:
2498                 continue;
2499             case CXt_BLOCK:
2500                 if (ix) {
2501                     gotoprobe = cx->blk_oldcop->op_sibling;
2502                     in_block = TRUE;
2503                 } else
2504                     gotoprobe = PL_main_root;
2505                 break;
2506             case CXt_SUB:
2507                 if (CvDEPTH(cx->blk_sub.cv)) {
2508                     gotoprobe = CvROOT(cx->blk_sub.cv);
2509                     break;
2510                 }
2511                 /* FALL THROUGH */
2512             case CXt_FORMAT:
2513             case CXt_NULL:
2514                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2515             default:
2516                 if (ix)
2517                     DIE(aTHX_ "panic: goto");
2518                 gotoprobe = PL_main_root;
2519                 break;
2520             }
2521             if (gotoprobe) {
2522                 retop = dofindlabel(gotoprobe, label,
2523                                     enterops, enterops + GOTO_DEPTH);
2524                 if (retop)
2525                     break;
2526             }
2527             PL_lastgotoprobe = gotoprobe;
2528         }
2529         if (!retop)
2530             DIE(aTHX_ "Can't find label %s", label);
2531
2532         /* if we're leaving an eval, check before we pop any frames
2533            that we're not going to punt, otherwise the error
2534            won't be caught */
2535
2536         if (leaving_eval && *enterops && enterops[1]) {
2537             I32 i;
2538             for (i = 1; enterops[i]; i++)
2539                 if (enterops[i]->op_type == OP_ENTERITER)
2540                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2541         }
2542
2543         /* pop unwanted frames */
2544
2545         if (ix < cxstack_ix) {
2546             I32 oldsave;
2547
2548             if (ix < 0)
2549                 ix = 0;
2550             dounwind(ix);
2551             TOPBLOCK(cx);
2552             oldsave = PL_scopestack[PL_scopestack_ix];
2553             LEAVE_SCOPE(oldsave);
2554         }
2555
2556         /* push wanted frames */
2557
2558         if (*enterops && enterops[1]) {
2559             OP *oldop = PL_op;
2560             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2561             for (; enterops[ix]; ix++) {
2562                 PL_op = enterops[ix];
2563                 /* Eventually we may want to stack the needed arguments
2564                  * for each op.  For now, we punt on the hard ones. */
2565                 if (PL_op->op_type == OP_ENTERITER)
2566                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2567                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2568             }
2569             PL_op = oldop;
2570         }
2571     }
2572
2573     if (do_dump) {
2574 #ifdef VMS
2575         if (!retop) retop = PL_main_start;
2576 #endif
2577         PL_restartop = retop;
2578         PL_do_undump = TRUE;
2579
2580         my_unexec();
2581
2582         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2583         PL_do_undump = FALSE;
2584     }
2585
2586     RETURNOP(retop);
2587 }
2588
2589 PP(pp_exit)
2590 {
2591     dSP;
2592     I32 anum;
2593
2594     if (MAXARG < 1)
2595         anum = 0;
2596     else {
2597         anum = SvIVx(POPs);
2598 #ifdef VMS
2599         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2600             anum = 0;
2601         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2602 #endif
2603     }
2604     PL_exit_flags |= PERL_EXIT_EXPECTED;
2605     my_exit(anum);
2606     PUSHs(&PL_sv_undef);
2607     RETURN;
2608 }
2609
2610 #ifdef NOTYET
2611 PP(pp_nswitch)
2612 {
2613     dSP;
2614     NV value = SvNVx(GvSV(cCOP->cop_gv));
2615     register I32 match = I_32(value);
2616
2617     if (value < 0.0) {
2618         if (((NV)match) > value)
2619             --match;            /* was fractional--truncate other way */
2620     }
2621     match -= cCOP->uop.scop.scop_offset;
2622     if (match < 0)
2623         match = 0;
2624     else if (match > cCOP->uop.scop.scop_max)
2625         match = cCOP->uop.scop.scop_max;
2626     PL_op = cCOP->uop.scop.scop_next[match];
2627     RETURNOP(PL_op);
2628 }
2629
2630 PP(pp_cswitch)
2631 {
2632     dSP;
2633     register I32 match;
2634
2635     if (PL_multiline)
2636         PL_op = PL_op->op_next;                 /* can't assume anything */
2637     else {
2638         STRLEN n_a;
2639         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2640         match -= cCOP->uop.scop.scop_offset;
2641         if (match < 0)
2642             match = 0;
2643         else if (match > cCOP->uop.scop.scop_max)
2644             match = cCOP->uop.scop.scop_max;
2645         PL_op = cCOP->uop.scop.scop_next[match];
2646     }
2647     RETURNOP(PL_op);
2648 }
2649 #endif
2650
2651 /* Eval. */
2652
2653 STATIC void
2654 S_save_lines(pTHX_ AV *array, SV *sv)
2655 {
2656     register char *s = SvPVX(sv);
2657     register char *send = SvPVX(sv) + SvCUR(sv);
2658     register char *t;
2659     register I32 line = 1;
2660
2661     while (s && s < send) {
2662         SV *tmpstr = NEWSV(85,0);
2663
2664         sv_upgrade(tmpstr, SVt_PVMG);
2665         t = strchr(s, '\n');
2666         if (t)
2667             t++;
2668         else
2669             t = send;
2670
2671         sv_setpvn(tmpstr, s, t - s);
2672         av_store(array, line++, tmpstr);
2673         s = t;
2674     }
2675 }
2676
2677 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2678 STATIC void *
2679 S_docatch_body(pTHX_ va_list args)
2680 {
2681     return docatch_body();
2682 }
2683 #endif
2684
2685 STATIC void *
2686 S_docatch_body(pTHX)
2687 {
2688     CALLRUNOPS(aTHX);
2689     return NULL;
2690 }
2691
2692 STATIC OP *
2693 S_docatch(pTHX_ OP *o)
2694 {
2695     int ret;
2696     OP *oldop = PL_op;
2697     OP *retop;
2698     volatile PERL_SI *cursi = PL_curstackinfo;
2699     dJMPENV;
2700
2701 #ifdef DEBUGGING
2702     assert(CATCH_GET == TRUE);
2703 #endif
2704     PL_op = o;
2705
2706     /* Normally, the leavetry at the end of this block of ops will
2707      * pop an op off the return stack and continue there. By setting
2708      * the op to Nullop, we force an exit from the inner runops()
2709      * loop. DAPM.
2710      */
2711     assert(cxstack_ix >= 0);
2712     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2713     retop = cxstack[cxstack_ix].blk_eval.retop;
2714     cxstack[cxstack_ix].blk_eval.retop = Nullop;
2715
2716 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2717  redo_body:
2718     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2719 #else
2720     JMPENV_PUSH(ret);
2721 #endif
2722     switch (ret) {
2723     case 0:
2724 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2725  redo_body:
2726         docatch_body();
2727 #endif
2728         break;
2729     case 3:
2730         /* die caught by an inner eval - continue inner loop */
2731         if (PL_restartop && cursi == PL_curstackinfo) {
2732             PL_op = PL_restartop;
2733             PL_restartop = 0;
2734             goto redo_body;
2735         }
2736         /* a die in this eval - continue in outer loop */
2737         if (!PL_restartop)
2738             break;
2739         /* FALL THROUGH */
2740     default:
2741         JMPENV_POP;
2742         PL_op = oldop;
2743         JMPENV_JUMP(ret);
2744         /* NOTREACHED */
2745     }
2746     JMPENV_POP;
2747     PL_op = oldop;
2748     return retop;
2749 }
2750
2751 OP *
2752 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2753 /* sv Text to convert to OP tree. */
2754 /* startop op_free() this to undo. */
2755 /* code Short string id of the caller. */
2756 {
2757     dSP;                                /* Make POPBLOCK work. */
2758     PERL_CONTEXT *cx;
2759     SV **newsp;
2760     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2761     I32 optype;
2762     OP dummy;
2763     OP *rop;
2764     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2765     char *tmpbuf = tbuf;
2766     char *safestr;
2767     int runtime;
2768     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2769
2770     ENTER;
2771     lex_start(sv);
2772     SAVETMPS;
2773     /* switch to eval mode */
2774
2775     if (IN_PERL_COMPILETIME) {
2776         SAVECOPSTASH_FREE(&PL_compiling);
2777         CopSTASH_set(&PL_compiling, PL_curstash);
2778     }
2779     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2780         SV *sv = sv_newmortal();
2781         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2782                        code, (unsigned long)++PL_evalseq,
2783                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2784         tmpbuf = SvPVX(sv);
2785     }
2786     else
2787         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2788     SAVECOPFILE_FREE(&PL_compiling);
2789     CopFILE_set(&PL_compiling, tmpbuf+2);
2790     SAVECOPLINE(&PL_compiling);
2791     CopLINE_set(&PL_compiling, 1);
2792     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2793        deleting the eval's FILEGV from the stash before gv_check() runs
2794        (i.e. before run-time proper). To work around the coredump that
2795        ensues, we always turn GvMULTI_on for any globals that were
2796        introduced within evals. See force_ident(). GSAR 96-10-12 */
2797     safestr = savepv(tmpbuf);
2798     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2799     SAVEHINTS();
2800 #ifdef OP_IN_REGISTER
2801     PL_opsave = op;
2802 #else
2803     SAVEVPTR(PL_op);
2804 #endif
2805
2806     /* we get here either during compilation, or via pp_regcomp at runtime */
2807     runtime = IN_PERL_RUNTIME;
2808     if (runtime)
2809         runcv = find_runcv(NULL);
2810
2811     PL_op = &dummy;
2812     PL_op->op_type = OP_ENTEREVAL;
2813     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2814     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2815     PUSHEVAL(cx, 0, Nullgv);
2816
2817     if (runtime)
2818         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2819     else
2820         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2821     POPBLOCK(cx,PL_curpm);
2822     POPEVAL(cx);
2823
2824     (*startop)->op_type = OP_NULL;
2825     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2826     lex_end();
2827     /* XXX DAPM do this properly one year */
2828     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2829     LEAVE;
2830     if (IN_PERL_COMPILETIME)
2831         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2832 #ifdef OP_IN_REGISTER
2833     op = PL_opsave;
2834 #endif
2835     return rop;
2836 }
2837
2838
2839 /*
2840 =for apidoc find_runcv
2841
2842 Locate the CV corresponding to the currently executing sub or eval.
2843 If db_seqp is non_null, skip CVs that are in the DB package and populate
2844 *db_seqp with the cop sequence number at the point that the DB:: code was
2845 entered. (allows debuggers to eval in the scope of the breakpoint rather
2846 than in in the scope of the debugger itself).
2847
2848 =cut
2849 */
2850
2851 CV*
2852 Perl_find_runcv(pTHX_ U32 *db_seqp)
2853 {
2854     I32          ix;
2855     PERL_SI      *si;
2856     PERL_CONTEXT *cx;
2857
2858     if (db_seqp)
2859         *db_seqp = PL_curcop->cop_seq;
2860     for (si = PL_curstackinfo; si; si = si->si_prev) {
2861         for (ix = si->si_cxix; ix >= 0; ix--) {
2862             cx = &(si->si_cxstack[ix]);
2863             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2864                 CV *cv = cx->blk_sub.cv;
2865                 /* skip DB:: code */
2866                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2867                     *db_seqp = cx->blk_oldcop->cop_seq;
2868                     continue;
2869                 }
2870                 return cv;
2871             }
2872             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2873                 return PL_compcv;
2874         }
2875     }
2876     return PL_main_cv;
2877 }
2878
2879
2880 /* Compile a require/do, an eval '', or a /(?{...})/.
2881  * In the last case, startop is non-null, and contains the address of
2882  * a pointer that should be set to the just-compiled code.
2883  * outside is the lexically enclosing CV (if any) that invoked us.
2884  */
2885
2886 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2887 STATIC OP *
2888 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2889 {
2890     dSP;
2891     OP *saveop = PL_op;
2892
2893     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2894                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2895                   : EVAL_INEVAL);
2896
2897     PUSHMARK(SP);
2898
2899     SAVESPTR(PL_compcv);
2900     PL_compcv = (CV*)NEWSV(1104,0);
2901     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2902     CvEVAL_on(PL_compcv);
2903     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2904     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2905
2906     CvOUTSIDE_SEQ(PL_compcv) = seq;
2907     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2908
2909     /* set up a scratch pad */
2910
2911     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2912
2913
2914     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2915
2916     /* make sure we compile in the right package */
2917
2918     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2919         SAVESPTR(PL_curstash);
2920         PL_curstash = CopSTASH(PL_curcop);
2921     }
2922     SAVESPTR(PL_beginav);
2923     PL_beginav = newAV();
2924     SAVEFREESV(PL_beginav);
2925     SAVEI32(PL_error_count);
2926
2927     /* try to compile it */
2928
2929     PL_eval_root = Nullop;
2930     PL_error_count = 0;
2931     PL_curcop = &PL_compiling;
2932     PL_curcop->cop_arybase = 0;
2933     if (saveop && saveop->op_flags & OPf_SPECIAL)
2934         PL_in_eval |= EVAL_KEEPERR;
2935     else
2936         sv_setpv(ERRSV,"");
2937     if (yyparse() || PL_error_count || !PL_eval_root) {
2938         SV **newsp;                     /* Used by POPBLOCK. */
2939        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2940         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2941         STRLEN n_a;
2942
2943         PL_op = saveop;
2944         if (PL_eval_root) {
2945             op_free(PL_eval_root);
2946             PL_eval_root = Nullop;
2947         }
2948         SP = PL_stack_base + POPMARK;           /* pop original mark */
2949         if (!startop) {
2950             POPBLOCK(cx,PL_curpm);
2951             POPEVAL(cx);
2952         }
2953         lex_end();
2954         LEAVE;
2955         if (optype == OP_REQUIRE) {
2956             char* msg = SvPVx(ERRSV, n_a);
2957            SV *nsv = cx->blk_eval.old_namesv;
2958            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2959                           &PL_sv_undef, 0);
2960             DIE(aTHX_ "%sCompilation failed in require",
2961                 *msg ? msg : "Unknown error\n");
2962         }
2963         else if (startop) {
2964             char* msg = SvPVx(ERRSV, n_a);
2965
2966             POPBLOCK(cx,PL_curpm);
2967             POPEVAL(cx);
2968             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2969                        (*msg ? msg : "Unknown error\n"));
2970         }
2971         else {
2972             char* msg = SvPVx(ERRSV, n_a);
2973             if (!*msg) {
2974                 sv_setpv(ERRSV, "Compilation error");
2975             }
2976         }
2977         RETPUSHUNDEF;
2978     }
2979     CopLINE_set(&PL_compiling, 0);
2980     if (startop) {
2981         *startop = PL_eval_root;
2982     } else
2983         SAVEFREEOP(PL_eval_root);
2984
2985     /* Set the context for this new optree.
2986      * If the last op is an OP_REQUIRE, force scalar context.
2987      * Otherwise, propagate the context from the eval(). */
2988     if (PL_eval_root->op_type == OP_LEAVEEVAL
2989             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2990             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2991             == OP_REQUIRE)
2992         scalar(PL_eval_root);
2993     else if (gimme & G_VOID)
2994         scalarvoid(PL_eval_root);
2995     else if (gimme & G_ARRAY)
2996         list(PL_eval_root);
2997     else
2998         scalar(PL_eval_root);
2999
3000     DEBUG_x(dump_eval());
3001
3002     /* Register with debugger: */
3003     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3004         CV *cv = get_cv("DB::postponed", FALSE);
3005         if (cv) {
3006             dSP;
3007             PUSHMARK(SP);
3008             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3009             PUTBACK;
3010             call_sv((SV*)cv, G_DISCARD);
3011         }
3012     }
3013
3014     /* compiled okay, so do it */
3015
3016     CvDEPTH(PL_compcv) = 1;
3017     SP = PL_stack_base + POPMARK;               /* pop original mark */
3018     PL_op = saveop;                     /* The caller may need it. */
3019     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3020
3021     RETURNOP(PL_eval_start);
3022 }
3023
3024 STATIC PerlIO *
3025 S_doopen_pm(pTHX_ const char *name, const char *mode)
3026 {
3027 #ifndef PERL_DISABLE_PMC
3028     STRLEN namelen = strlen(name);
3029     PerlIO *fp;
3030
3031     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3032         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3033         char *pmc = SvPV_nolen(pmcsv);
3034         Stat_t pmstat;
3035         Stat_t pmcstat;
3036         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037             fp = PerlIO_open(name, mode);
3038         }
3039         else {
3040             if (PerlLIO_stat(name, &pmstat) < 0 ||
3041                 pmstat.st_mtime < pmcstat.st_mtime)
3042             {
3043                 fp = PerlIO_open(pmc, mode);
3044             }
3045             else {
3046                 fp = PerlIO_open(name, mode);
3047             }
3048         }
3049         SvREFCNT_dec(pmcsv);
3050     }
3051     else {
3052         fp = PerlIO_open(name, mode);
3053     }
3054     return fp;
3055 #else
3056     return PerlIO_open(name, mode);
3057 #endif /* !PERL_DISABLE_PMC */
3058 }
3059
3060 PP(pp_require)
3061 {
3062     dSP;
3063     register PERL_CONTEXT *cx;
3064     SV *sv;
3065     char *name;
3066     STRLEN len;
3067     char *tryname = Nullch;
3068     SV *namesv = Nullsv;
3069     SV** svp;
3070     I32 gimme = GIMME_V;
3071     PerlIO *tryrsfp = 0;
3072     STRLEN n_a;
3073     int filter_has_file = 0;
3074     GV *filter_child_proc = 0;
3075     SV *filter_state = 0;
3076     SV *filter_sub = 0;
3077     SV *hook_sv = 0;
3078     SV *encoding;
3079     OP *op;
3080
3081     sv = POPs;
3082     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3083         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3084                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3085                         "v-string in use/require non-portable");
3086
3087         sv = new_version(sv);
3088         if (!sv_derived_from(PL_patchlevel, "version"))
3089             (void *)upg_version(PL_patchlevel);
3090         if ( vcmp(sv,PL_patchlevel) > 0 )
3091             DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
3092                 vstringify(sv), vstringify(PL_patchlevel));
3093
3094             RETPUSHYES;
3095     }
3096     name = SvPV(sv, len);
3097     if (!(name && len > 0 && *name))
3098         DIE(aTHX_ "Null filename used");
3099     TAINT_PROPER("require");
3100     if (PL_op->op_type == OP_REQUIRE &&
3101        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3102        if (*svp != &PL_sv_undef)
3103            RETPUSHYES;
3104        else
3105            DIE(aTHX_ "Compilation failed in require");
3106     }
3107
3108     /* prepare to compile file */
3109
3110     if (path_is_absolute(name)) {
3111         tryname = name;
3112         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3113     }
3114 #ifdef MACOS_TRADITIONAL
3115     if (!tryrsfp) {
3116         char newname[256];
3117
3118         MacPerl_CanonDir(name, newname, 1);
3119         if (path_is_absolute(newname)) {
3120             tryname = newname;
3121             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3122         }
3123     }
3124 #endif
3125     if (!tryrsfp) {
3126         AV *ar = GvAVn(PL_incgv);
3127         I32 i;
3128 #ifdef VMS
3129         char *unixname;
3130         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3131 #endif
3132         {
3133             namesv = NEWSV(806, 0);
3134             for (i = 0; i <= AvFILL(ar); i++) {
3135                 SV *dirsv = *av_fetch(ar, i, TRUE);
3136
3137                 if (SvROK(dirsv)) {
3138                     int count;
3139                     SV *loader = dirsv;
3140
3141                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3142                         && !sv_isobject(loader))
3143                     {
3144                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3145                     }
3146
3147                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3148                                    PTR2UV(SvRV(dirsv)), name);
3149                     tryname = SvPVX(namesv);
3150                     tryrsfp = 0;
3151
3152                     ENTER;
3153                     SAVETMPS;
3154                     EXTEND(SP, 2);
3155
3156                     PUSHMARK(SP);
3157                     PUSHs(dirsv);
3158                     PUSHs(sv);
3159                     PUTBACK;
3160                     if (sv_isobject(loader))
3161                         count = call_method("INC", G_ARRAY);
3162                     else
3163                         count = call_sv(loader, G_ARRAY);
3164                     SPAGAIN;
3165
3166                     if (count > 0) {
3167                         int i = 0;
3168                         SV *arg;
3169
3170                         SP -= count - 1;
3171                         arg = SP[i++];
3172
3173                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3174                             arg = SvRV(arg);
3175                         }
3176
3177                         if (SvTYPE(arg) == SVt_PVGV) {
3178                             IO *io = GvIO((GV *)arg);
3179
3180                             ++filter_has_file;
3181
3182                             if (io) {
3183                                 tryrsfp = IoIFP(io);
3184                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3185                                     /* reading from a child process doesn't
3186                                        nest -- when returning from reading
3187                                        the inner module, the outer one is
3188                                        unreadable (closed?)  I've tried to
3189                                        save the gv to manage the lifespan of
3190                                        the pipe, but this didn't help. XXX */
3191                                     filter_child_proc = (GV *)arg;
3192                                     (void)SvREFCNT_inc(filter_child_proc);
3193                                 }
3194                                 else {
3195                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3196                                         PerlIO_close(IoOFP(io));
3197                                     }
3198                                     IoIFP(io) = Nullfp;
3199                                     IoOFP(io) = Nullfp;
3200                                 }
3201                             }
3202
3203                             if (i < count) {
3204                                 arg = SP[i++];
3205                             }
3206                         }
3207
3208                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3209                             filter_sub = arg;
3210                             (void)SvREFCNT_inc(filter_sub);
3211
3212                             if (i < count) {
3213                                 filter_state = SP[i];
3214                                 (void)SvREFCNT_inc(filter_state);
3215                             }
3216
3217                             if (tryrsfp == 0) {
3218                                 tryrsfp = PerlIO_open("/dev/null",
3219                                                       PERL_SCRIPT_MODE);
3220                             }
3221                         }
3222                         SP--;
3223                     }
3224
3225                     PUTBACK;
3226                     FREETMPS;
3227                     LEAVE;
3228
3229                     if (tryrsfp) {
3230                         hook_sv = dirsv;
3231                         break;
3232                     }
3233
3234                     filter_has_file = 0;
3235                     if (filter_child_proc) {
3236                         SvREFCNT_dec(filter_child_proc);
3237                         filter_child_proc = 0;
3238                     }
3239                     if (filter_state) {
3240                         SvREFCNT_dec(filter_state);
3241                         filter_state = 0;
3242                     }
3243                     if (filter_sub) {
3244                         SvREFCNT_dec(filter_sub);
3245                         filter_sub = 0;
3246                     }
3247                 }
3248                 else {
3249                   if (!path_is_absolute(name)
3250 #ifdef MACOS_TRADITIONAL
3251                         /* We consider paths of the form :a:b ambiguous and interpret them first
3252                            as global then as local
3253                         */
3254                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3255 #endif
3256                   ) {
3257                     char *dir = SvPVx(dirsv, n_a);
3258 #ifdef MACOS_TRADITIONAL
3259                     char buf1[256];
3260                     char buf2[256];
3261
3262                     MacPerl_CanonDir(name, buf2, 1);
3263                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3264 #else
3265 #ifdef VMS
3266                     char *unixdir;
3267                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3268                         continue;
3269                     sv_setpv(namesv, unixdir);
3270                     sv_catpv(namesv, unixname);
3271 #else
3272                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3273 #endif
3274 #endif
3275                     TAINT_PROPER("require");
3276                     tryname = SvPVX(namesv);
3277                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3278                     if (tryrsfp) {
3279                         if (tryname[0] == '.' && tryname[1] == '/')
3280                             tryname += 2;
3281                         break;
3282                     }
3283                   }
3284                 }
3285             }
3286         }
3287     }
3288     SAVECOPFILE_FREE(&PL_compiling);
3289     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3290     SvREFCNT_dec(namesv);
3291     if (!tryrsfp) {
3292         if (PL_op->op_type == OP_REQUIRE) {
3293             char *msgstr = name;
3294             if (namesv) {                       /* did we lookup @INC? */
3295                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3296                 SV *dirmsgsv = NEWSV(0, 0);
3297                 AV *ar = GvAVn(PL_incgv);
3298                 I32 i;
3299                 sv_catpvn(msg, " in @INC", 8);
3300                 if (instr(SvPVX(msg), ".h "))
3301                     sv_catpv(msg, " (change .h to .ph maybe?)");
3302                 if (instr(SvPVX(msg), ".ph "))
3303                     sv_catpv(msg, " (did you run h2ph?)");
3304                 sv_catpv(msg, " (@INC contains:");
3305                 for (i = 0; i <= AvFILL(ar); i++) {
3306                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3307                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3308                     sv_catsv(msg, dirmsgsv);
3309                 }
3310                 sv_catpvn(msg, ")", 1);
3311                 SvREFCNT_dec(dirmsgsv);
3312                 msgstr = SvPV_nolen(msg);
3313             }
3314             DIE(aTHX_ "Can't locate %s", msgstr);
3315         }
3316
3317         RETPUSHUNDEF;
3318     }
3319     else
3320         SETERRNO(0, SS_NORMAL);
3321
3322     /* Assume success here to prevent recursive requirement. */
3323     len = strlen(name);
3324     /* Check whether a hook in @INC has already filled %INC */
3325     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3326         (void)hv_store(GvHVn(PL_incgv), name, len,
3327                        (hook_sv ? SvREFCNT_inc(hook_sv)
3328                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3329                        0 );
3330     }
3331
3332     ENTER;
3333     SAVETMPS;
3334     lex_start(sv_2mortal(newSVpvn("",0)));
3335     SAVEGENERICSV(PL_rsfp_filters);
3336     PL_rsfp_filters = Nullav;
3337
3338     PL_rsfp = tryrsfp;
3339     SAVEHINTS();
3340     PL_hints = 0;
3341     SAVESPTR(PL_compiling.cop_warnings);
3342     if (PL_dowarn & G_WARN_ALL_ON)
3343         PL_compiling.cop_warnings = pWARN_ALL ;
3344     else if (PL_dowarn & G_WARN_ALL_OFF)
3345         PL_compiling.cop_warnings = pWARN_NONE ;
3346     else if (PL_taint_warn)
3347         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3348     else
3349         PL_compiling.cop_warnings = pWARN_STD ;
3350     SAVESPTR(PL_compiling.cop_io);
3351     PL_compiling.cop_io = Nullsv;
3352
3353     if (filter_sub || filter_child_proc) {
3354         SV *datasv = filter_add(run_user_filter, Nullsv);
3355         IoLINES(datasv) = filter_has_file;
3356         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3357         IoTOP_GV(datasv) = (GV *)filter_state;
3358         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3359     }
3360
3361     /* switch to eval mode */
3362     PUSHBLOCK(cx, CXt_EVAL, SP);
3363     PUSHEVAL(cx, name, Nullgv);
3364     cx->blk_eval.retop = PL_op->op_next;
3365
3366     SAVECOPLINE(&PL_compiling);
3367     CopLINE_set(&PL_compiling, 0);
3368
3369     PUTBACK;
3370
3371     /* Store and reset encoding. */
3372     encoding = PL_encoding;
3373     PL_encoding = Nullsv;
3374
3375     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3376
3377     /* Restore encoding. */
3378     PL_encoding = encoding;
3379
3380     return op;
3381 }
3382
3383 PP(pp_dofile)
3384 {
3385     return pp_require();
3386 }
3387
3388 PP(pp_entereval)
3389 {
3390     dSP;
3391     register PERL_CONTEXT *cx;
3392     dPOPss;
3393     I32 gimme = GIMME_V, was = PL_sub_generation;
3394     char tbuf[TYPE_DIGITS(long) + 12];
3395     char *tmpbuf = tbuf;
3396     char *safestr;
3397     STRLEN len;
3398     OP *ret;
3399     CV* runcv;
3400     U32 seq;
3401
3402     if (!SvPV(sv,len))
3403         RETPUSHUNDEF;
3404     TAINT_PROPER("eval");
3405
3406     ENTER;
3407     lex_start(sv);
3408     SAVETMPS;
3409
3410     /* switch to eval mode */
3411
3412     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3413         SV *sv = sv_newmortal();
3414         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3415                        (unsigned long)++PL_evalseq,
3416                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3417         tmpbuf = SvPVX(sv);
3418     }
3419     else
3420         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3421     SAVECOPFILE_FREE(&PL_compiling);
3422     CopFILE_set(&PL_compiling, tmpbuf+2);
3423     SAVECOPLINE(&PL_compiling);
3424     CopLINE_set(&PL_compiling, 1);
3425     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3426        deleting the eval's FILEGV from the stash before gv_check() runs
3427        (i.e. before run-time proper). To work around the coredump that
3428        ensues, we always turn GvMULTI_on for any globals that were
3429        introduced within evals. See force_ident(). GSAR 96-10-12 */
3430     safestr = savepv(tmpbuf);
3431     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3432     SAVEHINTS();
3433     PL_hints = PL_op->op_targ;
3434     SAVESPTR(PL_compiling.cop_warnings);
3435     if (specialWARN(PL_curcop->cop_warnings))
3436         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3437     else {
3438         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3439         SAVEFREESV(PL_compiling.cop_warnings);
3440     }
3441     SAVESPTR(PL_compiling.cop_io);
3442     if (specialCopIO(PL_curcop->cop_io))
3443         PL_compiling.cop_io = PL_curcop->cop_io;
3444     else {
3445         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3446         SAVEFREESV(PL_compiling.cop_io);
3447     }
3448     /* special case: an eval '' executed within the DB package gets lexically
3449      * placed in the first non-DB CV rather than the current CV - this
3450      * allows the debugger to execute code, find lexicals etc, in the
3451      * scope of the code being debugged. Passing &seq gets find_runcv
3452      * to do the dirty work for us */
3453     runcv = find_runcv(&seq);
3454
3455     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3456     PUSHEVAL(cx, 0, Nullgv);
3457     cx->blk_eval.retop = PL_op->op_next;
3458
3459     /* prepare to compile string */
3460
3461     if (PERLDB_LINE && PL_curstash != PL_debstash)
3462         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3463     PUTBACK;
3464     ret = doeval(gimme, NULL, runcv, seq);
3465     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3466         && ret != PL_op->op_next) {     /* Successive compilation. */
3467         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3468     }
3469     return DOCATCH(ret);
3470 }
3471
3472 PP(pp_leaveeval)
3473 {
3474     dSP;
3475     register SV **mark;
3476     SV **newsp;
3477     PMOP *newpm;
3478     I32 gimme;
3479     register PERL_CONTEXT *cx;
3480     OP *retop;
3481     U8 save_flags = PL_op -> op_flags;
3482     I32 optype;
3483
3484     POPBLOCK(cx,newpm);
3485     POPEVAL(cx);
3486     retop = cx->blk_eval.retop;
3487
3488     TAINT_NOT;
3489     if (gimme == G_VOID)
3490         MARK = newsp;
3491     else if (gimme == G_SCALAR) {
3492         MARK = newsp + 1;
3493         if (MARK <= SP) {
3494             if (SvFLAGS(TOPs) & SVs_TEMP)
3495                 *MARK = TOPs;
3496             else
3497                 *MARK = sv_mortalcopy(TOPs);
3498         }
3499         else {
3500             MEXTEND(mark,0);
3501             *MARK = &PL_sv_undef;
3502         }
3503         SP = MARK;
3504     }
3505     else {
3506         /* in case LEAVE wipes old return values */
3507         for (mark = newsp + 1; mark <= SP; mark++) {
3508             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3509                 *mark = sv_mortalcopy(*mark);
3510                 TAINT_NOT;      /* Each item is independent */
3511             }
3512         }
3513     }
3514     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3515
3516 #ifdef DEBUGGING
3517     assert(CvDEPTH(PL_compcv) == 1);
3518 #endif
3519     CvDEPTH(PL_compcv) = 0;
3520     lex_end();
3521
3522     if (optype == OP_REQUIRE &&
3523         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3524     {
3525         /* Unassume the success we assumed earlier. */
3526         SV *nsv = cx->blk_eval.old_namesv;
3527         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3528         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3529         /* die_where() did LEAVE, or we won't be here */
3530     }
3531     else {
3532         LEAVE;
3533         if (!(save_flags & OPf_SPECIAL))
3534             sv_setpv(ERRSV,"");
3535     }
3536
3537     RETURNOP(retop);
3538 }
3539
3540 PP(pp_entertry)
3541 {
3542     dSP;
3543     register PERL_CONTEXT *cx;
3544     I32 gimme = GIMME_V;
3545
3546     ENTER;
3547     SAVETMPS;
3548
3549     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3550     PUSHEVAL(cx, 0, 0);
3551     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3552
3553     PL_in_eval = EVAL_INEVAL;
3554     sv_setpv(ERRSV,"");
3555     PUTBACK;
3556     return DOCATCH(PL_op->op_next);
3557 }
3558
3559 PP(pp_leavetry)
3560 {
3561     dSP;
3562     register SV **mark;
3563     SV **newsp;
3564     PMOP *newpm;
3565     OP* retop;
3566     I32 gimme;
3567     register PERL_CONTEXT *cx;
3568     I32 optype;
3569
3570     POPBLOCK(cx,newpm);
3571     POPEVAL(cx);
3572     retop = cx->blk_eval.retop;
3573
3574     TAINT_NOT;
3575     if (gimme == G_VOID)
3576         SP = newsp;
3577     else if (gimme == G_SCALAR) {
3578         MARK = newsp + 1;
3579         if (MARK <= SP) {
3580             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3581                 *MARK = TOPs;
3582             else
3583                 *MARK = sv_mortalcopy(TOPs);
3584         }
3585         else {
3586             MEXTEND(mark,0);
3587             *MARK = &PL_sv_undef;
3588         }
3589         SP = MARK;
3590     }
3591     else {
3592         /* in case LEAVE wipes old return values */
3593         for (mark = newsp + 1; mark <= SP; mark++) {
3594             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3595                 *mark = sv_mortalcopy(*mark);
3596                 TAINT_NOT;      /* Each item is independent */
3597             }
3598         }
3599     }
3600     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3601
3602     LEAVE;
3603     sv_setpv(ERRSV,"");
3604     RETURNOP(retop);
3605 }
3606
3607 STATIC OP *
3608 S_doparseform(pTHX_ SV *sv)
3609 {
3610     STRLEN len;
3611     register char *s = SvPV_force(sv, len);
3612     register char *send = s + len;
3613     register char *base = Nullch;
3614     register I32 skipspaces = 0;
3615     bool noblank   = FALSE;
3616     bool repeat    = FALSE;
3617     bool postspace = FALSE;
3618     U32 *fops;
3619     register U32 *fpc;
3620     U32 *linepc = 0;
3621     register I32 arg;
3622     bool ischop;
3623     bool unchopnum = FALSE;
3624     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3625
3626     if (len == 0)
3627         Perl_croak(aTHX_ "Null picture in formline");
3628
3629     /* estimate the buffer size needed */
3630     for (base = s; s <= send; s++) {
3631         if (*s == '\n' || *s == '@' || *s == '^')
3632             maxops += 10;
3633     }
3634     s = base;
3635     base = Nullch;
3636
3637     New(804, fops, maxops, U32);
3638     fpc = fops;
3639
3640     if (s < send) {
3641         linepc = fpc;
3642         *fpc++ = FF_LINEMARK;
3643         noblank = repeat = FALSE;
3644         base = s;
3645     }
3646
3647     while (s <= send) {
3648         switch (*s++) {
3649         default:
3650             skipspaces = 0;
3651             continue;
3652
3653         case '~':
3654             if (*s == '~') {
3655                 repeat = TRUE;
3656                 *s = ' ';
3657             }
3658             noblank = TRUE;
3659             s[-1] = ' ';
3660             /* FALL THROUGH */
3661         case ' ': case '\t':
3662             skipspaces++;
3663             continue;
3664         case 0:
3665             if (s < send) {
3666                 skipspaces = 0;
3667                 continue;
3668             } /* else FALL THROUGH */
3669         case '\n':
3670             arg = s - base;
3671             skipspaces++;
3672             arg -= skipspaces;
3673             if (arg) {
3674                 if (postspace)
3675                     *fpc++ = FF_SPACE;
3676                 *fpc++ = FF_LITERAL;
3677                 *fpc++ = (U16)arg;
3678             }
3679             postspace = FALSE;
3680             if (s <= send)
3681                 skipspaces--;
3682             if (skipspaces) {
3683                 *fpc++ = FF_SKIP;
3684                 *fpc++ = (U16)skipspaces;
3685             }
3686             skipspaces = 0;
3687             if (s <= send)
3688                 *fpc++ = FF_NEWLINE;
3689             if (noblank) {
3690                 *fpc++ = FF_BLANK;
3691                 if (repeat)
3692                     arg = fpc - linepc + 1;
3693                 else
3694                     arg = 0;
3695                 *fpc++ = (U16)arg;
3696             }
3697             if (s < send) {
3698                 linepc = fpc;
3699                 *fpc++ = FF_LINEMARK;
3700                 noblank = repeat = FALSE;
3701                 base = s;
3702             }
3703             else
3704                 s++;
3705             continue;
3706
3707         case '@':
3708         case '^':
3709             ischop = s[-1] == '^';
3710
3711             if (postspace) {
3712                 *fpc++ = FF_SPACE;
3713                 postspace = FALSE;
3714             }
3715             arg = (s - base) - 1;
3716             if (arg) {
3717                 *fpc++ = FF_LITERAL;
3718                 *fpc++ = (U16)arg;
3719             }
3720
3721             base = s - 1;
3722             *fpc++ = FF_FETCH;
3723             if (*s == '*') {
3724                 s++;
3725                 *fpc++ = 2;  /* skip the @* or ^* */
3726                 if (ischop) {
3727                     *fpc++ = FF_LINESNGL;
3728                     *fpc++ = FF_CHOP;
3729                 } else
3730                     *fpc++ = FF_LINEGLOB;
3731             }
3732             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3733                 arg = ischop ? 512 : 0;
3734                 base = s - 1;
3735                 while (*s == '#')
3736                     s++;
3737                 if (*s == '.') {
3738                     char *f;
3739                     s++;
3740                     f = s;
3741                     while (*s == '#')
3742                         s++;
3743                     arg |= 256 + (s - f);
3744                 }
3745                 *fpc++ = s - base;              /* fieldsize for FETCH */
3746                 *fpc++ = FF_DECIMAL;
3747                 *fpc++ = (U16)arg;
3748                 unchopnum |= ! ischop;
3749             }
3750             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3751                 arg = ischop ? 512 : 0;
3752                 base = s - 1;
3753                 s++;                                /* skip the '0' first */
3754                 while (*s == '#')
3755                     s++;
3756                 if (*s == '.') {
3757                     char *f;
3758                     s++;
3759                     f = s;
3760                     while (*s == '#')
3761                         s++;
3762                     arg |= 256 + (s - f);
3763                 }
3764                 *fpc++ = s - base;                /* fieldsize for FETCH */
3765                 *fpc++ = FF_0DECIMAL;
3766                 *fpc++ = (U16)arg;
3767                 unchopnum |= ! ischop;
3768             }
3769             else {
3770                 I32 prespace = 0;
3771                 bool ismore = FALSE;
3772
3773                 if (*s == '>') {
3774                     while (*++s == '>') ;
3775                     prespace = FF_SPACE;
3776                 }
3777                 else if (*s == '|') {
3778                     while (*++s == '|') ;
3779                     prespace = FF_HALFSPACE;
3780                     postspace = TRUE;
3781                 }
3782                 else {
3783                     if (*s == '<')
3784                         while (*++s == '<') ;
3785                     postspace = TRUE;
3786                 }
3787                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3788                     s += 3;
3789                     ismore = TRUE;
3790                 }
3791                 *fpc++ = s - base;              /* fieldsize for FETCH */
3792
3793                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3794
3795                 if (prespace)
3796                     *fpc++ = (U16)prespace;
3797                 *fpc++ = FF_ITEM;
3798                 if (ismore)
3799                     *fpc++ = FF_MORE;
3800                 if (ischop)
3801                     *fpc++ = FF_CHOP;
3802             }
3803             base = s;
3804             skipspaces = 0;
3805             continue;
3806         }
3807     }
3808     *fpc++ = FF_END;
3809
3810     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3811     arg = fpc - fops;
3812     { /* need to jump to the next word */
3813         int z;
3814         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3815         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3816         s = SvPVX(sv) + SvCUR(sv) + z;
3817     }
3818     Copy(fops, s, arg, U32);
3819     Safefree(fops);
3820     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3821     SvCOMPILED_on(sv);
3822
3823     if (unchopnum && repeat)
3824         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3825     return 0;
3826 }
3827
3828
3829 STATIC bool
3830 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3831 {
3832     /* Can value be printed in fldsize chars, using %*.*f ? */
3833     NV pwr = 1;
3834     NV eps = 0.5;
3835     bool res = FALSE;
3836     int intsize = fldsize - (value < 0 ? 1 : 0);
3837
3838     if (frcsize & 256)
3839         intsize--;
3840     frcsize &= 255;
3841     intsize -= frcsize;
3842
3843     while (intsize--) pwr *= 10.0;
3844     while (frcsize--) eps /= 10.0;
3845
3846     if( value >= 0 ){
3847         if (value + eps >= pwr)
3848             res = TRUE;
3849     } else {
3850         if (value - eps <= -pwr)
3851             res = TRUE;
3852     }
3853     return res;
3854 }
3855
3856 static I32
3857 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3858 {
3859     SV *datasv = FILTER_DATA(idx);
3860     int filter_has_file = IoLINES(datasv);
3861     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3862     SV *filter_state = (SV *)IoTOP_GV(datasv);
3863     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3864     int len = 0;
3865
3866     /* I was having segfault trouble under Linux 2.2.5 after a
3867        parse error occured.  (Had to hack around it with a test
3868        for PL_error_count == 0.)  Solaris doesn't segfault --
3869        not sure where the trouble is yet.  XXX */
3870
3871     if (filter_has_file) {
3872         len = FILTER_READ(idx+1, buf_sv, maxlen);
3873     }
3874
3875     if (filter_sub && len >= 0) {
3876         dSP;
3877         int count;
3878
3879         ENTER;
3880         SAVE_DEFSV;
3881         SAVETMPS;
3882         EXTEND(SP, 2);
3883
3884         DEFSV = buf_sv;
3885         PUSHMARK(SP);
3886         PUSHs(sv_2mortal(newSViv(maxlen)));
3887         if (filter_state) {
3888             PUSHs(filter_state);
3889         }
3890         PUTBACK;
3891         count = call_sv(filter_sub, G_SCALAR);
3892         SPAGAIN;
3893
3894         if (count > 0) {
3895             SV *out = POPs;
3896             if (SvOK(out)) {
3897                 len = SvIV(out);
3898             }
3899         }
3900
3901         PUTBACK;
3902         FREETMPS;
3903         LEAVE;
3904     }
3905
3906     if (len <= 0) {
3907         IoLINES(datasv) = 0;
3908         if (filter_child_proc) {
3909             SvREFCNT_dec(filter_child_proc);
3910             IoFMT_GV(datasv) = Nullgv;
3911         }
3912         if (filter_state) {
3913             SvREFCNT_dec(filter_state);
3914             IoTOP_GV(datasv) = Nullgv;
3915         }
3916         if (filter_sub) {
3917             SvREFCNT_dec(filter_sub);
3918             IoBOTTOM_GV(datasv) = Nullgv;
3919         }
3920         filter_del(run_user_filter);
3921     }
3922
3923     return len;
3924 }
3925
3926 /* perhaps someone can come up with a better name for
3927    this?  it is not really "absolute", per se ... */
3928 static bool
3929 S_path_is_absolute(pTHX_ char *name)
3930 {
3931     if (PERL_FILE_IS_ABSOLUTE(name)
3932 #ifdef MACOS_TRADITIONAL
3933         || (*name == ':'))
3934 #else
3935         || (*name == '.' && (name[1] == '/' ||
3936                              (name[1] == '.' && name[2] == '/'))))
3937 #endif
3938     {
3939         return TRUE;
3940     }
3941     else
3942         return FALSE;
3943 }