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         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1780         SAVESPTR(*svp);
1781 #ifdef USE_ITHREADS
1782         iterdata = (void*)PL_op->op_targ;
1783         cxtype |= CXp_PADVAR;
1784 #endif
1785     }
1786     else {
1787         GV *gv = (GV*)POPs;
1788         svp = &GvSV(gv);                        /* symbol table variable */
1789         SAVEGENERICSV(*svp);
1790         *svp = NEWSV(0,0);
1791 #ifdef USE_ITHREADS
1792         iterdata = (void*)gv;
1793 #endif
1794     }
1795
1796     ENTER;
1797
1798     PUSHBLOCK(cx, cxtype, SP);
1799 #ifdef USE_ITHREADS
1800     PUSHLOOP(cx, iterdata, MARK);
1801 #else
1802     PUSHLOOP(cx, svp, MARK);
1803 #endif
1804     if (PL_op->op_flags & OPf_STACKED) {
1805         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1806         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1807             dPOPss;
1808             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1809                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1810                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1811                  looks_like_number((SV*)cx->blk_loop.iterary) &&
1812                  *SvPVX(cx->blk_loop.iterary) != '0'))
1813             {
1814                  if (SvNV(sv) < IV_MIN ||
1815                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1816                      DIE(aTHX_ "Range iterator outside integer range");
1817                  cx->blk_loop.iterix = SvIV(sv);
1818                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1819             }
1820             else
1821                 cx->blk_loop.iterlval = newSVsv(sv);
1822         }
1823     }
1824     else {
1825         cx->blk_loop.iterary = PL_curstack;
1826         AvFILLp(PL_curstack) = SP - PL_stack_base;
1827         cx->blk_loop.iterix = MARK - PL_stack_base;
1828     }
1829
1830     RETURN;
1831 }
1832
1833 PP(pp_enterloop)
1834 {
1835     djSP;
1836     register PERL_CONTEXT *cx;
1837     I32 gimme = GIMME_V;
1838
1839     ENTER;
1840     SAVETMPS;
1841     ENTER;
1842
1843     PUSHBLOCK(cx, CXt_LOOP, SP);
1844     PUSHLOOP(cx, 0, SP);
1845
1846     RETURN;
1847 }
1848
1849 PP(pp_leaveloop)
1850 {
1851     djSP;
1852     register PERL_CONTEXT *cx;
1853     I32 gimme;
1854     SV **newsp;
1855     PMOP *newpm;
1856     SV **mark;
1857
1858     POPBLOCK(cx,newpm);
1859     mark = newsp;
1860     newsp = PL_stack_base + cx->blk_loop.resetsp;
1861
1862     TAINT_NOT;
1863     if (gimme == G_VOID)
1864         ; /* do nothing */
1865     else if (gimme == G_SCALAR) {
1866         if (mark < SP)
1867             *++newsp = sv_mortalcopy(*SP);
1868         else
1869             *++newsp = &PL_sv_undef;
1870     }
1871     else {
1872         while (mark < SP) {
1873             *++newsp = sv_mortalcopy(*++mark);
1874             TAINT_NOT;          /* Each item is independent */
1875         }
1876     }
1877     SP = newsp;
1878     PUTBACK;
1879
1880     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1881     PL_curpm = newpm;   /* ... and pop $1 et al */
1882
1883     LEAVE;
1884     LEAVE;
1885
1886     return NORMAL;
1887 }
1888
1889 PP(pp_return)
1890 {
1891     djSP; dMARK;
1892     I32 cxix;
1893     register PERL_CONTEXT *cx;
1894     bool popsub2 = FALSE;
1895     bool clear_errsv = FALSE;
1896     I32 gimme;
1897     SV **newsp;
1898     PMOP *newpm;
1899     I32 optype = 0;
1900     SV *sv;
1901
1902     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1903         if (cxstack_ix == PL_sortcxix
1904             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1905         {
1906             if (cxstack_ix > PL_sortcxix)
1907                 dounwind(PL_sortcxix);
1908             AvARRAY(PL_curstack)[1] = *SP;
1909             PL_stack_sp = PL_stack_base + 1;
1910             return 0;
1911         }
1912     }
1913
1914     cxix = dopoptosub(cxstack_ix);
1915     if (cxix < 0)
1916         DIE(aTHX_ "Can't return outside a subroutine");
1917     if (cxix < cxstack_ix)
1918         dounwind(cxix);
1919
1920     POPBLOCK(cx,newpm);
1921     switch (CxTYPE(cx)) {
1922     case CXt_SUB:
1923         popsub2 = TRUE;
1924         break;
1925     case CXt_EVAL:
1926         if (!(PL_in_eval & EVAL_KEEPERR))
1927             clear_errsv = TRUE;
1928         POPEVAL(cx);
1929         if (CxTRYBLOCK(cx))
1930             break;
1931         if (AvFILLp(PL_comppad_name) >= 0)
1932             free_closures();
1933         lex_end();
1934         if (optype == OP_REQUIRE &&
1935             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1936         {
1937             /* Unassume the success we assumed earlier. */
1938             SV *nsv = cx->blk_eval.old_namesv;
1939             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1940             DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1941         }
1942         break;
1943     case CXt_FORMAT:
1944         POPFORMAT(cx);
1945         break;
1946     default:
1947         DIE(aTHX_ "panic: return");
1948     }
1949
1950     TAINT_NOT;
1951     if (gimme == G_SCALAR) {
1952         if (MARK < SP) {
1953             if (popsub2) {
1954                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1955                     if (SvTEMP(TOPs)) {
1956                         *++newsp = SvREFCNT_inc(*SP);
1957                         FREETMPS;
1958                         sv_2mortal(*newsp);
1959                     }
1960                     else {
1961                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1962                         FREETMPS;
1963                         *++newsp = sv_mortalcopy(sv);
1964                         SvREFCNT_dec(sv);
1965                     }
1966                 }
1967                 else
1968                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1969             }
1970             else
1971                 *++newsp = sv_mortalcopy(*SP);
1972         }
1973         else
1974             *++newsp = &PL_sv_undef;
1975     }
1976     else if (gimme == G_ARRAY) {
1977         while (++MARK <= SP) {
1978             *++newsp = (popsub2 && SvTEMP(*MARK))
1979                         ? *MARK : sv_mortalcopy(*MARK);
1980             TAINT_NOT;          /* Each item is independent */
1981         }
1982     }
1983     PL_stack_sp = newsp;
1984
1985     /* Stack values are safe: */
1986     if (popsub2) {
1987         POPSUB(cx,sv);  /* release CV and @_ ... */
1988     }
1989     else
1990         sv = Nullsv;
1991     PL_curpm = newpm;   /* ... and pop $1 et al */
1992
1993     LEAVE;
1994     LEAVESUB(sv);
1995     if (clear_errsv)
1996         sv_setpv(ERRSV,"");
1997     return pop_return();
1998 }
1999
2000 PP(pp_last)
2001 {
2002     djSP;
2003     I32 cxix;
2004     register PERL_CONTEXT *cx;
2005     I32 pop2 = 0;
2006     I32 gimme;
2007     I32 optype;
2008     OP *nextop;
2009     SV **newsp;
2010     PMOP *newpm;
2011     SV **mark;
2012     SV *sv = Nullsv;
2013
2014     if (PL_op->op_flags & OPf_SPECIAL) {
2015         cxix = dopoptoloop(cxstack_ix);
2016         if (cxix < 0)
2017             DIE(aTHX_ "Can't \"last\" outside a loop block");
2018     }
2019     else {
2020         cxix = dopoptolabel(cPVOP->op_pv);
2021         if (cxix < 0)
2022             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2023     }
2024     if (cxix < cxstack_ix)
2025         dounwind(cxix);
2026
2027     POPBLOCK(cx,newpm);
2028     mark = newsp;
2029     switch (CxTYPE(cx)) {
2030     case CXt_LOOP:
2031         pop2 = CXt_LOOP;
2032         newsp = PL_stack_base + cx->blk_loop.resetsp;
2033         nextop = cx->blk_loop.last_op->op_next;
2034         break;
2035     case CXt_SUB:
2036         pop2 = CXt_SUB;
2037         nextop = pop_return();
2038         break;
2039     case CXt_EVAL:
2040         POPEVAL(cx);
2041         nextop = pop_return();
2042         break;
2043     case CXt_FORMAT:
2044         POPFORMAT(cx);
2045         nextop = pop_return();
2046         break;
2047     default:
2048         DIE(aTHX_ "panic: last");
2049     }
2050
2051     TAINT_NOT;
2052     if (gimme == G_SCALAR) {
2053         if (MARK < SP)
2054             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2055                         ? *SP : sv_mortalcopy(*SP);
2056         else
2057             *++newsp = &PL_sv_undef;
2058     }
2059     else if (gimme == G_ARRAY) {
2060         while (++MARK <= SP) {
2061             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2062                         ? *MARK : sv_mortalcopy(*MARK);
2063             TAINT_NOT;          /* Each item is independent */
2064         }
2065     }
2066     SP = newsp;
2067     PUTBACK;
2068
2069     /* Stack values are safe: */
2070     switch (pop2) {
2071     case CXt_LOOP:
2072         POPLOOP(cx);    /* release loop vars ... */
2073         LEAVE;
2074         break;
2075     case CXt_SUB:
2076         POPSUB(cx,sv);  /* release CV and @_ ... */
2077         break;
2078     }
2079     PL_curpm = newpm;   /* ... and pop $1 et al */
2080
2081     LEAVE;
2082     LEAVESUB(sv);
2083     return nextop;
2084 }
2085
2086 PP(pp_next)
2087 {
2088     I32 cxix;
2089     register PERL_CONTEXT *cx;
2090     I32 inner;
2091
2092     if (PL_op->op_flags & OPf_SPECIAL) {
2093         cxix = dopoptoloop(cxstack_ix);
2094         if (cxix < 0)
2095             DIE(aTHX_ "Can't \"next\" outside a loop block");
2096     }
2097     else {
2098         cxix = dopoptolabel(cPVOP->op_pv);
2099         if (cxix < 0)
2100             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2101     }
2102     if (cxix < cxstack_ix)
2103         dounwind(cxix);
2104
2105     /* clear off anything above the scope we're re-entering, but
2106      * save the rest until after a possible continue block */
2107     inner = PL_scopestack_ix;
2108     TOPBLOCK(cx);
2109     if (PL_scopestack_ix < inner)
2110         leave_scope(PL_scopestack[PL_scopestack_ix]);
2111     return cx->blk_loop.next_op;
2112 }
2113
2114 PP(pp_redo)
2115 {
2116     I32 cxix;
2117     register PERL_CONTEXT *cx;
2118     I32 oldsave;
2119
2120     if (PL_op->op_flags & OPf_SPECIAL) {
2121         cxix = dopoptoloop(cxstack_ix);
2122         if (cxix < 0)
2123             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2124     }
2125     else {
2126         cxix = dopoptolabel(cPVOP->op_pv);
2127         if (cxix < 0)
2128             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2129     }
2130     if (cxix < cxstack_ix)
2131         dounwind(cxix);
2132
2133     TOPBLOCK(cx);
2134     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2135     LEAVE_SCOPE(oldsave);
2136     return cx->blk_loop.redo_op;
2137 }
2138
2139 STATIC OP *
2140 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2141 {
2142     OP *kid;
2143     OP **ops = opstack;
2144     static char too_deep[] = "Target of goto is too deeply nested";
2145
2146     if (ops >= oplimit)
2147         Perl_croak(aTHX_ too_deep);
2148     if (o->op_type == OP_LEAVE ||
2149         o->op_type == OP_SCOPE ||
2150         o->op_type == OP_LEAVELOOP ||
2151         o->op_type == OP_LEAVETRY)
2152     {
2153         *ops++ = cUNOPo->op_first;
2154         if (ops >= oplimit)
2155             Perl_croak(aTHX_ too_deep);
2156     }
2157     *ops = 0;
2158     if (o->op_flags & OPf_KIDS) {
2159         dTHR;
2160         /* First try all the kids at this level, since that's likeliest. */
2161         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2162             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2163                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2164                 return kid;
2165         }
2166         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2167             if (kid == PL_lastgotoprobe)
2168                 continue;
2169             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2170                 (ops == opstack ||
2171                  (ops[-1]->op_type != OP_NEXTSTATE &&
2172                   ops[-1]->op_type != OP_DBSTATE)))
2173                 *ops++ = kid;
2174             if ((o = dofindlabel(kid, label, ops, oplimit)))
2175                 return o;
2176         }
2177     }
2178     *ops = 0;
2179     return 0;
2180 }
2181
2182 PP(pp_dump)
2183 {
2184     return pp_goto();
2185     /*NOTREACHED*/
2186 }
2187
2188 PP(pp_goto)
2189 {
2190     djSP;
2191     OP *retop = 0;
2192     I32 ix;
2193     register PERL_CONTEXT *cx;
2194 #define GOTO_DEPTH 64
2195     OP *enterops[GOTO_DEPTH];
2196     char *label;
2197     int do_dump = (PL_op->op_type == OP_DUMP);
2198     static char must_have_label[] = "goto must have label";
2199
2200     label = 0;
2201     if (PL_op->op_flags & OPf_STACKED) {
2202         SV *sv = POPs;
2203         STRLEN n_a;
2204
2205         /* This egregious kludge implements goto &subroutine */
2206         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2207             I32 cxix;
2208             register PERL_CONTEXT *cx;
2209             CV* cv = (CV*)SvRV(sv);
2210             SV** mark;
2211             I32 items = 0;
2212             I32 oldsave;
2213
2214         retry:
2215             if (!CvROOT(cv) && !CvXSUB(cv)) {
2216                 GV *gv = CvGV(cv);
2217                 GV *autogv;
2218                 if (gv) {
2219                     SV *tmpstr;
2220                     /* autoloaded stub? */
2221                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2222                         goto retry;
2223                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2224                                           GvNAMELEN(gv), FALSE);
2225                     if (autogv && (cv = GvCV(autogv)))
2226                         goto retry;
2227                     tmpstr = sv_newmortal();
2228                     gv_efullname3(tmpstr, gv, Nullch);
2229                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2230                 }
2231                 DIE(aTHX_ "Goto undefined subroutine");
2232             }
2233
2234             /* First do some returnish stuff. */
2235             cxix = dopoptosub(cxstack_ix);
2236             if (cxix < 0)
2237                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2238             if (cxix < cxstack_ix)
2239                 dounwind(cxix);
2240             TOPBLOCK(cx);
2241             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2242                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2243             mark = PL_stack_sp;
2244             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2245                 /* put @_ back onto stack */
2246                 AV* av = cx->blk_sub.argarray;
2247
2248                 items = AvFILLp(av) + 1;
2249                 PL_stack_sp++;
2250                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2251                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2252                 PL_stack_sp += items;
2253 #ifndef USE_THREADS
2254                 SvREFCNT_dec(GvAV(PL_defgv));
2255                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2256 #endif /* USE_THREADS */
2257                 /* abandon @_ if it got reified */
2258                 if (AvREAL(av)) {
2259                     (void)sv_2mortal((SV*)av);  /* delay until return */
2260                     av = newAV();
2261                     av_extend(av, items-1);
2262                     AvFLAGS(av) = AVf_REIFY;
2263                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2264                 }
2265             }
2266             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2267                 AV* av;
2268 #ifdef USE_THREADS
2269                 av = (AV*)PL_curpad[0];
2270 #else
2271                 av = GvAV(PL_defgv);
2272 #endif
2273                 items = AvFILLp(av) + 1;
2274                 PL_stack_sp++;
2275                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2276                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2277                 PL_stack_sp += items;
2278             }
2279             if (CxTYPE(cx) == CXt_SUB &&
2280                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2281                 SvREFCNT_dec(cx->blk_sub.cv);
2282             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2283             LEAVE_SCOPE(oldsave);
2284
2285             /* Now do some callish stuff. */
2286             SAVETMPS;
2287             if (CvXSUB(cv)) {
2288 #ifdef PERL_XSUB_OLDSTYLE
2289                 if (CvOLDSTYLE(cv)) {
2290                     I32 (*fp3)(int,int,int);
2291                     while (SP > mark) {
2292                         SP[1] = SP[0];
2293                         SP--;
2294                     }
2295                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2296                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2297                                    mark - PL_stack_base + 1,
2298                                    items);
2299                     SP = PL_stack_base + items;
2300                 }
2301                 else
2302 #endif /* PERL_XSUB_OLDSTYLE */
2303                 {
2304                     SV **newsp;
2305                     I32 gimme;
2306
2307                     PL_stack_sp--;              /* There is no cv arg. */
2308                     /* Push a mark for the start of arglist */
2309                     PUSHMARK(mark);
2310                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2311                     /* Pop the current context like a decent sub should */
2312                     POPBLOCK(cx, PL_curpm);
2313                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2314                 }
2315                 LEAVE;
2316                 return pop_return();
2317             }
2318             else {
2319                 AV* padlist = CvPADLIST(cv);
2320                 SV** svp = AvARRAY(padlist);
2321                 if (CxTYPE(cx) == CXt_EVAL) {
2322                     PL_in_eval = cx->blk_eval.old_in_eval;
2323                     PL_eval_root = cx->blk_eval.old_eval_root;
2324                     cx->cx_type = CXt_SUB;
2325                     cx->blk_sub.hasargs = 0;
2326                 }
2327                 cx->blk_sub.cv = cv;
2328                 cx->blk_sub.olddepth = CvDEPTH(cv);
2329                 CvDEPTH(cv)++;
2330                 if (CvDEPTH(cv) < 2)
2331                     (void)SvREFCNT_inc(cv);
2332                 else {  /* save temporaries on recursion? */
2333                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2334                         sub_crush_depth(cv);
2335                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2336                         AV *newpad = newAV();
2337                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2338                         I32 ix = AvFILLp((AV*)svp[1]);
2339                         I32 names_fill = AvFILLp((AV*)svp[0]);
2340                         svp = AvARRAY(svp[0]);
2341                         for ( ;ix > 0; ix--) {
2342                             if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2343                                 char *name = SvPVX(svp[ix]);
2344                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2345                                     || *name == '&')
2346                                 {
2347                                     /* outer lexical or anon code */
2348                                     av_store(newpad, ix,
2349                                         SvREFCNT_inc(oldpad[ix]) );
2350                                 }
2351                                 else {          /* our own lexical */
2352                                     if (*name == '@')
2353                                         av_store(newpad, ix, sv = (SV*)newAV());
2354                                     else if (*name == '%')
2355                                         av_store(newpad, ix, sv = (SV*)newHV());
2356                                     else
2357                                         av_store(newpad, ix, sv = NEWSV(0,0));
2358                                     SvPADMY_on(sv);
2359                                 }
2360                             }
2361                             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2362                                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2363                             }
2364                             else {
2365                                 av_store(newpad, ix, sv = NEWSV(0,0));
2366                                 SvPADTMP_on(sv);
2367                             }
2368                         }
2369                         if (cx->blk_sub.hasargs) {
2370                             AV* av = newAV();
2371                             av_extend(av, 0);
2372                             av_store(newpad, 0, (SV*)av);
2373                             AvFLAGS(av) = AVf_REIFY;
2374                         }
2375                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2376                         AvFILLp(padlist) = CvDEPTH(cv);
2377                         svp = AvARRAY(padlist);
2378                     }
2379                 }
2380 #ifdef USE_THREADS
2381                 if (!cx->blk_sub.hasargs) {
2382                     AV* av = (AV*)PL_curpad[0];
2383
2384                     items = AvFILLp(av) + 1;
2385                     if (items) {
2386                         /* Mark is at the end of the stack. */
2387                         EXTEND(SP, items);
2388                         Copy(AvARRAY(av), SP + 1, items, SV*);
2389                         SP += items;
2390                         PUTBACK ;
2391                     }
2392                 }
2393 #endif /* USE_THREADS */
2394                 SAVEVPTR(PL_curpad);
2395                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2396 #ifndef USE_THREADS
2397                 if (cx->blk_sub.hasargs)
2398 #endif /* USE_THREADS */
2399                 {
2400                     AV* av = (AV*)PL_curpad[0];
2401                     SV** ary;
2402
2403 #ifndef USE_THREADS
2404                     cx->blk_sub.savearray = GvAV(PL_defgv);
2405                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2406 #endif /* USE_THREADS */
2407                     cx->blk_sub.oldcurpad = PL_curpad;
2408                     cx->blk_sub.argarray = av;
2409                     ++mark;
2410
2411                     if (items >= AvMAX(av) + 1) {
2412                         ary = AvALLOC(av);
2413                         if (AvARRAY(av) != ary) {
2414                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2415                             SvPVX(av) = (char*)ary;
2416                         }
2417                         if (items >= AvMAX(av) + 1) {
2418                             AvMAX(av) = items - 1;
2419                             Renew(ary,items+1,SV*);
2420                             AvALLOC(av) = ary;
2421                             SvPVX(av) = (char*)ary;
2422                         }
2423                     }
2424                     Copy(mark,AvARRAY(av),items,SV*);
2425                     AvFILLp(av) = items - 1;
2426                     assert(!AvREAL(av));
2427                     while (items--) {
2428                         if (*mark)
2429                             SvTEMP_off(*mark);
2430                         mark++;
2431                     }
2432                 }
2433                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2434                     /*
2435                      * We do not care about using sv to call CV;
2436                      * it's for informational purposes only.
2437                      */
2438                     SV *sv = GvSV(PL_DBsub);
2439                     CV *gotocv;
2440
2441                     if (PERLDB_SUB_NN) {
2442                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2443                     } else {
2444                         save_item(sv);
2445                         gv_efullname3(sv, CvGV(cv), Nullch);
2446                     }
2447                     if (  PERLDB_GOTO
2448                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2449                         PUSHMARK( PL_stack_sp );
2450                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2451                         PL_stack_sp--;
2452                     }
2453                 }
2454                 RETURNOP(CvSTART(cv));
2455             }
2456         }
2457         else {
2458             label = SvPV(sv,n_a);
2459             if (!(do_dump || *label))
2460                 DIE(aTHX_ must_have_label);
2461         }
2462     }
2463     else if (PL_op->op_flags & OPf_SPECIAL) {
2464         if (! do_dump)
2465             DIE(aTHX_ must_have_label);
2466     }
2467     else
2468         label = cPVOP->op_pv;
2469
2470     if (label && *label) {
2471         OP *gotoprobe = 0;
2472
2473         /* find label */
2474
2475         PL_lastgotoprobe = 0;
2476         *enterops = 0;
2477         for (ix = cxstack_ix; ix >= 0; ix--) {
2478             cx = &cxstack[ix];
2479             switch (CxTYPE(cx)) {
2480             case CXt_EVAL:
2481                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2482                 break;
2483             case CXt_LOOP:
2484                 gotoprobe = cx->blk_oldcop->op_sibling;
2485                 break;
2486             case CXt_SUBST:
2487                 continue;
2488             case CXt_BLOCK:
2489                 if (ix)
2490                     gotoprobe = cx->blk_oldcop->op_sibling;
2491                 else
2492                     gotoprobe = PL_main_root;
2493                 break;
2494             case CXt_SUB:
2495                 if (CvDEPTH(cx->blk_sub.cv)) {
2496                     gotoprobe = CvROOT(cx->blk_sub.cv);
2497                     break;
2498                 }
2499                 /* FALL THROUGH */
2500             case CXt_FORMAT:
2501             case CXt_NULL:
2502                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2503             default:
2504                 if (ix)
2505                     DIE(aTHX_ "panic: goto");
2506                 gotoprobe = PL_main_root;
2507                 break;
2508             }
2509             if (gotoprobe) {
2510                 retop = dofindlabel(gotoprobe, label,
2511                                     enterops, enterops + GOTO_DEPTH);
2512                 if (retop)
2513                     break;
2514             }
2515             PL_lastgotoprobe = gotoprobe;
2516         }
2517         if (!retop)
2518             DIE(aTHX_ "Can't find label %s", label);
2519
2520         /* pop unwanted frames */
2521
2522         if (ix < cxstack_ix) {
2523             I32 oldsave;
2524
2525             if (ix < 0)
2526                 ix = 0;
2527             dounwind(ix);
2528             TOPBLOCK(cx);
2529             oldsave = PL_scopestack[PL_scopestack_ix];
2530             LEAVE_SCOPE(oldsave);
2531         }
2532
2533         /* push wanted frames */
2534
2535         if (*enterops && enterops[1]) {
2536             OP *oldop = PL_op;
2537             for (ix = 1; enterops[ix]; ix++) {
2538                 PL_op = enterops[ix];
2539                 /* Eventually we may want to stack the needed arguments
2540                  * for each op.  For now, we punt on the hard ones. */
2541                 if (PL_op->op_type == OP_ENTERITER)
2542                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2543                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2544             }
2545             PL_op = oldop;
2546         }
2547     }
2548
2549     if (do_dump) {
2550 #ifdef VMS
2551         if (!retop) retop = PL_main_start;
2552 #endif
2553         PL_restartop = retop;
2554         PL_do_undump = TRUE;
2555
2556         my_unexec();
2557
2558         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2559         PL_do_undump = FALSE;
2560     }
2561
2562     RETURNOP(retop);
2563 }
2564
2565 PP(pp_exit)
2566 {
2567     djSP;
2568     I32 anum;
2569
2570     if (MAXARG < 1)
2571         anum = 0;
2572     else {
2573         anum = SvIVx(POPs);
2574 #ifdef VMS
2575         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2576             anum = 0;
2577 #endif
2578     }
2579     PL_exit_flags |= PERL_EXIT_EXPECTED;
2580     my_exit(anum);
2581     PUSHs(&PL_sv_undef);
2582     RETURN;
2583 }
2584
2585 #ifdef NOTYET
2586 PP(pp_nswitch)
2587 {
2588     djSP;
2589     NV value = SvNVx(GvSV(cCOP->cop_gv));
2590     register I32 match = I_32(value);
2591
2592     if (value < 0.0) {
2593         if (((NV)match) > value)
2594             --match;            /* was fractional--truncate other way */
2595     }
2596     match -= cCOP->uop.scop.scop_offset;
2597     if (match < 0)
2598         match = 0;
2599     else if (match > cCOP->uop.scop.scop_max)
2600         match = cCOP->uop.scop.scop_max;
2601     PL_op = cCOP->uop.scop.scop_next[match];
2602     RETURNOP(PL_op);
2603 }
2604
2605 PP(pp_cswitch)
2606 {
2607     djSP;
2608     register I32 match;
2609
2610     if (PL_multiline)
2611         PL_op = PL_op->op_next;                 /* can't assume anything */
2612     else {
2613         STRLEN n_a;
2614         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2615         match -= cCOP->uop.scop.scop_offset;
2616         if (match < 0)
2617             match = 0;
2618         else if (match > cCOP->uop.scop.scop_max)
2619             match = cCOP->uop.scop.scop_max;
2620         PL_op = cCOP->uop.scop.scop_next[match];
2621     }
2622     RETURNOP(PL_op);
2623 }
2624 #endif
2625
2626 /* Eval. */
2627
2628 STATIC void
2629 S_save_lines(pTHX_ AV *array, SV *sv)
2630 {
2631     register char *s = SvPVX(sv);
2632     register char *send = SvPVX(sv) + SvCUR(sv);
2633     register char *t;
2634     register I32 line = 1;
2635
2636     while (s && s < send) {
2637         SV *tmpstr = NEWSV(85,0);
2638
2639         sv_upgrade(tmpstr, SVt_PVMG);
2640         t = strchr(s, '\n');
2641         if (t)
2642             t++;
2643         else
2644             t = send;
2645
2646         sv_setpvn(tmpstr, s, t - s);
2647         av_store(array, line++, tmpstr);
2648         s = t;
2649     }
2650 }
2651
2652 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2653 STATIC void *
2654 S_docatch_body(pTHX_ va_list args)
2655 {
2656     return docatch_body();
2657 }
2658 #endif
2659
2660 STATIC void *
2661 S_docatch_body(pTHX)
2662 {
2663     CALLRUNOPS(aTHX);
2664     return NULL;
2665 }
2666
2667 STATIC OP *
2668 S_docatch(pTHX_ OP *o)
2669 {
2670     dTHR;
2671     int ret;
2672     OP *oldop = PL_op;
2673     volatile PERL_SI *cursi = PL_curstackinfo;
2674     dJMPENV;
2675
2676 #ifdef DEBUGGING
2677     assert(CATCH_GET == TRUE);
2678 #endif
2679     PL_op = o;
2680 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2681  redo_body:
2682     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2683 #else
2684     JMPENV_PUSH(ret);
2685 #endif
2686     switch (ret) {
2687     case 0:
2688 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2689  redo_body:
2690         docatch_body();
2691 #endif
2692         break;
2693     case 3:
2694         if (PL_restartop && cursi == PL_curstackinfo) {
2695             PL_op = PL_restartop;
2696             PL_restartop = 0;
2697             goto redo_body;
2698         }
2699         /* FALL THROUGH */
2700     default:
2701         JMPENV_POP;
2702         PL_op = oldop;
2703         JMPENV_JUMP(ret);
2704         /* NOTREACHED */
2705     }
2706     JMPENV_POP;
2707     PL_op = oldop;
2708     return Nullop;
2709 }
2710
2711 OP *
2712 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2713 /* sv Text to convert to OP tree. */
2714 /* startop op_free() this to undo. */
2715 /* code Short string id of the caller. */
2716 {
2717     dSP;                                /* Make POPBLOCK work. */
2718     PERL_CONTEXT *cx;
2719     SV **newsp;
2720     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2721     I32 optype;
2722     OP dummy;
2723     OP *rop;
2724     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2725     char *tmpbuf = tbuf;
2726     char *safestr;
2727
2728     ENTER;
2729     lex_start(sv);
2730     SAVETMPS;
2731     /* switch to eval mode */
2732
2733     if (PL_curcop == &PL_compiling) {
2734         SAVECOPSTASH_FREE(&PL_compiling);
2735         CopSTASH_set(&PL_compiling, PL_curstash);
2736     }
2737     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2738         SV *sv = sv_newmortal();
2739         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2740                        code, (unsigned long)++PL_evalseq,
2741                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2742         tmpbuf = SvPVX(sv);
2743     }
2744     else
2745         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2746     SAVECOPFILE_FREE(&PL_compiling);
2747     CopFILE_set(&PL_compiling, tmpbuf+2);
2748     SAVECOPLINE(&PL_compiling);
2749     CopLINE_set(&PL_compiling, 1);
2750     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2751        deleting the eval's FILEGV from the stash before gv_check() runs
2752        (i.e. before run-time proper). To work around the coredump that
2753        ensues, we always turn GvMULTI_on for any globals that were
2754        introduced within evals. See force_ident(). GSAR 96-10-12 */
2755     safestr = savepv(tmpbuf);
2756     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2757     SAVEHINTS();
2758 #ifdef OP_IN_REGISTER
2759     PL_opsave = op;
2760 #else
2761     SAVEVPTR(PL_op);
2762 #endif
2763     PL_hints = 0;
2764
2765     PL_op = &dummy;
2766     PL_op->op_type = OP_ENTEREVAL;
2767     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2768     PUSHBLOCK(cx, CXt_EVAL, SP);
2769     PUSHEVAL(cx, 0, Nullgv);
2770     rop = doeval(G_SCALAR, startop);
2771     POPBLOCK(cx,PL_curpm);
2772     POPEVAL(cx);
2773
2774     (*startop)->op_type = OP_NULL;
2775     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2776     lex_end();
2777     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2778     LEAVE;
2779     if (PL_curcop == &PL_compiling)
2780         PL_compiling.op_private = PL_hints;
2781 #ifdef OP_IN_REGISTER
2782     op = PL_opsave;
2783 #endif
2784     return rop;
2785 }
2786
2787 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2788 STATIC OP *
2789 S_doeval(pTHX_ int gimme, OP** startop)
2790 {
2791     dSP;
2792     OP *saveop = PL_op;
2793     CV *caller;
2794     AV* comppadlist;
2795     I32 i;
2796
2797     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2798                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2799                   : EVAL_INEVAL);
2800
2801     PUSHMARK(SP);
2802
2803     /* set up a scratch pad */
2804
2805     SAVEI32(PL_padix);
2806     SAVEVPTR(PL_curpad);
2807     SAVESPTR(PL_comppad);
2808     SAVESPTR(PL_comppad_name);
2809     SAVEI32(PL_comppad_name_fill);
2810     SAVEI32(PL_min_intro_pending);
2811     SAVEI32(PL_max_intro_pending);
2812
2813     caller = PL_compcv;
2814     for (i = cxstack_ix - 1; i >= 0; i--) {
2815         PERL_CONTEXT *cx = &cxstack[i];
2816         if (CxTYPE(cx) == CXt_EVAL)
2817             break;
2818         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2819             caller = cx->blk_sub.cv;
2820             break;
2821         }
2822     }
2823
2824     SAVESPTR(PL_compcv);
2825     PL_compcv = (CV*)NEWSV(1104,0);
2826     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2827     CvEVAL_on(PL_compcv);
2828 #ifdef USE_THREADS
2829     CvOWNER(PL_compcv) = 0;
2830     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2831     MUTEX_INIT(CvMUTEXP(PL_compcv));
2832 #endif /* USE_THREADS */
2833
2834     PL_comppad = newAV();
2835     av_push(PL_comppad, Nullsv);
2836     PL_curpad = AvARRAY(PL_comppad);
2837     PL_comppad_name = newAV();
2838     PL_comppad_name_fill = 0;
2839     PL_min_intro_pending = 0;
2840     PL_padix = 0;
2841 #ifdef USE_THREADS
2842     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2843     PL_curpad[0] = (SV*)newAV();
2844     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2845 #endif /* USE_THREADS */
2846
2847     comppadlist = newAV();
2848     AvREAL_off(comppadlist);
2849     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2850     av_store(comppadlist, 1, (SV*)PL_comppad);
2851     CvPADLIST(PL_compcv) = comppadlist;
2852
2853     if (!saveop ||
2854         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2855     {
2856         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2857     }
2858
2859     SAVEFREESV(PL_compcv);
2860
2861     /* make sure we compile in the right package */
2862
2863     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2864         SAVESPTR(PL_curstash);
2865         PL_curstash = CopSTASH(PL_curcop);
2866     }
2867     SAVESPTR(PL_beginav);
2868     PL_beginav = newAV();
2869     SAVEFREESV(PL_beginav);
2870     SAVEI32(PL_error_count);
2871
2872     /* try to compile it */
2873
2874     PL_eval_root = Nullop;
2875     PL_error_count = 0;
2876     PL_curcop = &PL_compiling;
2877     PL_curcop->cop_arybase = 0;
2878     SvREFCNT_dec(PL_rs);
2879     PL_rs = newSVpvn("\n", 1);
2880     if (saveop && saveop->op_flags & OPf_SPECIAL)
2881         PL_in_eval |= EVAL_KEEPERR;
2882     else
2883         sv_setpv(ERRSV,"");
2884     if (yyparse() || PL_error_count || !PL_eval_root) {
2885         SV **newsp;
2886         I32 gimme;
2887         PERL_CONTEXT *cx;
2888         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2889         STRLEN n_a;
2890
2891         PL_op = saveop;
2892         if (PL_eval_root) {
2893             op_free(PL_eval_root);
2894             PL_eval_root = Nullop;
2895         }
2896         SP = PL_stack_base + POPMARK;           /* pop original mark */
2897         if (!startop) {
2898             POPBLOCK(cx,PL_curpm);
2899             POPEVAL(cx);
2900             pop_return();
2901         }
2902         lex_end();
2903         LEAVE;
2904         if (optype == OP_REQUIRE) {
2905             char* msg = SvPVx(ERRSV, n_a);
2906             DIE(aTHX_ "%sCompilation failed in require",
2907                 *msg ? msg : "Unknown error\n");
2908         }
2909         else if (startop) {
2910             char* msg = SvPVx(ERRSV, n_a);
2911
2912             POPBLOCK(cx,PL_curpm);
2913             POPEVAL(cx);
2914             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2915                        (*msg ? msg : "Unknown error\n"));
2916         }
2917         SvREFCNT_dec(PL_rs);
2918         PL_rs = SvREFCNT_inc(PL_nrs);
2919 #ifdef USE_THREADS
2920         MUTEX_LOCK(&PL_eval_mutex);
2921         PL_eval_owner = 0;
2922         COND_SIGNAL(&PL_eval_cond);
2923         MUTEX_UNLOCK(&PL_eval_mutex);
2924 #endif /* USE_THREADS */
2925         RETPUSHUNDEF;
2926     }
2927     SvREFCNT_dec(PL_rs);
2928     PL_rs = SvREFCNT_inc(PL_nrs);
2929     CopLINE_set(&PL_compiling, 0);
2930     if (startop) {
2931         *startop = PL_eval_root;
2932         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2933         CvOUTSIDE(PL_compcv) = Nullcv;
2934     } else
2935         SAVEFREEOP(PL_eval_root);
2936     if (gimme & G_VOID)
2937         scalarvoid(PL_eval_root);
2938     else if (gimme & G_ARRAY)
2939         list(PL_eval_root);
2940     else
2941         scalar(PL_eval_root);
2942
2943     DEBUG_x(dump_eval());
2944
2945     /* Register with debugger: */
2946     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2947         CV *cv = get_cv("DB::postponed", FALSE);
2948         if (cv) {
2949             dSP;
2950             PUSHMARK(SP);
2951             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2952             PUTBACK;
2953             call_sv((SV*)cv, G_DISCARD);
2954         }
2955     }
2956
2957     /* compiled okay, so do it */
2958
2959     CvDEPTH(PL_compcv) = 1;
2960     SP = PL_stack_base + POPMARK;               /* pop original mark */
2961     PL_op = saveop;                     /* The caller may need it. */
2962     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2963 #ifdef USE_THREADS
2964     MUTEX_LOCK(&PL_eval_mutex);
2965     PL_eval_owner = 0;
2966     COND_SIGNAL(&PL_eval_cond);
2967     MUTEX_UNLOCK(&PL_eval_mutex);
2968 #endif /* USE_THREADS */
2969
2970     RETURNOP(PL_eval_start);
2971 }
2972
2973 STATIC PerlIO *
2974 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2975 {
2976     STRLEN namelen = strlen(name);
2977     PerlIO *fp;
2978
2979     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2980         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2981         char *pmc = SvPV_nolen(pmcsv);
2982         Stat_t pmstat;
2983         Stat_t pmcstat;
2984         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2985             fp = PerlIO_open(name, mode);
2986         }
2987         else {
2988             if (PerlLIO_stat(name, &pmstat) < 0 ||
2989                 pmstat.st_mtime < pmcstat.st_mtime)
2990             {
2991                 fp = PerlIO_open(pmc, mode);
2992             }
2993             else {
2994                 fp = PerlIO_open(name, mode);
2995             }
2996         }
2997         SvREFCNT_dec(pmcsv);
2998     }
2999     else {
3000         fp = PerlIO_open(name, mode);
3001     }
3002     return fp;
3003 }
3004
3005 PP(pp_require)
3006 {
3007     djSP;
3008     register PERL_CONTEXT *cx;
3009     SV *sv;
3010     char *name;
3011     STRLEN len;
3012     char *tryname;
3013     SV *namesv = Nullsv;
3014     SV** svp;
3015     I32 gimme = G_SCALAR;
3016     PerlIO *tryrsfp = 0;
3017     STRLEN n_a;
3018     int filter_has_file = 0;
3019     GV *filter_child_proc = 0;
3020     SV *filter_state = 0;
3021     SV *filter_sub = 0;
3022
3023     sv = POPs;
3024     if (SvNIOKp(sv)) {
3025         if (SvPOK(sv) && SvNOK(sv)) {           /* require v5.6.1 */
3026             UV rev = 0, ver = 0, sver = 0;
3027             STRLEN len;
3028             U8 *s = (U8*)SvPVX(sv);
3029             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3030             if (s < end) {
3031                 rev = utf8_to_uv(s, end - s, &len, 0);
3032                 s += len;
3033                 if (s < end) {
3034                     ver = utf8_to_uv(s, end - s, &len, 0);
3035                     s += len;
3036                     if (s < end)
3037                         sver = utf8_to_uv(s, end - s, &len, 0);
3038                 }
3039             }
3040             if (PERL_REVISION < rev
3041                 || (PERL_REVISION == rev
3042                     && (PERL_VERSION < ver
3043                         || (PERL_VERSION == ver
3044                             && PERL_SUBVERSION < sver))))
3045             {
3046                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3047                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3048                     PERL_VERSION, PERL_SUBVERSION);
3049             }
3050             RETPUSHYES;
3051         }
3052         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3053             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3054                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3055                 + 0.00000099 < SvNV(sv))
3056             {
3057                 NV nrev = SvNV(sv);
3058                 UV rev = (UV)nrev;
3059                 NV nver = (nrev - rev) * 1000;
3060                 UV ver = (UV)(nver + 0.0009);
3061                 NV nsver = (nver - ver) * 1000;
3062                 UV sver = (UV)(nsver + 0.0009);
3063
3064                 /* help out with the "use 5.6" confusion */
3065                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3066                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3067                         "this is only v%d.%d.%d, stopped"
3068                         " (did you mean v%"UVuf".%"UVuf".0?)",
3069                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3070                         PERL_SUBVERSION, rev, ver/100);
3071                 }
3072                 else {
3073                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3074                         "this is only v%d.%d.%d, stopped",
3075                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3076                         PERL_SUBVERSION);
3077                 }
3078             }
3079             RETPUSHYES;
3080         }
3081     }
3082     name = SvPV(sv, len);
3083     if (!(name && len > 0 && *name))
3084         DIE(aTHX_ "Null filename used");
3085     TAINT_PROPER("require");
3086     if (PL_op->op_type == OP_REQUIRE &&
3087       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3088       *svp != &PL_sv_undef)
3089         RETPUSHYES;
3090
3091     /* prepare to compile file */
3092
3093     if (PERL_FILE_IS_ABSOLUTE(name)
3094         || (*name == '.' && (name[1] == '/' ||
3095                              (name[1] == '.' && name[2] == '/'))))
3096     {
3097         tryname = name;
3098         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3099 #ifdef MACOS_TRADITIONAL
3100         /* We consider paths of the form :a:b ambiguous and interpret them first
3101            as global then as local
3102         */
3103         if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3104             goto trylocal;
3105     }
3106     else
3107 trylocal: {
3108 #else
3109     }
3110     else {
3111 #endif
3112         AV *ar = GvAVn(PL_incgv);
3113         I32 i;
3114 #ifdef VMS
3115         char *unixname;
3116         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3117 #endif
3118         {
3119             namesv = NEWSV(806, 0);
3120             for (i = 0; i <= AvFILL(ar); i++) {
3121                 SV *dirsv = *av_fetch(ar, i, TRUE);
3122
3123                 if (SvROK(dirsv)) {
3124                     int count;
3125                     SV *loader = dirsv;
3126
3127                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3128                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3129                     }
3130
3131                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3132                                    PTR2UV(SvANY(loader)), name);
3133                     tryname = SvPVX(namesv);
3134                     tryrsfp = 0;
3135
3136                     ENTER;
3137                     SAVETMPS;
3138                     EXTEND(SP, 2);
3139
3140                     PUSHMARK(SP);
3141                     PUSHs(dirsv);
3142                     PUSHs(sv);
3143                     PUTBACK;
3144                     count = call_sv(loader, G_ARRAY);
3145                     SPAGAIN;
3146
3147                     if (count > 0) {
3148                         int i = 0;
3149                         SV *arg;
3150
3151                         SP -= count - 1;
3152                         arg = SP[i++];
3153
3154                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3155                             arg = SvRV(arg);
3156                         }
3157
3158                         if (SvTYPE(arg) == SVt_PVGV) {
3159                             IO *io = GvIO((GV *)arg);
3160
3161                             ++filter_has_file;
3162
3163                             if (io) {
3164                                 tryrsfp = IoIFP(io);
3165                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3166                                     /* reading from a child process doesn't
3167                                        nest -- when returning from reading
3168                                        the inner module, the outer one is
3169                                        unreadable (closed?)  I've tried to
3170                                        save the gv to manage the lifespan of
3171                                        the pipe, but this didn't help. XXX */
3172                                     filter_child_proc = (GV *)arg;
3173                                     (void)SvREFCNT_inc(filter_child_proc);
3174                                 }
3175                                 else {
3176                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3177                                         PerlIO_close(IoOFP(io));
3178                                     }
3179                                     IoIFP(io) = Nullfp;
3180                                     IoOFP(io) = Nullfp;
3181                                 }
3182                             }
3183
3184                             if (i < count) {
3185                                 arg = SP[i++];
3186                             }
3187                         }
3188
3189                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3190                             filter_sub = arg;
3191                             (void)SvREFCNT_inc(filter_sub);
3192
3193                             if (i < count) {
3194                                 filter_state = SP[i];
3195                                 (void)SvREFCNT_inc(filter_state);
3196                             }
3197
3198                             if (tryrsfp == 0) {
3199                                 tryrsfp = PerlIO_open("/dev/null",
3200                                                       PERL_SCRIPT_MODE);
3201                             }
3202                         }
3203                     }
3204
3205                     PUTBACK;
3206                     FREETMPS;
3207                     LEAVE;
3208
3209                     if (tryrsfp) {
3210                         break;
3211                     }
3212
3213                     filter_has_file = 0;
3214                     if (filter_child_proc) {
3215                         SvREFCNT_dec(filter_child_proc);
3216                         filter_child_proc = 0;
3217                     }
3218                     if (filter_state) {
3219                         SvREFCNT_dec(filter_state);
3220                         filter_state = 0;
3221                     }
3222                     if (filter_sub) {
3223                         SvREFCNT_dec(filter_sub);
3224                         filter_sub = 0;
3225                     }
3226                 }
3227                 else {
3228                     char *dir = SvPVx(dirsv, n_a);
3229 #ifdef MACOS_TRADITIONAL
3230                     char buf[256];
3231                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3232 #else
3233 #ifdef VMS
3234                     char *unixdir;
3235                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3236                         continue;
3237                     sv_setpv(namesv, unixdir);
3238                     sv_catpv(namesv, unixname);
3239 #else
3240                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3241 #endif
3242 #endif
3243                     TAINT_PROPER("require");
3244                     tryname = SvPVX(namesv);
3245 #ifdef MACOS_TRADITIONAL
3246                     {
3247                         /* Convert slashes in the name part, but not the directory part, to colons */
3248                         char * colon;
3249                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3250                             *colon++ = ':';
3251                     }
3252 #endif
3253                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3254                     if (tryrsfp) {
3255                         if (tryname[0] == '.' && tryname[1] == '/')
3256                             tryname += 2;
3257                         break;
3258                     }
3259                 }
3260             }
3261         }
3262     }
3263     SAVECOPFILE_FREE(&PL_compiling);
3264     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3265     SvREFCNT_dec(namesv);
3266     if (!tryrsfp) {
3267         if (PL_op->op_type == OP_REQUIRE) {
3268             char *msgstr = name;
3269             if (namesv) {                       /* did we lookup @INC? */
3270                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3271                 SV *dirmsgsv = NEWSV(0, 0);
3272                 AV *ar = GvAVn(PL_incgv);
3273                 I32 i;
3274                 sv_catpvn(msg, " in @INC", 8);
3275                 if (instr(SvPVX(msg), ".h "))
3276                     sv_catpv(msg, " (change .h to .ph maybe?)");
3277                 if (instr(SvPVX(msg), ".ph "))
3278                     sv_catpv(msg, " (did you run h2ph?)");
3279                 sv_catpv(msg, " (@INC contains:");
3280                 for (i = 0; i <= AvFILL(ar); i++) {
3281                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3282                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3283                     sv_catsv(msg, dirmsgsv);
3284                 }
3285                 sv_catpvn(msg, ")", 1);
3286                 SvREFCNT_dec(dirmsgsv);
3287                 msgstr = SvPV_nolen(msg);
3288             }
3289             DIE(aTHX_ "Can't locate %s", msgstr);
3290         }
3291
3292         RETPUSHUNDEF;
3293     }
3294     else
3295         SETERRNO(0, SS$_NORMAL);
3296
3297     /* Assume success here to prevent recursive requirement. */
3298     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3299                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3300
3301     ENTER;
3302     SAVETMPS;
3303     lex_start(sv_2mortal(newSVpvn("",0)));
3304     SAVEGENERICSV(PL_rsfp_filters);
3305     PL_rsfp_filters = Nullav;
3306
3307     PL_rsfp = tryrsfp;
3308     SAVEHINTS();
3309     PL_hints = 0;
3310     SAVESPTR(PL_compiling.cop_warnings);
3311     if (PL_dowarn & G_WARN_ALL_ON)
3312         PL_compiling.cop_warnings = pWARN_ALL ;
3313     else if (PL_dowarn & G_WARN_ALL_OFF)
3314         PL_compiling.cop_warnings = pWARN_NONE ;
3315     else
3316         PL_compiling.cop_warnings = pWARN_STD ;
3317
3318     if (filter_sub || filter_child_proc) {
3319         SV *datasv = filter_add(run_user_filter, Nullsv);
3320         IoLINES(datasv) = filter_has_file;
3321         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3322         IoTOP_GV(datasv) = (GV *)filter_state;
3323         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3324     }
3325
3326     /* switch to eval mode */
3327     push_return(PL_op->op_next);
3328     PUSHBLOCK(cx, CXt_EVAL, SP);
3329     PUSHEVAL(cx, name, Nullgv);
3330
3331     SAVECOPLINE(&PL_compiling);
3332     CopLINE_set(&PL_compiling, 0);
3333
3334     PUTBACK;
3335 #ifdef USE_THREADS
3336     MUTEX_LOCK(&PL_eval_mutex);
3337     if (PL_eval_owner && PL_eval_owner != thr)
3338         while (PL_eval_owner)
3339             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3340     PL_eval_owner = thr;
3341     MUTEX_UNLOCK(&PL_eval_mutex);
3342 #endif /* USE_THREADS */
3343     return DOCATCH(doeval(G_SCALAR, NULL));
3344 }
3345
3346 PP(pp_dofile)
3347 {
3348     return pp_require();
3349 }
3350
3351 PP(pp_entereval)
3352 {
3353     djSP;
3354     register PERL_CONTEXT *cx;
3355     dPOPss;
3356     I32 gimme = GIMME_V, was = PL_sub_generation;
3357     char tbuf[TYPE_DIGITS(long) + 12];
3358     char *tmpbuf = tbuf;
3359     char *safestr;
3360     STRLEN len;
3361     OP *ret;
3362
3363     if (!SvPV(sv,len) || !len)
3364         RETPUSHUNDEF;
3365     TAINT_PROPER("eval");
3366
3367     ENTER;
3368     lex_start(sv);
3369     SAVETMPS;
3370
3371     /* switch to eval mode */
3372
3373     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3374         SV *sv = sv_newmortal();
3375         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3376                        (unsigned long)++PL_evalseq,
3377                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3378         tmpbuf = SvPVX(sv);
3379     }
3380     else
3381         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3382     SAVECOPFILE_FREE(&PL_compiling);
3383     CopFILE_set(&PL_compiling, tmpbuf+2);
3384     SAVECOPLINE(&PL_compiling);
3385     CopLINE_set(&PL_compiling, 1);
3386     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3387        deleting the eval's FILEGV from the stash before gv_check() runs
3388        (i.e. before run-time proper). To work around the coredump that
3389        ensues, we always turn GvMULTI_on for any globals that were
3390        introduced within evals. See force_ident(). GSAR 96-10-12 */
3391     safestr = savepv(tmpbuf);
3392     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3393     SAVEHINTS();
3394     PL_hints = PL_op->op_targ;
3395     SAVESPTR(PL_compiling.cop_warnings);
3396     if (specialWARN(PL_curcop->cop_warnings))
3397         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3398     else {
3399         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3400         SAVEFREESV(PL_compiling.cop_warnings);
3401     }
3402
3403     push_return(PL_op->op_next);
3404     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3405     PUSHEVAL(cx, 0, Nullgv);
3406
3407     /* prepare to compile string */
3408
3409     if (PERLDB_LINE && PL_curstash != PL_debstash)
3410         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3411     PUTBACK;
3412 #ifdef USE_THREADS
3413     MUTEX_LOCK(&PL_eval_mutex);
3414     if (PL_eval_owner && PL_eval_owner != thr)
3415         while (PL_eval_owner)
3416             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3417     PL_eval_owner = thr;
3418     MUTEX_UNLOCK(&PL_eval_mutex);
3419 #endif /* USE_THREADS */
3420     ret = doeval(gimme, NULL);
3421     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3422         && ret != PL_op->op_next) {     /* Successive compilation. */
3423         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3424     }
3425     return DOCATCH(ret);
3426 }
3427
3428 PP(pp_leaveeval)
3429 {
3430     djSP;
3431     register SV **mark;
3432     SV **newsp;
3433     PMOP *newpm;
3434     I32 gimme;
3435     register PERL_CONTEXT *cx;
3436     OP *retop;
3437     U8 save_flags = PL_op -> op_flags;
3438     I32 optype;
3439
3440     POPBLOCK(cx,newpm);
3441     POPEVAL(cx);
3442     retop = pop_return();
3443
3444     TAINT_NOT;
3445     if (gimme == G_VOID)
3446         MARK = newsp;
3447     else if (gimme == G_SCALAR) {
3448         MARK = newsp + 1;
3449         if (MARK <= SP) {
3450             if (SvFLAGS(TOPs) & SVs_TEMP)
3451                 *MARK = TOPs;
3452             else
3453                 *MARK = sv_mortalcopy(TOPs);
3454         }
3455         else {
3456             MEXTEND(mark,0);
3457             *MARK = &PL_sv_undef;
3458         }
3459         SP = MARK;
3460     }
3461     else {
3462         /* in case LEAVE wipes old return values */
3463         for (mark = newsp + 1; mark <= SP; mark++) {
3464             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3465                 *mark = sv_mortalcopy(*mark);
3466                 TAINT_NOT;      /* Each item is independent */
3467             }
3468         }
3469     }
3470     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3471
3472     if (AvFILLp(PL_comppad_name) >= 0)
3473         free_closures();
3474
3475 #ifdef DEBUGGING
3476     assert(CvDEPTH(PL_compcv) == 1);
3477 #endif
3478     CvDEPTH(PL_compcv) = 0;
3479     lex_end();
3480
3481     if (optype == OP_REQUIRE &&
3482         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3483     {
3484         /* Unassume the success we assumed earlier. */
3485         SV *nsv = cx->blk_eval.old_namesv;
3486         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3487         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3488         /* die_where() did LEAVE, or we won't be here */
3489     }
3490     else {
3491         LEAVE;
3492         if (!(save_flags & OPf_SPECIAL))
3493             sv_setpv(ERRSV,"");
3494     }
3495
3496     RETURNOP(retop);
3497 }
3498
3499 PP(pp_entertry)
3500 {
3501     djSP;
3502     register PERL_CONTEXT *cx;
3503     I32 gimme = GIMME_V;
3504
3505     ENTER;
3506     SAVETMPS;
3507
3508     push_return(cLOGOP->op_other->op_next);
3509     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3510     PUSHEVAL(cx, 0, 0);
3511     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3512
3513     PL_in_eval = EVAL_INEVAL;
3514     sv_setpv(ERRSV,"");
3515     PUTBACK;
3516     return DOCATCH(PL_op->op_next);
3517 }
3518
3519 PP(pp_leavetry)
3520 {
3521     djSP;
3522     register SV **mark;
3523     SV **newsp;
3524     PMOP *newpm;
3525     I32 gimme;
3526     register PERL_CONTEXT *cx;
3527     I32 optype;
3528
3529     POPBLOCK(cx,newpm);
3530     POPEVAL(cx);
3531     pop_return();
3532
3533     TAINT_NOT;
3534     if (gimme == G_VOID)
3535         SP = newsp;
3536     else if (gimme == G_SCALAR) {
3537         MARK = newsp + 1;
3538         if (MARK <= SP) {
3539             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3540                 *MARK = TOPs;
3541             else
3542                 *MARK = sv_mortalcopy(TOPs);
3543         }
3544         else {
3545             MEXTEND(mark,0);
3546             *MARK = &PL_sv_undef;
3547         }
3548         SP = MARK;
3549     }
3550     else {
3551         /* in case LEAVE wipes old return values */
3552         for (mark = newsp + 1; mark <= SP; mark++) {
3553             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3554                 *mark = sv_mortalcopy(*mark);
3555                 TAINT_NOT;      /* Each item is independent */
3556             }
3557         }
3558     }
3559     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3560
3561     LEAVE;
3562     sv_setpv(ERRSV,"");
3563     RETURN;
3564 }
3565
3566 STATIC void
3567 S_doparseform(pTHX_ SV *sv)
3568 {
3569     STRLEN len;
3570     register char *s = SvPV_force(sv, len);
3571     register char *send = s + len;
3572     register char *base;
3573     register I32 skipspaces = 0;
3574     bool noblank;
3575     bool repeat;
3576     bool postspace = FALSE;
3577     U16 *fops;
3578     register U16 *fpc;
3579     U16 *linepc;
3580     register I32 arg;
3581     bool ischop;
3582
3583     if (len == 0)
3584         Perl_croak(aTHX_ "Null picture in formline");
3585
3586     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3587     fpc = fops;
3588
3589     if (s < send) {
3590         linepc = fpc;
3591         *fpc++ = FF_LINEMARK;
3592         noblank = repeat = FALSE;
3593         base = s;
3594     }
3595
3596     while (s <= send) {
3597         switch (*s++) {
3598         default:
3599             skipspaces = 0;
3600             continue;
3601
3602         case '~':
3603             if (*s == '~') {
3604                 repeat = TRUE;
3605                 *s = ' ';
3606             }
3607             noblank = TRUE;
3608             s[-1] = ' ';
3609             /* FALL THROUGH */
3610         case ' ': case '\t':
3611             skipspaces++;
3612             continue;
3613
3614         case '\n': case 0:
3615             arg = s - base;
3616             skipspaces++;
3617             arg -= skipspaces;
3618             if (arg) {
3619                 if (postspace)
3620                     *fpc++ = FF_SPACE;
3621                 *fpc++ = FF_LITERAL;
3622                 *fpc++ = arg;
3623             }
3624             postspace = FALSE;
3625             if (s <= send)
3626                 skipspaces--;
3627             if (skipspaces) {
3628                 *fpc++ = FF_SKIP;
3629                 *fpc++ = skipspaces;
3630             }
3631             skipspaces = 0;
3632             if (s <= send)
3633                 *fpc++ = FF_NEWLINE;
3634             if (noblank) {
3635                 *fpc++ = FF_BLANK;
3636                 if (repeat)
3637                     arg = fpc - linepc + 1;
3638                 else
3639                     arg = 0;
3640                 *fpc++ = arg;
3641             }
3642             if (s < send) {
3643                 linepc = fpc;
3644                 *fpc++ = FF_LINEMARK;
3645                 noblank = repeat = FALSE;
3646                 base = s;
3647             }
3648             else
3649                 s++;
3650             continue;
3651
3652         case '@':
3653         case '^':
3654             ischop = s[-1] == '^';
3655
3656             if (postspace) {
3657                 *fpc++ = FF_SPACE;
3658                 postspace = FALSE;
3659             }
3660             arg = (s - base) - 1;
3661             if (arg) {
3662                 *fpc++ = FF_LITERAL;
3663                 *fpc++ = arg;
3664             }
3665
3666             base = s - 1;
3667             *fpc++ = FF_FETCH;
3668             if (*s == '*') {
3669                 s++;
3670                 *fpc++ = 0;
3671                 *fpc++ = FF_LINEGLOB;
3672             }
3673             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3674                 arg = ischop ? 512 : 0;
3675                 base = s - 1;
3676                 while (*s == '#')
3677                     s++;
3678                 if (*s == '.') {
3679                     char *f;
3680                     s++;
3681                     f = s;
3682                     while (*s == '#')
3683                         s++;
3684                     arg |= 256 + (s - f);
3685                 }
3686                 *fpc++ = s - base;              /* fieldsize for FETCH */
3687                 *fpc++ = FF_DECIMAL;
3688                 *fpc++ = arg;
3689             }
3690             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3691                 arg = ischop ? 512 : 0;
3692                 base = s - 1;
3693                 s++;                                /* skip the '0' first */
3694                 while (*s == '#')
3695                     s++;
3696                 if (*s == '.') {
3697                     char *f;
3698                     s++;
3699                     f = s;
3700                     while (*s == '#')
3701                         s++;
3702                     arg |= 256 + (s - f);
3703                 }
3704                 *fpc++ = s - base;                /* fieldsize for FETCH */
3705                 *fpc++ = FF_0DECIMAL;
3706                 *fpc++ = arg;
3707             }
3708             else {
3709                 I32 prespace = 0;
3710                 bool ismore = FALSE;
3711
3712                 if (*s == '>') {
3713                     while (*++s == '>') ;
3714                     prespace = FF_SPACE;
3715                 }
3716                 else if (*s == '|') {
3717                     while (*++s == '|') ;
3718                     prespace = FF_HALFSPACE;
3719                     postspace = TRUE;
3720                 }
3721                 else {
3722                     if (*s == '<')
3723                         while (*++s == '<') ;
3724                     postspace = TRUE;
3725                 }
3726                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3727                     s += 3;
3728                     ismore = TRUE;
3729                 }
3730                 *fpc++ = s - base;              /* fieldsize for FETCH */
3731
3732                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3733
3734                 if (prespace)
3735                     *fpc++ = prespace;
3736                 *fpc++ = FF_ITEM;
3737                 if (ismore)
3738                     *fpc++ = FF_MORE;
3739                 if (ischop)
3740                     *fpc++ = FF_CHOP;
3741             }
3742             base = s;
3743             skipspaces = 0;
3744             continue;
3745         }
3746     }
3747     *fpc++ = FF_END;
3748
3749     arg = fpc - fops;
3750     { /* need to jump to the next word */
3751         int z;
3752         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3753         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3754         s = SvPVX(sv) + SvCUR(sv) + z;
3755     }
3756     Copy(fops, s, arg, U16);
3757     Safefree(fops);
3758     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3759     SvCOMPILED_on(sv);
3760 }
3761
3762 /*
3763  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3764  *
3765  * The original code was written in conjunction with BSD Computer Software
3766  * Research Group at University of California, Berkeley.
3767  *
3768  * See also: "Optimistic Merge Sort" (SODA '92)
3769  *
3770  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3771  *
3772  * The code can be distributed under the same terms as Perl itself.
3773  *
3774  */
3775
3776 #ifdef  TESTHARNESS
3777 #include <sys/types.h>
3778 typedef void SV;
3779 #define pTHXo_
3780 #define pTHX_
3781 #define STATIC
3782 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3783 #define Safefree(VAR) free(VAR)
3784 typedef int  (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3785 #endif  /* TESTHARNESS */
3786
3787 typedef char * aptr;            /* pointer for arithmetic on sizes */
3788 typedef SV * gptr;              /* pointers in our lists */
3789
3790 /* Binary merge internal sort, with a few special mods
3791 ** for the special perl environment it now finds itself in.
3792 **
3793 ** Things that were once options have been hotwired
3794 ** to values suitable for this use.  In particular, we'll always
3795 ** initialize looking for natural runs, we'll always produce stable
3796 ** output, and we'll always do Peter McIlroy's binary merge.
3797 */
3798
3799 /* Pointer types for arithmetic and storage and convenience casts */
3800
3801 #define APTR(P) ((aptr)(P))
3802 #define GPTP(P) ((gptr *)(P))
3803 #define GPPP(P) ((gptr **)(P))
3804
3805
3806 /* byte offset from pointer P to (larger) pointer Q */
3807 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3808
3809 #define PSIZE sizeof(gptr)
3810
3811 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3812
3813 #ifdef  PSHIFT
3814 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
3815 #define PNBYTE(N)       ((N) << (PSHIFT))
3816 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
3817 #else
3818 /* Leave optimization to compiler */
3819 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
3820 #define PNBYTE(N)       ((N) * (PSIZE))
3821 #define PINDEX(P, N)    (GPTP(P) + (N))
3822 #endif
3823
3824 /* Pointer into other corresponding to pointer into this */
3825 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3826
3827 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3828
3829
3830 /* Runs are identified by a pointer in the auxilliary list.
3831 ** The pointer is at the start of the list,
3832 ** and it points to the start of the next list.
3833 ** NEXT is used as an lvalue, too.
3834 */
3835
3836 #define NEXT(P)         (*GPPP(P))
3837
3838
3839 /* PTHRESH is the minimum number of pairs with the same sense to justify
3840 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
3841 ** not just elements, so PTHRESH == 8 means a run of 16.
3842 */
3843
3844 #define PTHRESH (8)
3845
3846 /* RTHRESH is the number of elements in a run that must compare low
3847 ** to the low element from the opposing run before we justify
3848 ** doing a binary rampup instead of single stepping.
3849 ** In random input, N in a row low should only happen with
3850 ** probability 2^(1-N), so we can risk that we are dealing
3851 ** with orderly input without paying much when we aren't.
3852 */
3853
3854 #define RTHRESH (6)
3855
3856
3857 /*
3858 ** Overview of algorithm and variables.
3859 ** The array of elements at list1 will be organized into runs of length 2,
3860 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
3861 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3862 **
3863 ** Unless otherwise specified, pair pointers address the first of two elements.
3864 **
3865 ** b and b+1 are a pair that compare with sense ``sense''.
3866 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3867 **
3868 ** p2 parallels b in the list2 array, where runs are defined by
3869 ** a pointer chain.
3870 **
3871 ** t represents the ``top'' of the adjacent pairs that might extend
3872 ** the run beginning at b.  Usually, t addresses a pair
3873 ** that compares with opposite sense from (b,b+1).
3874 ** However, it may also address a singleton element at the end of list1,
3875 ** or it may be equal to ``last'', the first element beyond list1.
3876 **
3877 ** r addresses the Nth pair following b.  If this would be beyond t,
3878 ** we back it off to t.  Only when r is less than t do we consider the
3879 ** run long enough to consider checking.
3880 **
3881 ** q addresses a pair such that the pairs at b through q already form a run.
3882 ** Often, q will equal b, indicating we only are sure of the pair itself.
3883 ** However, a search on the previous cycle may have revealed a longer run,
3884 ** so q may be greater than b.
3885 **
3886 ** p is used to work back from a candidate r, trying to reach q,
3887 ** which would mean b through r would be a run.  If we discover such a run,
3888 ** we start q at r and try to push it further towards t.
3889 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3890 ** In any event, after the check (if any), we have two main cases.
3891 **
3892 ** 1) Short run.  b <= q < p <= r <= t.
3893 **      b through q is a run (perhaps trivial)
3894 **      q through p are uninteresting pairs
3895 **      p through r is a run
3896 **
3897 ** 2) Long run.  b < r <= q < t.
3898 **      b through q is a run (of length >= 2 * PTHRESH)
3899 **
3900 ** Note that degenerate cases are not only possible, but likely.
3901 ** For example, if the pair following b compares with opposite sense,
3902 ** then b == q < p == r == t.
3903 */
3904
3905
3906 static void
3907 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3908 {
3909     int sense;
3910     register gptr *b, *p, *q, *t, *p2;
3911     register gptr c, *last, *r;
3912     gptr *savep;
3913
3914     b = list1;
3915     last = PINDEX(b, nmemb);
3916     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3917     for (p2 = list2; b < last; ) {
3918         /* We just started, or just reversed sense.
3919         ** Set t at end of pairs with the prevailing sense.
3920         */
3921         for (p = b+2, t = p; ++p < last; t = ++p) {
3922             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3923         }
3924         q = b;
3925         /* Having laid out the playing field, look for long runs */
3926         do {
3927             p = r = b + (2 * PTHRESH);
3928             if (r >= t) p = r = t;      /* too short to care about */
3929             else {
3930                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3931                        ((p -= 2) > q));
3932                 if (p <= q) {
3933                     /* b through r is a (long) run.
3934                     ** Extend it as far as possible.
3935                     */
3936                     p = q = r;
3937                     while (((p += 2) < t) &&
3938                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3939                     r = p = q + 2;      /* no simple pairs, no after-run */
3940                 }
3941             }
3942             if (q > b) {                /* run of greater than 2 at b */
3943                 savep = p;
3944                 p = q += 2;
3945                 /* pick up singleton, if possible */
3946                 if ((p == t) &&
3947                     ((t + 1) == last) &&
3948                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3949                     savep = r = p = q = last;
3950                 p2 = NEXT(p2) = p2 + (p - b);
3951                 if (sense) while (b < --p) {
3952                     c = *b;
3953                     *b++ = *p;
3954                     *p = c;
3955                 }
3956                 p = savep;
3957             }
3958             while (q < p) {             /* simple pairs */
3959                 p2 = NEXT(p2) = p2 + 2;
3960                 if (sense) {
3961                     c = *q++;
3962                     *(q-1) = *q;
3963                     *q++ = c;
3964                 } else q += 2;
3965             }
3966             if (((b = p) == t) && ((t+1) == last)) {
3967                 NEXT(p2) = p2 + 1;
3968                 b++;
3969             }
3970             q = r;
3971         } while (b < t);
3972         sense = !sense;
3973     }
3974     return;
3975 }
3976
3977
3978 /* Overview of bmerge variables:
3979 **
3980 ** list1 and list2 address the main and auxiliary arrays.
3981 ** They swap identities after each merge pass.
3982 ** Base points to the original list1, so we can tell if
3983 ** the pointers ended up where they belonged (or must be copied).
3984 **
3985 ** When we are merging two lists, f1 and f2 are the next elements
3986 ** on the respective lists.  l1 and l2 mark the end of the lists.
3987 ** tp2 is the current location in the merged list.
3988 **
3989 ** p1 records where f1 started.
3990 ** After the merge, a new descriptor is built there.
3991 **
3992 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3993 ** It is used to identify and delimit the runs.
3994 **
3995 ** In the heat of determining where q, the greater of the f1/f2 elements,
3996 ** belongs in the other list, b, t and p, represent bottom, top and probe
3997 ** locations, respectively, in the other list.
3998 ** They make convenient temporary pointers in other places.
3999 */
4000
4001 STATIC void
4002 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4003 {
4004     int i, run;
4005     int sense;
4006     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4007     gptr *aux, *list2, *p2, *last;
4008     gptr *base = list1;
4009     gptr *p1;
4010
4011     if (nmemb <= 1) return;     /* sorted trivially */
4012     New(799,list2,nmemb,gptr);  /* allocate auxilliary array */
4013     aux = list2;
4014     dynprep(aTHX_ list1, list2, nmemb, cmp);
4015     last = PINDEX(list2, nmemb);
4016     while (NEXT(list2) != last) {
4017         /* More than one run remains.  Do some merging to reduce runs. */
4018         l2 = p1 = list1;
4019         for (tp2 = p2 = list2; p2 != last;) {
4020             /* The new first run begins where the old second list ended.
4021             ** Use the p2 ``parallel'' pointer to identify the end of the run.
4022             */
4023             f1 = l2;
4024             t = NEXT(p2);
4025             f2 = l1 = POTHER(t, list2, list1);
4026             if (t != last) t = NEXT(t);
4027             l2 = POTHER(t, list2, list1);
4028             p2 = t;
4029             while (f1 < l1 && f2 < l2) {
4030                 /* If head 1 is larger than head 2, find ALL the elements
4031                 ** in list 2 strictly less than head1, write them all,
4032                 ** then head 1.  Then compare the new heads, and repeat,
4033                 ** until one or both lists are exhausted.
4034                 **
4035                 ** In all comparisons (after establishing
4036                 ** which head to merge) the item to merge
4037                 ** (at pointer q) is the first operand of
4038                 ** the comparison.  When we want to know
4039                 ** if ``q is strictly less than the other'',
4040                 ** we can't just do
4041                 **    cmp(q, other) < 0
4042                 ** because stability demands that we treat equality
4043                 ** as high when q comes from l2, and as low when
4044                 ** q was from l1.  So we ask the question by doing
4045                 **    cmp(q, other) <= sense
4046                 ** and make sense == 0 when equality should look low,
4047                 ** and -1 when equality should look high.
4048                 */
4049
4050
4051                 if (cmp(aTHX_ *f1, *f2) <= 0) {
4052                     q = f2; b = f1; t = l1;
4053                     sense = -1;
4054                 } else {
4055                     q = f1; b = f2; t = l2;
4056                     sense = 0;
4057                 }
4058
4059
4060                 /* ramp up
4061                 **
4062                 ** Leave t at something strictly
4063                 ** greater than q (or at the end of the list),
4064                 ** and b at something strictly less than q.
4065                 */
4066                 for (i = 1, run = 0 ;;) {
4067                     if ((p = PINDEX(b, i)) >= t) {
4068                         /* off the end */
4069                         if (((p = PINDEX(t, -1)) > b) &&
4070                             (cmp(aTHX_ *q, *p) <= sense))
4071                              t = p;
4072                         else b = p;
4073                         break;
4074                     } else if (cmp(aTHX_ *q, *p) <= sense) {
4075                         t = p;
4076                         break;
4077                     } else b = p;
4078                     if (++run >= RTHRESH) i += i;
4079                 }
4080
4081
4082                 /* q is known to follow b and must be inserted before t.
4083                 ** Increment b, so the range of possibilities is [b,t).
4084                 ** Round binary split down, to favor early appearance.
4085                 ** Adjust b and t until q belongs just before t.
4086                 */
4087
4088                 b++;
4089                 while (b < t) {
4090                     p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4091                     if (cmp(aTHX_ *q, *p) <= sense) {
4092                         t = p;
4093                     } else b = p + 1;
4094                 }
4095
4096
4097                 /* Copy all the strictly low elements */
4098
4099                 if (q == f1) {
4100                     FROMTOUPTO(f2, tp2, t);
4101                     *tp2++ = *f1++;
4102                 } else {
4103                     FROMTOUPTO(f1, tp2, t);
4104                     *tp2++ = *f2++;
4105                 }
4106             }
4107
4108
4109             /* Run out remaining list */
4110             if (f1 == l1) {
4111                    if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4112             } else              FROMTOUPTO(f1, tp2, l1);
4113             p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4114         }
4115         t = list1;
4116         list1 = list2;
4117         list2 = t;
4118         last = PINDEX(list2, nmemb);
4119     }
4120     if (base == list2) {
4121         last = PINDEX(list1, nmemb);
4122         FROMTOUPTO(list1, list2, last);
4123     }
4124     Safefree(aux);
4125     return;
4126 }
4127
4128
4129 #ifdef PERL_OBJECT
4130 #undef this
4131 #define this pPerl
4132 #include "XSUB.h"
4133 #endif
4134
4135
4136 static I32
4137 sortcv(pTHXo_ SV *a, SV *b)
4138 {
4139     dTHR;
4140     I32 oldsaveix = PL_savestack_ix;
4141     I32 oldscopeix = PL_scopestack_ix;
4142     I32 result;
4143     GvSV(PL_firstgv) = a;
4144     GvSV(PL_secondgv) = b;
4145     PL_stack_sp = PL_stack_base;
4146     PL_op = PL_sortcop;
4147     CALLRUNOPS(aTHX);
4148     if (PL_stack_sp != PL_stack_base + 1)
4149         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4150     if (!SvNIOKp(*PL_stack_sp))
4151         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4152     result = SvIV(*PL_stack_sp);
4153     while (PL_scopestack_ix > oldscopeix) {
4154         LEAVE;
4155     }
4156     leave_scope(oldsaveix);
4157     return result;
4158 }
4159
4160 static I32
4161 sortcv_stacked(pTHXo_ SV *a, SV *b)
4162 {
4163     dTHR;
4164     I32 oldsaveix = PL_savestack_ix;
4165     I32 oldscopeix = PL_scopestack_ix;
4166     I32 result;
4167     AV *av;
4168
4169 #ifdef USE_THREADS
4170     av = (AV*)PL_curpad[0];
4171 #else
4172     av = GvAV(PL_defgv);
4173 #endif
4174
4175     if (AvMAX(av) < 1) {
4176         SV** ary = AvALLOC(av);
4177         if (AvARRAY(av) != ary) {
4178             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4179             SvPVX(av) = (char*)ary;
4180         }
4181         if (AvMAX(av) < 1) {
4182             AvMAX(av) = 1;
4183             Renew(ary,2,SV*);
4184             SvPVX(av) = (char*)ary;
4185         }
4186     }
4187     AvFILLp(av) = 1;
4188
4189     AvARRAY(av)[0] = a;
4190     AvARRAY(av)[1] = b;
4191     PL_stack_sp = PL_stack_base;
4192     PL_op = PL_sortcop;
4193     CALLRUNOPS(aTHX);
4194     if (PL_stack_sp != PL_stack_base + 1)
4195         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4196     if (!SvNIOKp(*PL_stack_sp))
4197         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4198     result = SvIV(*PL_stack_sp);
4199     while (PL_scopestack_ix > oldscopeix) {
4200         LEAVE;
4201     }
4202     leave_scope(oldsaveix);
4203     return result;
4204 }
4205
4206 static I32
4207 sortcv_xsub(pTHXo_ SV *a, SV *b)
4208 {
4209     dSP;
4210     I32 oldsaveix = PL_savestack_ix;
4211     I32 oldscopeix = PL_scopestack_ix;
4212     I32 result;
4213     CV *cv=(CV*)PL_sortcop;
4214
4215     SP = PL_stack_base;
4216     PUSHMARK(SP);
4217     EXTEND(SP, 2);
4218     *++SP = a;
4219     *++SP = b;
4220     PUTBACK;
4221     (void)(*CvXSUB(cv))(aTHXo_ cv);
4222     if (PL_stack_sp != PL_stack_base + 1)
4223         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4224     if (!SvNIOKp(*PL_stack_sp))
4225         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4226     result = SvIV(*PL_stack_sp);
4227     while (PL_scopestack_ix > oldscopeix) {
4228         LEAVE;
4229     }
4230     leave_scope(oldsaveix);
4231     return result;
4232 }
4233
4234
4235 static I32
4236 sv_ncmp(pTHXo_ SV *a, SV *b)
4237 {
4238     NV nv1 = SvNV(a);
4239     NV nv2 = SvNV(b);
4240     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4241 }
4242
4243 static I32
4244 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4245 {
4246     IV iv1 = SvIV(a);
4247     IV iv2 = SvIV(b);
4248     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4249 }
4250 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4251           *svp = Nullsv;                                \
4252           if (PL_amagic_generation) { \
4253             if (SvAMAGIC(left)||SvAMAGIC(right))\
4254                 *svp = amagic_call(left, \
4255                                    right, \
4256                                    CAT2(meth,_amg), \
4257                                    0); \
4258           } \
4259         } STMT_END
4260
4261 static I32
4262 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4263 {
4264     SV *tmpsv;
4265     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4266     if (tmpsv) {
4267         NV d;
4268
4269         if (SvIOK(tmpsv)) {
4270             I32 i = SvIVX(tmpsv);
4271             if (i > 0)
4272                return 1;
4273             return i? -1 : 0;
4274         }
4275         d = SvNV(tmpsv);
4276         if (d > 0)
4277            return 1;
4278         return d? -1 : 0;
4279      }
4280      return sv_ncmp(aTHXo_ a, b);
4281 }
4282
4283 static I32
4284 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4285 {
4286     SV *tmpsv;
4287     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4288     if (tmpsv) {
4289         NV d;
4290
4291         if (SvIOK(tmpsv)) {
4292             I32 i = SvIVX(tmpsv);
4293             if (i > 0)
4294                return 1;
4295             return i? -1 : 0;
4296         }
4297         d = SvNV(tmpsv);
4298         if (d > 0)
4299            return 1;
4300         return d? -1 : 0;
4301     }
4302     return sv_i_ncmp(aTHXo_ a, b);
4303 }
4304
4305 static I32
4306 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4307 {
4308     SV *tmpsv;
4309     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4310     if (tmpsv) {
4311         NV d;
4312
4313         if (SvIOK(tmpsv)) {
4314             I32 i = SvIVX(tmpsv);
4315             if (i > 0)
4316                return 1;
4317             return i? -1 : 0;
4318         }
4319         d = SvNV(tmpsv);
4320         if (d > 0)
4321            return 1;
4322         return d? -1 : 0;
4323     }
4324     return sv_cmp(str1, str2);
4325 }
4326
4327 static I32
4328 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4329 {
4330     SV *tmpsv;
4331     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4332     if (tmpsv) {
4333         NV d;
4334
4335         if (SvIOK(tmpsv)) {
4336             I32 i = SvIVX(tmpsv);
4337             if (i > 0)
4338                return 1;
4339             return i? -1 : 0;
4340         }
4341         d = SvNV(tmpsv);
4342         if (d > 0)
4343            return 1;
4344         return d? -1 : 0;
4345     }
4346     return sv_cmp_locale(str1, str2);
4347 }
4348
4349 static I32
4350 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4351 {
4352     SV *datasv = FILTER_DATA(idx);
4353     int filter_has_file = IoLINES(datasv);
4354     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4355     SV *filter_state = (SV *)IoTOP_GV(datasv);
4356     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4357     int len = 0;
4358
4359     /* I was having segfault trouble under Linux 2.2.5 after a
4360        parse error occured.  (Had to hack around it with a test
4361        for PL_error_count == 0.)  Solaris doesn't segfault --
4362        not sure where the trouble is yet.  XXX */
4363
4364     if (filter_has_file) {
4365         len = FILTER_READ(idx+1, buf_sv, maxlen);
4366     }
4367
4368     if (filter_sub && len >= 0) {
4369         djSP;
4370         int count;
4371
4372         ENTER;
4373         SAVE_DEFSV;
4374         SAVETMPS;
4375         EXTEND(SP, 2);
4376
4377         DEFSV = buf_sv;
4378         PUSHMARK(SP);
4379         PUSHs(sv_2mortal(newSViv(maxlen)));
4380         if (filter_state) {
4381             PUSHs(filter_state);
4382         }
4383         PUTBACK;
4384         count = call_sv(filter_sub, G_SCALAR);
4385         SPAGAIN;
4386
4387         if (count > 0) {
4388             SV *out = POPs;
4389             if (SvOK(out)) {
4390                 len = SvIV(out);
4391             }
4392         }
4393
4394         PUTBACK;
4395         FREETMPS;
4396         LEAVE;
4397     }
4398
4399     if (len <= 0) {
4400         IoLINES(datasv) = 0;
4401         if (filter_child_proc) {
4402             SvREFCNT_dec(filter_child_proc);
4403             IoFMT_GV(datasv) = Nullgv;
4404         }
4405         if (filter_state) {
4406             SvREFCNT_dec(filter_state);
4407             IoTOP_GV(datasv) = Nullgv;
4408         }
4409         if (filter_sub) {
4410             SvREFCNT_dec(filter_sub);
4411             IoBOTTOM_GV(datasv) = Nullgv;
4412         }
4413         filter_del(run_user_filter);
4414     }
4415
4416     return len;
4417 }
4418
4419 #ifdef PERL_OBJECT
4420
4421 static I32
4422 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4423 {
4424     return sv_cmp_locale(str1, str2);
4425 }
4426
4427 static I32
4428 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4429 {
4430     return sv_cmp(str1, str2);
4431 }
4432
4433 #endif /* PERL_OBJECT */