pp_ctl.c

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