pp_ctl.c

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