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