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     register I32 i;
1164     register PERL_CONTEXT *cx;
1165
1166     for (i = cxstack_ix; i >= 0; i--) {
1167         cx = &cxstack[i];
1168         switch (CxTYPE(cx)) {
1169         case CXt_SUBST:
1170             if (ckWARN(WARN_EXITING))
1171                 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1172                         PL_op_name[PL_op->op_type]);
1173             break;
1174         case CXt_SUB:
1175             if (ckWARN(WARN_EXITING))
1176                 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1177                         PL_op_name[PL_op->op_type]);
1178             break;
1179         case CXt_FORMAT:
1180             if (ckWARN(WARN_EXITING))
1181                 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1182                         PL_op_name[PL_op->op_type]);
1183             break;
1184         case CXt_EVAL:
1185             if (ckWARN(WARN_EXITING))
1186                 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1187                         PL_op_name[PL_op->op_type]);
1188             break;
1189         case CXt_NULL:
1190             if (ckWARN(WARN_EXITING))
1191                 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1192                         PL_op_name[PL_op->op_type]);
1193             return -1;
1194         case CXt_LOOP:
1195             if (!cx->blk_loop.label ||
1196               strNE(label, cx->blk_loop.label) ) {
1197                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1198                         (long)i, cx->blk_loop.label));
1199                 continue;
1200             }
1201             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1202             return i;
1203         }
1204     }
1205     return i;
1206 }
1207
1208 I32
1209 Perl_dowantarray(pTHX)
1210 {
1211     I32 gimme = block_gimme();
1212     return (gimme == G_VOID) ? G_SCALAR : gimme;
1213 }
1214
1215 I32
1216 Perl_block_gimme(pTHX)
1217 {
1218     I32 cxix;
1219
1220     cxix = dopoptosub(cxstack_ix);
1221     if (cxix < 0)
1222         return G_VOID;
1223
1224     switch (cxstack[cxix].blk_gimme) {
1225     case G_VOID:
1226         return G_VOID;
1227     case G_SCALAR:
1228         return G_SCALAR;
1229     case G_ARRAY:
1230         return G_ARRAY;
1231     default:
1232         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1233         /* NOTREACHED */
1234         return 0;
1235     }
1236 }
1237
1238 STATIC I32
1239 S_dopoptosub(pTHX_ I32 startingblock)
1240 {
1241     return dopoptosub_at(cxstack, startingblock);
1242 }
1243
1244 STATIC I32
1245 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1246 {
1247     I32 i;
1248     register PERL_CONTEXT *cx;
1249     for (i = startingblock; i >= 0; i--) {
1250         cx = &cxstk[i];
1251         switch (CxTYPE(cx)) {
1252         default:
1253             continue;
1254         case CXt_EVAL:
1255         case CXt_SUB:
1256         case CXt_FORMAT:
1257             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1258             return i;
1259         }
1260     }
1261     return i;
1262 }
1263
1264 STATIC I32
1265 S_dopoptoeval(pTHX_ I32 startingblock)
1266 {
1267     I32 i;
1268     register PERL_CONTEXT *cx;
1269     for (i = startingblock; i >= 0; i--) {
1270         cx = &cxstack[i];
1271         switch (CxTYPE(cx)) {
1272         default:
1273             continue;
1274         case CXt_EVAL:
1275             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1276             return i;
1277         }
1278     }
1279     return i;
1280 }
1281
1282 STATIC I32
1283 S_dopoptoloop(pTHX_ I32 startingblock)
1284 {
1285     I32 i;
1286     register PERL_CONTEXT *cx;
1287     for (i = startingblock; i >= 0; i--) {
1288         cx = &cxstack[i];
1289         switch (CxTYPE(cx)) {
1290         case CXt_SUBST:
1291             if (ckWARN(WARN_EXITING))
1292                 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1293                         PL_op_name[PL_op->op_type]);
1294             break;
1295         case CXt_SUB:
1296             if (ckWARN(WARN_EXITING))
1297                 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1298                         PL_op_name[PL_op->op_type]);
1299             break;
1300         case CXt_FORMAT:
1301             if (ckWARN(WARN_EXITING))
1302                 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1303                         PL_op_name[PL_op->op_type]);
1304             break;
1305         case CXt_EVAL:
1306             if (ckWARN(WARN_EXITING))
1307                 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1308                         PL_op_name[PL_op->op_type]);
1309             break;
1310         case CXt_NULL:
1311             if (ckWARN(WARN_EXITING))
1312                 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1313                         PL_op_name[PL_op->op_type]);
1314             return -1;
1315         case CXt_LOOP:
1316             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1317             return i;
1318         }
1319     }
1320     return i;
1321 }
1322
1323 void
1324 Perl_dounwind(pTHX_ I32 cxix)
1325 {
1326     register PERL_CONTEXT *cx;
1327     I32 optype;
1328
1329     while (cxstack_ix > cxix) {
1330         SV *sv;
1331         cx = &cxstack[cxstack_ix];
1332         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1333                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1334         /* Note: we don't need to restore the base context info till the end. */
1335         switch (CxTYPE(cx)) {
1336         case CXt_SUBST:
1337             POPSUBST(cx);
1338             continue;  /* not break */
1339         case CXt_SUB:
1340             POPSUB(cx,sv);
1341             LEAVESUB(sv);
1342             break;
1343         case CXt_EVAL:
1344             POPEVAL(cx);
1345             break;
1346         case CXt_LOOP:
1347             POPLOOP(cx);
1348             break;
1349         case CXt_NULL:
1350             break;
1351         case CXt_FORMAT:
1352             POPFORMAT(cx);
1353             break;
1354         }
1355         cxstack_ix--;
1356     }
1357 }
1358
1359 /*
1360  * Closures mentioned at top level of eval cannot be referenced
1361  * again, and their presence indirectly causes a memory leak.
1362  * (Note that the fact that compcv and friends are still set here
1363  * is, AFAIK, an accident.)  --Chip
1364  *
1365  * XXX need to get comppad et al from eval's cv rather than
1366  * relying on the incidental global values.
1367  */
1368 STATIC void
1369 S_free_closures(pTHX)
1370 {
1371     SV **svp = AvARRAY(PL_comppad_name);
1372     I32 ix;
1373     for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1374         SV *sv = svp[ix];
1375         if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1376             SvREFCNT_dec(sv);
1377             svp[ix] = &PL_sv_undef;
1378
1379             sv = PL_curpad[ix];
1380             if (CvCLONE(sv)) {
1381                 SvREFCNT_dec(CvOUTSIDE(sv));
1382                 CvOUTSIDE(sv) = Nullcv;
1383             }
1384             else {
1385                 SvREFCNT_dec(sv);
1386                 sv = NEWSV(0,0);
1387                 SvPADTMP_on(sv);
1388                 PL_curpad[ix] = sv;
1389             }
1390         }
1391     }
1392 }
1393
1394 void
1395 Perl_qerror(pTHX_ SV *err)
1396 {
1397     if (PL_in_eval)
1398         sv_catsv(ERRSV, err);
1399     else if (PL_errors)
1400         sv_catsv(PL_errors, err);
1401     else
1402         Perl_warn(aTHX_ "%"SVf, err);
1403     ++PL_error_count;
1404 }
1405
1406 OP *
1407 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1408 {
1409     STRLEN n_a;
1410     if (PL_in_eval) {
1411         I32 cxix;
1412         register PERL_CONTEXT *cx;
1413         I32 gimme;
1414         SV **newsp;
1415
1416         if (message) {
1417             if (PL_in_eval & EVAL_KEEPERR) {
1418                 static char prefix[] = "\t(in cleanup) ";
1419                 SV *err = ERRSV;
1420                 char *e = Nullch;
1421                 if (!SvPOK(err))
1422                     sv_setpv(err,"");
1423                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1424                     e = SvPV(err, n_a);
1425                     e += n_a - msglen;
1426                     if (*e != *message || strNE(e,message))
1427                         e = Nullch;
1428                 }
1429                 if (!e) {
1430                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1431                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1432                     sv_catpvn(err, message, msglen);
1433                     if (ckWARN(WARN_MISC)) {
1434                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1435                         Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1436                     }
1437                 }
1438             }
1439             else
1440                 sv_setpvn(ERRSV, message, msglen);
1441         }
1442         else
1443             message = SvPVx(ERRSV, msglen);
1444
1445         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1446                && PL_curstackinfo->si_prev)
1447         {
1448             dounwind(-1);
1449             POPSTACK;
1450         }
1451
1452         if (cxix >= 0) {
1453             I32 optype;
1454
1455             if (cxix < cxstack_ix)
1456                 dounwind(cxix);
1457
1458             POPBLOCK(cx,PL_curpm);
1459             if (CxTYPE(cx) != CXt_EVAL) {
1460                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1461                 PerlIO_write(Perl_error_log, message, msglen);
1462                 my_exit(1);
1463             }
1464             POPEVAL(cx);
1465
1466             if (gimme == G_SCALAR)
1467                 *++newsp = &PL_sv_undef;
1468             PL_stack_sp = newsp;
1469
1470             LEAVE;
1471
1472             /* LEAVE could clobber PL_curcop (see save_re_context())
1473              * XXX it might be better to find a way to avoid messing with
1474              * PL_curcop in save_re_context() instead, but this is a more
1475              * minimal fix --GSAR */
1476             PL_curcop = cx->blk_oldcop;
1477
1478             if (optype == OP_REQUIRE) {
1479                 char* msg = SvPVx(ERRSV, n_a);
1480                 DIE(aTHX_ "%sCompilation failed in require",
1481                     *msg ? msg : "Unknown error\n");
1482             }
1483             return pop_return();
1484         }
1485     }
1486     if (!message)
1487         message = SvPVx(ERRSV, msglen);
1488     {
1489 #ifdef USE_SFIO
1490         /* SFIO can really mess with your errno */
1491         int e = errno;
1492 #endif
1493         PerlIO *serr = Perl_error_log;
1494
1495         PerlIO_write(serr, message, msglen);
1496         (void)PerlIO_flush(serr);
1497 #ifdef USE_SFIO
1498         errno = e;
1499 #endif
1500     }
1501     my_failure_exit();
1502     /* NOTREACHED */
1503     return 0;
1504 }
1505
1506 PP(pp_xor)
1507 {
1508     djSP; dPOPTOPssrl;
1509     if (SvTRUE(left) != SvTRUE(right))
1510         RETSETYES;
1511     else
1512         RETSETNO;
1513 }
1514
1515 PP(pp_andassign)
1516 {
1517     djSP;
1518     if (!SvTRUE(TOPs))
1519         RETURN;
1520     else
1521         RETURNOP(cLOGOP->op_other);
1522 }
1523
1524 PP(pp_orassign)
1525 {
1526     djSP;
1527     if (SvTRUE(TOPs))
1528         RETURN;
1529     else
1530         RETURNOP(cLOGOP->op_other);
1531 }
1532
1533 PP(pp_caller)
1534 {
1535     djSP;
1536     register I32 cxix = dopoptosub(cxstack_ix);
1537     register PERL_CONTEXT *cx;
1538     register PERL_CONTEXT *ccstack = cxstack;
1539     PERL_SI *top_si = PL_curstackinfo;
1540     I32 dbcxix;
1541     I32 gimme;
1542     char *stashname;
1543     SV *sv;
1544     I32 count = 0;
1545
1546     if (MAXARG)
1547         count = POPi;
1548     EXTEND(SP, 10);
1549     for (;;) {
1550         /* we may be in a higher stacklevel, so dig down deeper */
1551         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1552             top_si = top_si->si_prev;
1553             ccstack = top_si->si_cxstack;
1554             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1555         }
1556         if (cxix < 0) {
1557             if (GIMME != G_ARRAY)
1558                 RETPUSHUNDEF;
1559             RETURN;
1560         }
1561         if (PL_DBsub && cxix >= 0 &&
1562                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1563             count++;
1564         if (!count--)
1565             break;
1566         cxix = dopoptosub_at(ccstack, cxix - 1);
1567     }
1568
1569     cx = &ccstack[cxix];
1570     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1571         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1572         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1573            field below is defined for any cx. */
1574         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1575             cx = &ccstack[dbcxix];
1576     }
1577
1578     stashname = CopSTASHPV(cx->blk_oldcop);
1579     if (GIMME != G_ARRAY) {
1580         if (!stashname)
1581             PUSHs(&PL_sv_undef);
1582         else {
1583             dTARGET;
1584             sv_setpv(TARG, stashname);
1585             PUSHs(TARG);
1586         }
1587         RETURN;
1588     }
1589
1590     if (!stashname)
1591         PUSHs(&PL_sv_undef);
1592     else
1593         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1594     PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1595     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1596     if (!MAXARG)
1597         RETURN;
1598     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1599         /* So is ccstack[dbcxix]. */
1600         sv = NEWSV(49, 0);
1601         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1602         PUSHs(sv_2mortal(sv));
1603         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1604     }
1605     else {
1606         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1607         PUSHs(sv_2mortal(newSViv(0)));
1608     }
1609     gimme = (I32)cx->blk_gimme;
1610     if (gimme == G_VOID)
1611         PUSHs(&PL_sv_undef);
1612     else
1613         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1614     if (CxTYPE(cx) == CXt_EVAL) {
1615         /* eval STRING */
1616         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1617             PUSHs(cx->blk_eval.cur_text);
1618             PUSHs(&PL_sv_no);
1619         }
1620         /* require */
1621         else if (cx->blk_eval.old_namesv) {
1622             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1623             PUSHs(&PL_sv_yes);
1624         }
1625         /* eval BLOCK (try blocks have old_namesv == 0) */
1626         else {
1627             PUSHs(&PL_sv_undef);
1628             PUSHs(&PL_sv_undef);
1629         }
1630     }
1631     else {
1632         PUSHs(&PL_sv_undef);
1633         PUSHs(&PL_sv_undef);
1634     }
1635     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1636         && CopSTASH_eq(PL_curcop, PL_debstash))
1637     {
1638         AV *ary = cx->blk_sub.argarray;
1639         int off = AvARRAY(ary) - AvALLOC(ary);
1640
1641         if (!PL_dbargs) {
1642             GV* tmpgv;
1643             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1644                                 SVt_PVAV)));
1645             GvMULTI_on(tmpgv);
1646             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1647         }
1648
1649         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1650             av_extend(PL_dbargs, AvFILLp(ary) + off);
1651         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1652         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1653     }
1654     /* XXX only hints propagated via op_private are currently
1655      * visible (others are not easily accessible, since they
1656      * use the global PL_hints) */
1657     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1658                              HINT_PRIVATE_MASK)));
1659     {
1660         SV * mask ;
1661         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1662
1663         if  (old_warnings == pWARN_NONE ||
1664                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1665             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1666         else if (old_warnings == pWARN_ALL ||
1667                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1668             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1669         else
1670             mask = newSVsv(old_warnings);
1671         PUSHs(sv_2mortal(mask));
1672     }
1673     RETURN;
1674 }
1675
1676 PP(pp_reset)
1677 {
1678     djSP;
1679     char *tmps;
1680     STRLEN n_a;
1681
1682     if (MAXARG < 1)
1683         tmps = "";
1684     else
1685         tmps = POPpx;
1686     sv_reset(tmps, CopSTASH(PL_curcop));
1687     PUSHs(&PL_sv_yes);
1688     RETURN;
1689 }
1690
1691 PP(pp_lineseq)
1692 {
1693     return NORMAL;
1694 }
1695
1696 PP(pp_dbstate)
1697 {
1698     PL_curcop = (COP*)PL_op;
1699     TAINT_NOT;          /* Each statement is presumed innocent */
1700     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1701     FREETMPS;
1702
1703     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1704     {
1705         djSP;
1706         register CV *cv;
1707         register PERL_CONTEXT *cx;
1708         I32 gimme = G_ARRAY;
1709         I32 hasargs;
1710         GV *gv;
1711
1712         gv = PL_DBgv;
1713         cv = GvCV(gv);
1714         if (!cv)
1715             DIE(aTHX_ "No DB::DB routine defined");
1716
1717         if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1718             return NORMAL;
1719
1720         ENTER;
1721         SAVETMPS;
1722
1723         SAVEI32(PL_debug);
1724         SAVESTACK_POS();
1725         PL_debug = 0;
1726         hasargs = 0;
1727         SPAGAIN;
1728
1729         push_return(PL_op->op_next);
1730         PUSHBLOCK(cx, CXt_SUB, SP);
1731         PUSHSUB(cx);
1732         CvDEPTH(cv)++;
1733         (void)SvREFCNT_inc(cv);
1734         SAVEVPTR(PL_curpad);
1735         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1736         RETURNOP(CvSTART(cv));
1737     }
1738     else
1739         return NORMAL;
1740 }
1741
1742 PP(pp_scope)
1743 {
1744     return NORMAL;
1745 }
1746
1747 PP(pp_enteriter)
1748 {
1749     djSP; dMARK;
1750     register PERL_CONTEXT *cx;
1751     I32 gimme = GIMME_V;
1752     SV **svp;
1753     U32 cxtype = CXt_LOOP;
1754 #ifdef USE_ITHREADS
1755     void *iterdata;
1756 #endif
1757
1758     ENTER;
1759     SAVETMPS;
1760
1761 #ifdef USE_THREADS
1762     if (PL_op->op_flags & OPf_SPECIAL) {
1763         svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1764         SAVEGENERICSV(*svp);
1765         *svp = NEWSV(0,0);
1766     }
1767     else
1768 #endif /* USE_THREADS */
1769     if (PL_op->op_targ) {
1770 #ifndef USE_ITHREADS
1771         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1772         SAVESPTR(*svp);
1773 #else
1774         SAVEPADSV(PL_op->op_targ);
1775         iterdata = (void*)PL_op->op_targ;
1776         cxtype |= CXp_PADVAR;
1777 #endif
1778     }
1779     else {
1780         GV *gv = (GV*)POPs;
1781         svp = &GvSV(gv);                        /* symbol table variable */
1782         SAVEGENERICSV(*svp);
1783         *svp = NEWSV(0,0);
1784 #ifdef USE_ITHREADS
1785         iterdata = (void*)gv;
1786 #endif
1787     }
1788
1789     ENTER;
1790
1791     PUSHBLOCK(cx, cxtype, SP);
1792 #ifdef USE_ITHREADS
1793     PUSHLOOP(cx, iterdata, MARK);
1794 #else
1795     PUSHLOOP(cx, svp, MARK);
1796 #endif
1797     if (PL_op->op_flags & OPf_STACKED) {
1798         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1799         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1800             dPOPss;
1801             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1802                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1803                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1804                  looks_like_number((SV*)cx->blk_loop.iterary) &&
1805                  *SvPVX(cx->blk_loop.iterary) != '0'))
1806             {
1807                  if (SvNV(sv) < IV_MIN ||
1808                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1809                      DIE(aTHX_ "Range iterator outside integer range");
1810                  cx->blk_loop.iterix = SvIV(sv);
1811                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1812             }
1813             else
1814                 cx->blk_loop.iterlval = newSVsv(sv);
1815         }
1816     }
1817     else {
1818         cx->blk_loop.iterary = PL_curstack;
1819         AvFILLp(PL_curstack) = SP - PL_stack_base;
1820         cx->blk_loop.iterix = MARK - PL_stack_base;
1821     }
1822
1823     RETURN;
1824 }
1825
1826 PP(pp_enterloop)
1827 {
1828     djSP;
1829     register PERL_CONTEXT *cx;
1830     I32 gimme = GIMME_V;
1831
1832     ENTER;
1833     SAVETMPS;
1834     ENTER;
1835
1836     PUSHBLOCK(cx, CXt_LOOP, SP);
1837     PUSHLOOP(cx, 0, SP);
1838
1839     RETURN;
1840 }
1841
1842 PP(pp_leaveloop)
1843 {
1844     djSP;
1845     register PERL_CONTEXT *cx;
1846     I32 gimme;
1847     SV **newsp;
1848     PMOP *newpm;
1849     SV **mark;
1850
1851     POPBLOCK(cx,newpm);
1852     mark = newsp;
1853     newsp = PL_stack_base + cx->blk_loop.resetsp;
1854
1855     TAINT_NOT;
1856     if (gimme == G_VOID)
1857         ; /* do nothing */
1858     else if (gimme == G_SCALAR) {
1859         if (mark < SP)
1860             *++newsp = sv_mortalcopy(*SP);
1861         else
1862             *++newsp = &PL_sv_undef;
1863     }
1864     else {
1865         while (mark < SP) {
1866             *++newsp = sv_mortalcopy(*++mark);
1867             TAINT_NOT;          /* Each item is independent */
1868         }
1869     }
1870     SP = newsp;
1871     PUTBACK;
1872
1873     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1874     PL_curpm = newpm;   /* ... and pop $1 et al */
1875
1876     LEAVE;
1877     LEAVE;
1878
1879     return NORMAL;
1880 }
1881
1882 PP(pp_return)
1883 {
1884     djSP; dMARK;
1885     I32 cxix;
1886     register PERL_CONTEXT *cx;
1887     bool popsub2 = FALSE;
1888     bool clear_errsv = FALSE;
1889     I32 gimme;
1890     SV **newsp;
1891     PMOP *newpm;
1892     I32 optype = 0;
1893     SV *sv;
1894
1895     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1896         if (cxstack_ix == PL_sortcxix
1897             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1898         {
1899             if (cxstack_ix > PL_sortcxix)
1900                 dounwind(PL_sortcxix);
1901             AvARRAY(PL_curstack)[1] = *SP;
1902             PL_stack_sp = PL_stack_base + 1;
1903             return 0;
1904         }
1905     }
1906
1907     cxix = dopoptosub(cxstack_ix);
1908     if (cxix < 0)
1909         DIE(aTHX_ "Can't return outside a subroutine");
1910     if (cxix < cxstack_ix)
1911         dounwind(cxix);
1912
1913     POPBLOCK(cx,newpm);
1914     switch (CxTYPE(cx)) {
1915     case CXt_SUB:
1916         popsub2 = TRUE;
1917         break;
1918     case CXt_EVAL:
1919         if (!(PL_in_eval & EVAL_KEEPERR))
1920             clear_errsv = TRUE;
1921         POPEVAL(cx);
1922         if (CxTRYBLOCK(cx))
1923             break;
1924         if (AvFILLp(PL_comppad_name) >= 0)
1925             free_closures();
1926         lex_end();
1927         if (optype == OP_REQUIRE &&
1928             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1929         {
1930             /* Unassume the success we assumed earlier. */
1931             SV *nsv = cx->blk_eval.old_namesv;
1932             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1933             DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1934         }
1935         break;
1936     case CXt_FORMAT:
1937         POPFORMAT(cx);
1938         break;
1939     default:
1940         DIE(aTHX_ "panic: return");
1941     }
1942
1943     TAINT_NOT;
1944     if (gimme == G_SCALAR) {
1945         if (MARK < SP) {
1946             if (popsub2) {
1947                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1948                     if (SvTEMP(TOPs)) {
1949                         *++newsp = SvREFCNT_inc(*SP);
1950                         FREETMPS;
1951                         sv_2mortal(*newsp);
1952                     }
1953                     else {
1954                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1955                         FREETMPS;
1956                         *++newsp = sv_mortalcopy(sv);
1957                         SvREFCNT_dec(sv);
1958                     }
1959                 }
1960                 else
1961                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1962             }
1963             else
1964                 *++newsp = sv_mortalcopy(*SP);
1965         }
1966         else
1967             *++newsp = &PL_sv_undef;
1968     }
1969     else if (gimme == G_ARRAY) {
1970         while (++MARK <= SP) {
1971             *++newsp = (popsub2 && SvTEMP(*MARK))
1972                         ? *MARK : sv_mortalcopy(*MARK);
1973             TAINT_NOT;          /* Each item is independent */
1974         }
1975     }
1976     PL_stack_sp = newsp;
1977
1978     /* Stack values are safe: */
1979     if (popsub2) {
1980         POPSUB(cx,sv);  /* release CV and @_ ... */
1981     }
1982     else
1983         sv = Nullsv;
1984     PL_curpm = newpm;   /* ... and pop $1 et al */
1985
1986     LEAVE;
1987     LEAVESUB(sv);
1988     if (clear_errsv)
1989         sv_setpv(ERRSV,"");
1990     return pop_return();
1991 }
1992
1993 PP(pp_last)
1994 {
1995     djSP;
1996     I32 cxix;
1997     register PERL_CONTEXT *cx;
1998     I32 pop2 = 0;
1999     I32 gimme;
2000     I32 optype;
2001     OP *nextop;
2002     SV **newsp;
2003     PMOP *newpm;
2004     SV **mark;
2005     SV *sv = Nullsv;
2006
2007     if (PL_op->op_flags & OPf_SPECIAL) {
2008         cxix = dopoptoloop(cxstack_ix);
2009         if (cxix < 0)
2010             DIE(aTHX_ "Can't \"last\" outside a loop block");
2011     }
2012     else {
2013         cxix = dopoptolabel(cPVOP->op_pv);
2014         if (cxix < 0)
2015             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2016     }
2017     if (cxix < cxstack_ix)
2018         dounwind(cxix);
2019
2020     POPBLOCK(cx,newpm);
2021     mark = newsp;
2022     switch (CxTYPE(cx)) {
2023     case CXt_LOOP:
2024         pop2 = CXt_LOOP;
2025         newsp = PL_stack_base + cx->blk_loop.resetsp;
2026         nextop = cx->blk_loop.last_op->op_next;
2027         break;
2028     case CXt_SUB:
2029         pop2 = CXt_SUB;
2030         nextop = pop_return();
2031         break;
2032     case CXt_EVAL:
2033         POPEVAL(cx);
2034         nextop = pop_return();
2035         break;
2036     case CXt_FORMAT:
2037         POPFORMAT(cx);
2038         nextop = pop_return();
2039         break;
2040     default:
2041         DIE(aTHX_ "panic: last");
2042     }
2043
2044     TAINT_NOT;
2045     if (gimme == G_SCALAR) {
2046         if (MARK < SP)
2047             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2048                         ? *SP : sv_mortalcopy(*SP);
2049         else
2050             *++newsp = &PL_sv_undef;
2051     }
2052     else if (gimme == G_ARRAY) {
2053         while (++MARK <= SP) {
2054             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2055                         ? *MARK : sv_mortalcopy(*MARK);
2056             TAINT_NOT;          /* Each item is independent */
2057         }
2058     }
2059     SP = newsp;
2060     PUTBACK;
2061
2062     /* Stack values are safe: */
2063     switch (pop2) {
2064     case CXt_LOOP:
2065         POPLOOP(cx);    /* release loop vars ... */
2066         LEAVE;
2067         break;
2068     case CXt_SUB:
2069         POPSUB(cx,sv);  /* release CV and @_ ... */
2070         break;
2071     }
2072     PL_curpm = newpm;   /* ... and pop $1 et al */
2073
2074     LEAVE;
2075     LEAVESUB(sv);
2076     return nextop;
2077 }
2078
2079 PP(pp_next)
2080 {
2081     I32 cxix;
2082     register PERL_CONTEXT *cx;
2083     I32 inner;
2084
2085     if (PL_op->op_flags & OPf_SPECIAL) {
2086         cxix = dopoptoloop(cxstack_ix);
2087         if (cxix < 0)
2088             DIE(aTHX_ "Can't \"next\" outside a loop block");
2089     }
2090     else {
2091         cxix = dopoptolabel(cPVOP->op_pv);
2092         if (cxix < 0)
2093             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2094     }
2095     if (cxix < cxstack_ix)
2096         dounwind(cxix);
2097
2098     /* clear off anything above the scope we're re-entering, but
2099      * save the rest until after a possible continue block */
2100     inner = PL_scopestack_ix;
2101     TOPBLOCK(cx);
2102     if (PL_scopestack_ix < inner)
2103         leave_scope(PL_scopestack[PL_scopestack_ix]);
2104     return cx->blk_loop.next_op;
2105 }
2106
2107 PP(pp_redo)
2108 {
2109     I32 cxix;
2110     register PERL_CONTEXT *cx;
2111     I32 oldsave;
2112
2113     if (PL_op->op_flags & OPf_SPECIAL) {
2114         cxix = dopoptoloop(cxstack_ix);
2115         if (cxix < 0)
2116             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2117     }
2118     else {
2119         cxix = dopoptolabel(cPVOP->op_pv);
2120         if (cxix < 0)
2121             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2122     }
2123     if (cxix < cxstack_ix)
2124         dounwind(cxix);
2125
2126     TOPBLOCK(cx);
2127     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2128     LEAVE_SCOPE(oldsave);
2129     return cx->blk_loop.redo_op;
2130 }
2131
2132 STATIC OP *
2133 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2134 {
2135     OP *kid;
2136     OP **ops = opstack;
2137     static char too_deep[] = "Target of goto is too deeply nested";
2138
2139     if (ops >= oplimit)
2140         Perl_croak(aTHX_ too_deep);
2141     if (o->op_type == OP_LEAVE ||
2142         o->op_type == OP_SCOPE ||
2143         o->op_type == OP_LEAVELOOP ||
2144         o->op_type == OP_LEAVETRY)
2145     {
2146         *ops++ = cUNOPo->op_first;
2147         if (ops >= oplimit)
2148             Perl_croak(aTHX_ too_deep);
2149     }
2150     *ops = 0;
2151     if (o->op_flags & OPf_KIDS) {
2152         /* First try all the kids at this level, since that's likeliest. */
2153         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2154             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2155                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2156                 return kid;
2157         }
2158         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2159             if (kid == PL_lastgotoprobe)
2160                 continue;
2161             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2162                 (ops == opstack ||
2163                  (ops[-1]->op_type != OP_NEXTSTATE &&
2164                   ops[-1]->op_type != OP_DBSTATE)))
2165                 *ops++ = kid;
2166             if ((o = dofindlabel(kid, label, ops, oplimit)))
2167                 return o;
2168         }
2169     }
2170     *ops = 0;
2171     return 0;
2172 }
2173
2174 PP(pp_dump)
2175 {
2176     return pp_goto();
2177     /*NOTREACHED*/
2178 }
2179
2180 PP(pp_goto)
2181 {
2182     djSP;
2183     OP *retop = 0;
2184     I32 ix;
2185     register PERL_CONTEXT *cx;
2186 #define GOTO_DEPTH 64
2187     OP *enterops[GOTO_DEPTH];
2188     char *label;
2189     int do_dump = (PL_op->op_type == OP_DUMP);
2190     static char must_have_label[] = "goto must have label";
2191
2192     label = 0;
2193     if (PL_op->op_flags & OPf_STACKED) {
2194         SV *sv = POPs;
2195         STRLEN n_a;
2196
2197         /* This egregious kludge implements goto &subroutine */
2198         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2199             I32 cxix;
2200             register PERL_CONTEXT *cx;
2201             CV* cv = (CV*)SvRV(sv);
2202             SV** mark;
2203             I32 items = 0;
2204             I32 oldsave;
2205
2206         retry:
2207             if (!CvROOT(cv) && !CvXSUB(cv)) {
2208                 GV *gv = CvGV(cv);
2209                 GV *autogv;
2210                 if (gv) {
2211                     SV *tmpstr;
2212                     /* autoloaded stub? */
2213                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2214                         goto retry;
2215                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2216                                           GvNAMELEN(gv), FALSE);
2217                     if (autogv && (cv = GvCV(autogv)))
2218                         goto retry;
2219                     tmpstr = sv_newmortal();
2220                     gv_efullname3(tmpstr, gv, Nullch);
2221                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2222                 }
2223                 DIE(aTHX_ "Goto undefined subroutine");
2224             }
2225
2226             /* First do some returnish stuff. */
2227             cxix = dopoptosub(cxstack_ix);
2228             if (cxix < 0)
2229                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2230             if (cxix < cxstack_ix)
2231                 dounwind(cxix);
2232             TOPBLOCK(cx);
2233             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2234                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2235             mark = PL_stack_sp;
2236             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2237                 /* put @_ back onto stack */
2238                 AV* av = cx->blk_sub.argarray;
2239
2240                 items = AvFILLp(av) + 1;
2241                 PL_stack_sp++;
2242                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2243                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2244                 PL_stack_sp += items;
2245 #ifndef USE_THREADS
2246                 SvREFCNT_dec(GvAV(PL_defgv));
2247                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2248 #endif /* USE_THREADS */
2249                 /* abandon @_ if it got reified */
2250                 if (AvREAL(av)) {
2251                     (void)sv_2mortal((SV*)av);  /* delay until return */
2252                     av = newAV();
2253                     av_extend(av, items-1);
2254                     AvFLAGS(av) = AVf_REIFY;
2255                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2256                 }
2257             }
2258             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2259                 AV* av;
2260 #ifdef USE_THREADS
2261                 av = (AV*)PL_curpad[0];
2262 #else
2263                 av = GvAV(PL_defgv);
2264 #endif
2265                 items = AvFILLp(av) + 1;
2266                 PL_stack_sp++;
2267                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2268                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2269                 PL_stack_sp += items;
2270             }
2271             if (CxTYPE(cx) == CXt_SUB &&
2272                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2273                 SvREFCNT_dec(cx->blk_sub.cv);
2274             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2275             LEAVE_SCOPE(oldsave);
2276
2277             /* Now do some callish stuff. */
2278             SAVETMPS;
2279             if (CvXSUB(cv)) {
2280 #ifdef PERL_XSUB_OLDSTYLE
2281                 if (CvOLDSTYLE(cv)) {
2282                     I32 (*fp3)(int,int,int);
2283                     while (SP > mark) {
2284                         SP[1] = SP[0];
2285                         SP--;
2286                     }
2287                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2288                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2289                                    mark - PL_stack_base + 1,
2290                                    items);
2291                     SP = PL_stack_base + items;
2292                 }
2293                 else
2294 #endif /* PERL_XSUB_OLDSTYLE */
2295                 {
2296                     SV **newsp;
2297                     I32 gimme;
2298
2299                     PL_stack_sp--;              /* There is no cv arg. */
2300                     /* Push a mark for the start of arglist */
2301                     PUSHMARK(mark);
2302                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2303                     /* Pop the current context like a decent sub should */
2304                     POPBLOCK(cx, PL_curpm);
2305                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2306                 }
2307                 LEAVE;
2308                 return pop_return();
2309             }
2310             else {
2311                 AV* padlist = CvPADLIST(cv);
2312                 SV** svp = AvARRAY(padlist);
2313                 if (CxTYPE(cx) == CXt_EVAL) {
2314                     PL_in_eval = cx->blk_eval.old_in_eval;
2315                     PL_eval_root = cx->blk_eval.old_eval_root;
2316                     cx->cx_type = CXt_SUB;
2317                     cx->blk_sub.hasargs = 0;
2318                 }
2319                 cx->blk_sub.cv = cv;
2320                 cx->blk_sub.olddepth = CvDEPTH(cv);
2321                 CvDEPTH(cv)++;
2322                 if (CvDEPTH(cv) < 2)
2323                     (void)SvREFCNT_inc(cv);
2324                 else {  /* save temporaries on recursion? */
2325                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2326                         sub_crush_depth(cv);
2327                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2328                         AV *newpad = newAV();
2329                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2330                         I32 ix = AvFILLp((AV*)svp[1]);
2331                         I32 names_fill = AvFILLp((AV*)svp[0]);
2332                         svp = AvARRAY(svp[0]);
2333                         for ( ;ix > 0; ix--) {
2334                             if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2335                                 char *name = SvPVX(svp[ix]);
2336                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2337                                     || *name == '&')
2338                                 {
2339                                     /* outer lexical or anon code */
2340                                     av_store(newpad, ix,
2341                                         SvREFCNT_inc(oldpad[ix]) );
2342                                 }
2343                                 else {          /* our own lexical */
2344                                     if (*name == '@')
2345                                         av_store(newpad, ix, sv = (SV*)newAV());
2346                                     else if (*name == '%')
2347                                         av_store(newpad, ix, sv = (SV*)newHV());
2348                                     else
2349                                         av_store(newpad, ix, sv = NEWSV(0,0));
2350                                     SvPADMY_on(sv);
2351                                 }
2352                             }
2353                             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2354                                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2355                             }
2356                             else {
2357                                 av_store(newpad, ix, sv = NEWSV(0,0));
2358                                 SvPADTMP_on(sv);
2359                             }
2360                         }
2361                         if (cx->blk_sub.hasargs) {
2362                             AV* av = newAV();
2363                             av_extend(av, 0);
2364                             av_store(newpad, 0, (SV*)av);
2365                             AvFLAGS(av) = AVf_REIFY;
2366                         }
2367                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2368                         AvFILLp(padlist) = CvDEPTH(cv);
2369                         svp = AvARRAY(padlist);
2370                     }
2371                 }
2372 #ifdef USE_THREADS
2373                 if (!cx->blk_sub.hasargs) {
2374                     AV* av = (AV*)PL_curpad[0];
2375
2376                     items = AvFILLp(av) + 1;
2377                     if (items) {
2378                         /* Mark is at the end of the stack. */
2379                         EXTEND(SP, items);
2380                         Copy(AvARRAY(av), SP + 1, items, SV*);
2381                         SP += items;
2382                         PUTBACK ;
2383                     }
2384                 }
2385 #endif /* USE_THREADS */
2386                 SAVEVPTR(PL_curpad);
2387                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2388 #ifndef USE_THREADS
2389                 if (cx->blk_sub.hasargs)
2390 #endif /* USE_THREADS */
2391                 {
2392                     AV* av = (AV*)PL_curpad[0];
2393                     SV** ary;
2394
2395 #ifndef USE_THREADS
2396                     cx->blk_sub.savearray = GvAV(PL_defgv);
2397                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2398 #endif /* USE_THREADS */
2399                     cx->blk_sub.oldcurpad = PL_curpad;
2400                     cx->blk_sub.argarray = av;
2401                     ++mark;
2402
2403                     if (items >= AvMAX(av) + 1) {
2404                         ary = AvALLOC(av);
2405                         if (AvARRAY(av) != ary) {
2406                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407                             SvPVX(av) = (char*)ary;
2408                         }
2409                         if (items >= AvMAX(av) + 1) {
2410                             AvMAX(av) = items - 1;
2411                             Renew(ary,items+1,SV*);
2412                             AvALLOC(av) = ary;
2413                             SvPVX(av) = (char*)ary;
2414                         }
2415                     }
2416                     Copy(mark,AvARRAY(av),items,SV*);
2417                     AvFILLp(av) = items - 1;
2418                     assert(!AvREAL(av));
2419                     while (items--) {
2420                         if (*mark)
2421                             SvTEMP_off(*mark);
2422                         mark++;
2423                     }
2424                 }
2425                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2426                     /*
2427                      * We do not care about using sv to call CV;
2428                      * it's for informational purposes only.
2429                      */
2430                     SV *sv = GvSV(PL_DBsub);
2431                     CV *gotocv;
2432
2433                     if (PERLDB_SUB_NN) {
2434                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2435                     } else {
2436                         save_item(sv);
2437                         gv_efullname3(sv, CvGV(cv), Nullch);
2438                     }
2439                     if (  PERLDB_GOTO
2440                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2441                         PUSHMARK( PL_stack_sp );
2442                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2443                         PL_stack_sp--;
2444                     }
2445                 }
2446                 RETURNOP(CvSTART(cv));
2447             }
2448         }
2449         else {
2450             label = SvPV(sv,n_a);
2451             if (!(do_dump || *label))
2452                 DIE(aTHX_ must_have_label);
2453         }
2454     }
2455     else if (PL_op->op_flags & OPf_SPECIAL) {
2456         if (! do_dump)
2457             DIE(aTHX_ must_have_label);
2458     }
2459     else
2460         label = cPVOP->op_pv;
2461
2462     if (label && *label) {
2463         OP *gotoprobe = 0;
2464
2465         /* find label */
2466
2467         PL_lastgotoprobe = 0;
2468         *enterops = 0;
2469         for (ix = cxstack_ix; ix >= 0; ix--) {
2470             cx = &cxstack[ix];
2471             switch (CxTYPE(cx)) {
2472             case CXt_EVAL:
2473                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2474                 break;
2475             case CXt_LOOP:
2476                 gotoprobe = cx->blk_oldcop->op_sibling;
2477                 break;
2478             case CXt_SUBST:
2479                 continue;
2480             case CXt_BLOCK:
2481                 if (ix)
2482                     gotoprobe = cx->blk_oldcop->op_sibling;
2483                 else
2484                     gotoprobe = PL_main_root;
2485                 break;
2486             case CXt_SUB:
2487                 if (CvDEPTH(cx->blk_sub.cv)) {
2488                     gotoprobe = CvROOT(cx->blk_sub.cv);
2489                     break;
2490                 }
2491                 /* FALL THROUGH */
2492             case CXt_FORMAT:
2493             case CXt_NULL:
2494                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2495             default:
2496                 if (ix)
2497                     DIE(aTHX_ "panic: goto");
2498                 gotoprobe = PL_main_root;
2499                 break;
2500             }
2501             if (gotoprobe) {
2502                 retop = dofindlabel(gotoprobe, label,
2503                                     enterops, enterops + GOTO_DEPTH);
2504                 if (retop)
2505                     break;
2506             }
2507             PL_lastgotoprobe = gotoprobe;
2508         }
2509         if (!retop)
2510             DIE(aTHX_ "Can't find label %s", label);
2511
2512         /* pop unwanted frames */
2513
2514         if (ix < cxstack_ix) {
2515             I32 oldsave;
2516
2517             if (ix < 0)
2518                 ix = 0;
2519             dounwind(ix);
2520             TOPBLOCK(cx);
2521             oldsave = PL_scopestack[PL_scopestack_ix];
2522             LEAVE_SCOPE(oldsave);
2523         }
2524
2525         /* push wanted frames */
2526
2527         if (*enterops && enterops[1]) {
2528             OP *oldop = PL_op;
2529             for (ix = 1; enterops[ix]; ix++) {
2530                 PL_op = enterops[ix];
2531                 /* Eventually we may want to stack the needed arguments
2532                  * for each op.  For now, we punt on the hard ones. */
2533                 if (PL_op->op_type == OP_ENTERITER)
2534                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2535                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2536             }
2537             PL_op = oldop;
2538         }
2539     }
2540
2541     if (do_dump) {
2542 #ifdef VMS
2543         if (!retop) retop = PL_main_start;
2544 #endif
2545         PL_restartop = retop;
2546         PL_do_undump = TRUE;
2547
2548         my_unexec();
2549
2550         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2551         PL_do_undump = FALSE;
2552     }
2553
2554     RETURNOP(retop);
2555 }
2556
2557 PP(pp_exit)
2558 {
2559     djSP;
2560     I32 anum;
2561
2562     if (MAXARG < 1)
2563         anum = 0;
2564     else {
2565         anum = SvIVx(POPs);
2566 #ifdef VMS
2567         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2568             anum = 0;
2569 #endif
2570     }
2571     PL_exit_flags |= PERL_EXIT_EXPECTED;
2572     my_exit(anum);
2573     PUSHs(&PL_sv_undef);
2574     RETURN;
2575 }
2576
2577 #ifdef NOTYET
2578 PP(pp_nswitch)
2579 {
2580     djSP;
2581     NV value = SvNVx(GvSV(cCOP->cop_gv));
2582     register I32 match = I_32(value);
2583
2584     if (value < 0.0) {
2585         if (((NV)match) > value)
2586             --match;            /* was fractional--truncate other way */
2587     }
2588     match -= cCOP->uop.scop.scop_offset;
2589     if (match < 0)
2590         match = 0;
2591     else if (match > cCOP->uop.scop.scop_max)
2592         match = cCOP->uop.scop.scop_max;
2593     PL_op = cCOP->uop.scop.scop_next[match];
2594     RETURNOP(PL_op);
2595 }
2596
2597 PP(pp_cswitch)
2598 {
2599     djSP;
2600     register I32 match;
2601
2602     if (PL_multiline)
2603         PL_op = PL_op->op_next;                 /* can't assume anything */
2604     else {
2605         STRLEN n_a;
2606         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2607         match -= cCOP->uop.scop.scop_offset;
2608         if (match < 0)
2609             match = 0;
2610         else if (match > cCOP->uop.scop.scop_max)
2611             match = cCOP->uop.scop.scop_max;
2612         PL_op = cCOP->uop.scop.scop_next[match];
2613     }
2614     RETURNOP(PL_op);
2615 }
2616 #endif
2617
2618 /* Eval. */
2619
2620 STATIC void
2621 S_save_lines(pTHX_ AV *array, SV *sv)
2622 {
2623     register char *s = SvPVX(sv);
2624     register char *send = SvPVX(sv) + SvCUR(sv);
2625     register char *t;
2626     register I32 line = 1;
2627
2628     while (s && s < send) {
2629         SV *tmpstr = NEWSV(85,0);
2630
2631         sv_upgrade(tmpstr, SVt_PVMG);
2632         t = strchr(s, '\n');
2633         if (t)
2634             t++;
2635         else
2636             t = send;
2637
2638         sv_setpvn(tmpstr, s, t - s);
2639         av_store(array, line++, tmpstr);
2640         s = t;
2641     }
2642 }
2643
2644 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2645 STATIC void *
2646 S_docatch_body(pTHX_ va_list args)
2647 {
2648     return docatch_body();
2649 }
2650 #endif
2651
2652 STATIC void *
2653 S_docatch_body(pTHX)
2654 {
2655     CALLRUNOPS(aTHX);
2656     return NULL;
2657 }
2658
2659 STATIC OP *
2660 S_docatch(pTHX_ OP *o)
2661 {
2662     int ret;
2663     OP *oldop = PL_op;
2664     volatile PERL_SI *cursi = PL_curstackinfo;
2665     dJMPENV;
2666
2667 #ifdef DEBUGGING
2668     assert(CATCH_GET == TRUE);
2669 #endif
2670     PL_op = o;
2671 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2672  redo_body:
2673     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2674 #else
2675     JMPENV_PUSH(ret);
2676 #endif
2677     switch (ret) {
2678     case 0:
2679 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2680  redo_body:
2681         docatch_body();
2682 #endif
2683         break;
2684     case 3:
2685         if (PL_restartop && cursi == PL_curstackinfo) {
2686             PL_op = PL_restartop;
2687             PL_restartop = 0;
2688             goto redo_body;
2689         }
2690         /* FALL THROUGH */
2691     default:
2692         JMPENV_POP;
2693         PL_op = oldop;
2694         JMPENV_JUMP(ret);
2695         /* NOTREACHED */
2696     }
2697     JMPENV_POP;
2698     PL_op = oldop;
2699     return Nullop;
2700 }
2701
2702 OP *
2703 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2704 /* sv Text to convert to OP tree. */
2705 /* startop op_free() this to undo. */
2706 /* code Short string id of the caller. */
2707 {
2708     dSP;                                /* Make POPBLOCK work. */
2709     PERL_CONTEXT *cx;
2710     SV **newsp;
2711     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2712     I32 optype;
2713     OP dummy;
2714     OP *rop;
2715     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2716     char *tmpbuf = tbuf;
2717     char *safestr;
2718
2719     ENTER;
2720     lex_start(sv);
2721     SAVETMPS;
2722     /* switch to eval mode */
2723
2724     if (PL_curcop == &PL_compiling) {
2725         SAVECOPSTASH_FREE(&PL_compiling);
2726         CopSTASH_set(&PL_compiling, PL_curstash);
2727     }
2728     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2729         SV *sv = sv_newmortal();
2730         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2731                        code, (unsigned long)++PL_evalseq,
2732                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2733         tmpbuf = SvPVX(sv);
2734     }
2735     else
2736         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2737     SAVECOPFILE_FREE(&PL_compiling);
2738     CopFILE_set(&PL_compiling, tmpbuf+2);
2739     SAVECOPLINE(&PL_compiling);
2740     CopLINE_set(&PL_compiling, 1);
2741     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2742        deleting the eval's FILEGV from the stash before gv_check() runs
2743        (i.e. before run-time proper). To work around the coredump that
2744        ensues, we always turn GvMULTI_on for any globals that were
2745        introduced within evals. See force_ident(). GSAR 96-10-12 */
2746     safestr = savepv(tmpbuf);
2747     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2748     SAVEHINTS();
2749 #ifdef OP_IN_REGISTER
2750     PL_opsave = op;
2751 #else
2752     SAVEVPTR(PL_op);
2753 #endif
2754     PL_hints = 0;
2755
2756     PL_op = &dummy;
2757     PL_op->op_type = OP_ENTEREVAL;
2758     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2759     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2760     PUSHEVAL(cx, 0, Nullgv);
2761     rop = doeval(G_SCALAR, startop);
2762     POPBLOCK(cx,PL_curpm);
2763     POPEVAL(cx);
2764
2765     (*startop)->op_type = OP_NULL;
2766     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2767     lex_end();
2768     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2769     LEAVE;
2770     if (PL_curcop == &PL_compiling)
2771         PL_compiling.op_private = PL_hints;
2772 #ifdef OP_IN_REGISTER
2773     op = PL_opsave;
2774 #endif
2775     return rop;
2776 }
2777
2778 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2779 STATIC OP *
2780 S_doeval(pTHX_ int gimme, OP** startop)
2781 {
2782     dSP;
2783     OP *saveop = PL_op;
2784     CV *caller;
2785     AV* comppadlist;
2786     I32 i;
2787
2788     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2789                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2790                   : EVAL_INEVAL);
2791
2792     PUSHMARK(SP);
2793
2794     /* set up a scratch pad */
2795
2796     SAVEI32(PL_padix);
2797     SAVEVPTR(PL_curpad);
2798     SAVESPTR(PL_comppad);
2799     SAVESPTR(PL_comppad_name);
2800     SAVEI32(PL_comppad_name_fill);
2801     SAVEI32(PL_min_intro_pending);
2802     SAVEI32(PL_max_intro_pending);
2803
2804     caller = PL_compcv;
2805     for (i = cxstack_ix - 1; i >= 0; i--) {
2806         PERL_CONTEXT *cx = &cxstack[i];
2807         if (CxTYPE(cx) == CXt_EVAL)
2808             break;
2809         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2810             caller = cx->blk_sub.cv;
2811             break;
2812         }
2813     }
2814
2815     SAVESPTR(PL_compcv);
2816     PL_compcv = (CV*)NEWSV(1104,0);
2817     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2818     CvEVAL_on(PL_compcv);
2819 #ifdef USE_THREADS
2820     CvOWNER(PL_compcv) = 0;
2821     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2822     MUTEX_INIT(CvMUTEXP(PL_compcv));
2823 #endif /* USE_THREADS */
2824
2825     PL_comppad = newAV();
2826     av_push(PL_comppad, Nullsv);
2827     PL_curpad = AvARRAY(PL_comppad);
2828     PL_comppad_name = newAV();
2829     PL_comppad_name_fill = 0;
2830     PL_min_intro_pending = 0;
2831     PL_padix = 0;
2832 #ifdef USE_THREADS
2833     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2834     PL_curpad[0] = (SV*)newAV();
2835     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2836 #endif /* USE_THREADS */
2837
2838     comppadlist = newAV();
2839     AvREAL_off(comppadlist);
2840     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2841     av_store(comppadlist, 1, (SV*)PL_comppad);
2842     CvPADLIST(PL_compcv) = comppadlist;
2843
2844     if (!saveop ||
2845         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2846     {
2847         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2848     }
2849
2850     SAVEFREESV(PL_compcv);
2851
2852     /* make sure we compile in the right package */
2853
2854     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2855         SAVESPTR(PL_curstash);
2856         PL_curstash = CopSTASH(PL_curcop);
2857     }
2858     SAVESPTR(PL_beginav);
2859     PL_beginav = newAV();
2860     SAVEFREESV(PL_beginav);
2861     SAVEI32(PL_error_count);
2862
2863     /* try to compile it */
2864
2865     PL_eval_root = Nullop;
2866     PL_error_count = 0;
2867     PL_curcop = &PL_compiling;
2868     PL_curcop->cop_arybase = 0;
2869     SvREFCNT_dec(PL_rs);
2870     PL_rs = newSVpvn("\n", 1);
2871     if (saveop && saveop->op_flags & OPf_SPECIAL)
2872         PL_in_eval |= EVAL_KEEPERR;
2873     else
2874         sv_setpv(ERRSV,"");
2875     if (yyparse() || PL_error_count || !PL_eval_root) {
2876         SV **newsp;
2877         I32 gimme;
2878         PERL_CONTEXT *cx;
2879         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2880         STRLEN n_a;
2881
2882         PL_op = saveop;
2883         if (PL_eval_root) {
2884             op_free(PL_eval_root);
2885             PL_eval_root = Nullop;
2886         }
2887         SP = PL_stack_base + POPMARK;           /* pop original mark */
2888         if (!startop) {
2889             POPBLOCK(cx,PL_curpm);
2890             POPEVAL(cx);
2891             pop_return();
2892         }
2893         lex_end();
2894         LEAVE;
2895         if (optype == OP_REQUIRE) {
2896             char* msg = SvPVx(ERRSV, n_a);
2897             DIE(aTHX_ "%sCompilation failed in require",
2898                 *msg ? msg : "Unknown error\n");
2899         }
2900         else if (startop) {
2901             char* msg = SvPVx(ERRSV, n_a);
2902
2903             POPBLOCK(cx,PL_curpm);
2904             POPEVAL(cx);
2905             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2906                        (*msg ? msg : "Unknown error\n"));
2907         }
2908         SvREFCNT_dec(PL_rs);
2909         PL_rs = SvREFCNT_inc(PL_nrs);
2910 #ifdef USE_THREADS
2911         MUTEX_LOCK(&PL_eval_mutex);
2912         PL_eval_owner = 0;
2913         COND_SIGNAL(&PL_eval_cond);
2914         MUTEX_UNLOCK(&PL_eval_mutex);
2915 #endif /* USE_THREADS */
2916         RETPUSHUNDEF;
2917     }
2918     SvREFCNT_dec(PL_rs);
2919     PL_rs = SvREFCNT_inc(PL_nrs);
2920     CopLINE_set(&PL_compiling, 0);
2921     if (startop) {
2922         *startop = PL_eval_root;
2923         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2924         CvOUTSIDE(PL_compcv) = Nullcv;
2925     } else
2926         SAVEFREEOP(PL_eval_root);
2927     if (gimme & G_VOID)
2928         scalarvoid(PL_eval_root);
2929     else if (gimme & G_ARRAY)
2930         list(PL_eval_root);
2931     else
2932         scalar(PL_eval_root);
2933
2934     DEBUG_x(dump_eval());
2935
2936     /* Register with debugger: */
2937     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2938         CV *cv = get_cv("DB::postponed", FALSE);
2939         if (cv) {
2940             dSP;
2941             PUSHMARK(SP);
2942             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2943             PUTBACK;
2944             call_sv((SV*)cv, G_DISCARD);
2945         }
2946     }
2947
2948     /* compiled okay, so do it */
2949
2950     CvDEPTH(PL_compcv) = 1;
2951     SP = PL_stack_base + POPMARK;               /* pop original mark */
2952     PL_op = saveop;                     /* The caller may need it. */
2953     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2954 #ifdef USE_THREADS
2955     MUTEX_LOCK(&PL_eval_mutex);
2956     PL_eval_owner = 0;
2957     COND_SIGNAL(&PL_eval_cond);
2958     MUTEX_UNLOCK(&PL_eval_mutex);
2959 #endif /* USE_THREADS */
2960
2961     RETURNOP(PL_eval_start);
2962 }
2963
2964 STATIC PerlIO *
2965 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2966 {
2967     STRLEN namelen = strlen(name);
2968     PerlIO *fp;
2969
2970     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2971         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2972         char *pmc = SvPV_nolen(pmcsv);
2973         Stat_t pmstat;
2974         Stat_t pmcstat;
2975         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2976             fp = PerlIO_open(name, mode);
2977         }
2978         else {
2979             if (PerlLIO_stat(name, &pmstat) < 0 ||
2980                 pmstat.st_mtime < pmcstat.st_mtime)
2981             {
2982                 fp = PerlIO_open(pmc, mode);
2983             }
2984             else {
2985                 fp = PerlIO_open(name, mode);
2986             }
2987         }
2988         SvREFCNT_dec(pmcsv);
2989     }
2990     else {
2991         fp = PerlIO_open(name, mode);
2992     }
2993     return fp;
2994 }
2995
2996 PP(pp_require)
2997 {
2998     djSP;
2999     register PERL_CONTEXT *cx;
3000     SV *sv;
3001     char *name;
3002     STRLEN len;
3003     char *tryname;
3004     SV *namesv = Nullsv;
3005     SV** svp;
3006     I32 gimme = G_SCALAR;
3007     PerlIO *tryrsfp = 0;
3008     STRLEN n_a;
3009     int filter_has_file = 0;
3010     GV *filter_child_proc = 0;
3011     SV *filter_state = 0;
3012     SV *filter_sub = 0;
3013
3014     sv = POPs;
3015     if (SvNIOKp(sv)) {
3016         if (SvPOK(sv) && SvNOK(sv)) {           /* require v5.6.1 */
3017             UV rev = 0, ver = 0, sver = 0;
3018             STRLEN len;
3019             U8 *s = (U8*)SvPVX(sv);
3020             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3021             if (s < end) {
3022                 rev = utf8_to_uv(s, end - s, &len, 0);
3023                 s += len;
3024                 if (s < end) {
3025                     ver = utf8_to_uv(s, end - s, &len, 0);
3026                     s += len;
3027                     if (s < end)
3028                         sver = utf8_to_uv(s, end - s, &len, 0);
3029                 }
3030             }
3031             if (PERL_REVISION < rev
3032                 || (PERL_REVISION == rev
3033                     && (PERL_VERSION < ver
3034                         || (PERL_VERSION == ver
3035                             && PERL_SUBVERSION < sver))))
3036             {
3037                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3038                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3039                     PERL_VERSION, PERL_SUBVERSION);
3040             }
3041             RETPUSHYES;
3042         }
3043         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3044             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3045                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3046                 + 0.00000099 < SvNV(sv))
3047             {
3048                 NV nrev = SvNV(sv);
3049                 UV rev = (UV)nrev;
3050                 NV nver = (nrev - rev) * 1000;
3051                 UV ver = (UV)(nver + 0.0009);
3052                 NV nsver = (nver - ver) * 1000;
3053                 UV sver = (UV)(nsver + 0.0009);
3054
3055                 /* help out with the "use 5.6" confusion */
3056                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3057                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3058                         "this is only v%d.%d.%d, stopped"
3059                         " (did you mean v%"UVuf".%"UVuf".0?)",
3060                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3061                         PERL_SUBVERSION, rev, ver/100);
3062                 }
3063                 else {
3064                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3065                         "this is only v%d.%d.%d, stopped",
3066                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3067                         PERL_SUBVERSION);
3068                 }
3069             }
3070             RETPUSHYES;
3071         }
3072     }
3073     name = SvPV(sv, len);
3074     if (!(name && len > 0 && *name))
3075         DIE(aTHX_ "Null filename used");
3076     TAINT_PROPER("require");
3077     if (PL_op->op_type == OP_REQUIRE &&
3078       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3079       *svp != &PL_sv_undef)
3080         RETPUSHYES;
3081
3082     /* prepare to compile file */
3083
3084     if (PERL_FILE_IS_ABSOLUTE(name)
3085         || (*name == '.' && (name[1] == '/' ||
3086                              (name[1] == '.' && name[2] == '/'))))
3087     {
3088         tryname = name;
3089         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3090 #ifdef MACOS_TRADITIONAL
3091         /* We consider paths of the form :a:b ambiguous and interpret them first
3092            as global then as local
3093         */
3094         if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3095             goto trylocal;
3096     }
3097     else
3098 trylocal: {
3099 #else
3100     }
3101     else {
3102 #endif
3103         AV *ar = GvAVn(PL_incgv);
3104         I32 i;
3105 #ifdef VMS
3106         char *unixname;
3107         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3108 #endif
3109         {
3110             namesv = NEWSV(806, 0);
3111             for (i = 0; i <= AvFILL(ar); i++) {
3112                 SV *dirsv = *av_fetch(ar, i, TRUE);
3113
3114                 if (SvROK(dirsv)) {
3115                     int count;
3116                     SV *loader = dirsv;
3117
3118                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3119                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3120                     }
3121
3122                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3123                                    PTR2UV(SvANY(loader)), name);
3124                     tryname = SvPVX(namesv);
3125                     tryrsfp = 0;
3126
3127                     ENTER;
3128                     SAVETMPS;
3129                     EXTEND(SP, 2);
3130
3131                     PUSHMARK(SP);
3132                     PUSHs(dirsv);
3133                     PUSHs(sv);
3134                     PUTBACK;
3135                     count = call_sv(loader, G_ARRAY);
3136                     SPAGAIN;
3137
3138                     if (count > 0) {
3139                         int i = 0;
3140                         SV *arg;
3141
3142                         SP -= count - 1;
3143                         arg = SP[i++];
3144
3145                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3146                             arg = SvRV(arg);
3147                         }
3148
3149                         if (SvTYPE(arg) == SVt_PVGV) {
3150                             IO *io = GvIO((GV *)arg);
3151
3152                             ++filter_has_file;
3153
3154                             if (io) {
3155                                 tryrsfp = IoIFP(io);
3156                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3157                                     /* reading from a child process doesn't
3158                                        nest -- when returning from reading
3159                                        the inner module, the outer one is
3160                                        unreadable (closed?)  I've tried to
3161                                        save the gv to manage the lifespan of
3162                                        the pipe, but this didn't help. XXX */
3163                                     filter_child_proc = (GV *)arg;
3164                                     (void)SvREFCNT_inc(filter_child_proc);
3165                                 }
3166                                 else {
3167                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3168                                         PerlIO_close(IoOFP(io));
3169                                     }
3170                                     IoIFP(io) = Nullfp;
3171                                     IoOFP(io) = Nullfp;
3172                                 }
3173                             }
3174
3175                             if (i < count) {
3176                                 arg = SP[i++];
3177                             }
3178                         }
3179
3180                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3181                             filter_sub = arg;
3182                             (void)SvREFCNT_inc(filter_sub);
3183
3184                             if (i < count) {
3185                                 filter_state = SP[i];
3186                                 (void)SvREFCNT_inc(filter_state);
3187                             }
3188
3189                             if (tryrsfp == 0) {
3190                                 tryrsfp = PerlIO_open("/dev/null",
3191                                                       PERL_SCRIPT_MODE);
3192                             }
3193                         }
3194                     }
3195
3196                     PUTBACK;
3197                     FREETMPS;
3198                     LEAVE;
3199
3200                     if (tryrsfp) {
3201                         break;
3202                     }
3203
3204                     filter_has_file = 0;
3205                     if (filter_child_proc) {
3206                         SvREFCNT_dec(filter_child_proc);
3207                         filter_child_proc = 0;
3208                     }
3209                     if (filter_state) {
3210                         SvREFCNT_dec(filter_state);
3211                         filter_state = 0;
3212                     }
3213                     if (filter_sub) {
3214                         SvREFCNT_dec(filter_sub);
3215                         filter_sub = 0;
3216                     }
3217                 }
3218                 else {
3219                     char *dir = SvPVx(dirsv, n_a);
3220 #ifdef MACOS_TRADITIONAL
3221                     char buf[256];
3222                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3223 #else
3224 #ifdef VMS
3225                     char *unixdir;
3226                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3227                         continue;
3228                     sv_setpv(namesv, unixdir);
3229                     sv_catpv(namesv, unixname);
3230 #else
3231                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3232 #endif
3233 #endif
3234                     TAINT_PROPER("require");
3235                     tryname = SvPVX(namesv);
3236 #ifdef MACOS_TRADITIONAL
3237                     {
3238                         /* Convert slashes in the name part, but not the directory part, to colons */
3239                         char * colon;
3240                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3241                             *colon++ = ':';
3242                     }
3243 #endif
3244                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3245                     if (tryrsfp) {
3246                         if (tryname[0] == '.' && tryname[1] == '/')
3247                             tryname += 2;
3248                         break;
3249                     }
3250                 }
3251             }
3252         }
3253     }
3254     SAVECOPFILE_FREE(&PL_compiling);
3255     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3256     SvREFCNT_dec(namesv);
3257     if (!tryrsfp) {
3258         if (PL_op->op_type == OP_REQUIRE) {
3259             char *msgstr = name;
3260             if (namesv) {                       /* did we lookup @INC? */
3261                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3262                 SV *dirmsgsv = NEWSV(0, 0);
3263                 AV *ar = GvAVn(PL_incgv);
3264                 I32 i;
3265                 sv_catpvn(msg, " in @INC", 8);
3266                 if (instr(SvPVX(msg), ".h "))
3267                     sv_catpv(msg, " (change .h to .ph maybe?)");
3268                 if (instr(SvPVX(msg), ".ph "))
3269                     sv_catpv(msg, " (did you run h2ph?)");
3270                 sv_catpv(msg, " (@INC contains:");
3271                 for (i = 0; i <= AvFILL(ar); i++) {
3272                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3273                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3274                     sv_catsv(msg, dirmsgsv);
3275                 }
3276                 sv_catpvn(msg, ")", 1);
3277                 SvREFCNT_dec(dirmsgsv);
3278                 msgstr = SvPV_nolen(msg);
3279             }
3280             DIE(aTHX_ "Can't locate %s", msgstr);
3281         }
3282
3283         RETPUSHUNDEF;
3284     }
3285     else
3286         SETERRNO(0, SS$_NORMAL);
3287
3288     /* Assume success here to prevent recursive requirement. */
3289     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3290                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3291
3292     ENTER;
3293     SAVETMPS;
3294     lex_start(sv_2mortal(newSVpvn("",0)));
3295     SAVEGENERICSV(PL_rsfp_filters);
3296     PL_rsfp_filters = Nullav;
3297
3298     PL_rsfp = tryrsfp;
3299     SAVEHINTS();
3300     PL_hints = 0;
3301     SAVESPTR(PL_compiling.cop_warnings);
3302     if (PL_dowarn & G_WARN_ALL_ON)
3303         PL_compiling.cop_warnings = pWARN_ALL ;
3304     else if (PL_dowarn & G_WARN_ALL_OFF)
3305         PL_compiling.cop_warnings = pWARN_NONE ;
3306     else
3307         PL_compiling.cop_warnings = pWARN_STD ;
3308     SAVESPTR(PL_compiling.cop_io);
3309     PL_compiling.cop_io = Nullsv;
3310
3311     if (filter_sub || filter_child_proc) {
3312         SV *datasv = filter_add(run_user_filter, Nullsv);
3313         IoLINES(datasv) = filter_has_file;
3314         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3315         IoTOP_GV(datasv) = (GV *)filter_state;
3316         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3317     }
3318
3319     /* switch to eval mode */
3320     push_return(PL_op->op_next);
3321     PUSHBLOCK(cx, CXt_EVAL, SP);
3322     PUSHEVAL(cx, name, Nullgv);
3323
3324     SAVECOPLINE(&PL_compiling);
3325     CopLINE_set(&PL_compiling, 0);
3326
3327     PUTBACK;
3328 #ifdef USE_THREADS
3329     MUTEX_LOCK(&PL_eval_mutex);
3330     if (PL_eval_owner && PL_eval_owner != thr)
3331         while (PL_eval_owner)
3332             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3333     PL_eval_owner = thr;
3334     MUTEX_UNLOCK(&PL_eval_mutex);
3335 #endif /* USE_THREADS */
3336     return DOCATCH(doeval(G_SCALAR, NULL));
3337 }
3338
3339 PP(pp_dofile)
3340 {
3341     return pp_require();
3342 }
3343
3344 PP(pp_entereval)
3345 {
3346     djSP;
3347     register PERL_CONTEXT *cx;
3348     dPOPss;
3349     I32 gimme = GIMME_V, was = PL_sub_generation;
3350     char tbuf[TYPE_DIGITS(long) + 12];
3351     char *tmpbuf = tbuf;
3352     char *safestr;
3353     STRLEN len;
3354     OP *ret;
3355
3356     if (!SvPV(sv,len) || !len)
3357         RETPUSHUNDEF;
3358     TAINT_PROPER("eval");
3359
3360     ENTER;
3361     lex_start(sv);
3362     SAVETMPS;
3363
3364     /* switch to eval mode */
3365
3366     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3367         SV *sv = sv_newmortal();
3368         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3369                        (unsigned long)++PL_evalseq,
3370                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3371         tmpbuf = SvPVX(sv);
3372     }
3373     else
3374         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3375     SAVECOPFILE_FREE(&PL_compiling);
3376     CopFILE_set(&PL_compiling, tmpbuf+2);
3377     SAVECOPLINE(&PL_compiling);
3378     CopLINE_set(&PL_compiling, 1);
3379     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3380        deleting the eval's FILEGV from the stash before gv_check() runs
3381        (i.e. before run-time proper). To work around the coredump that
3382        ensues, we always turn GvMULTI_on for any globals that were
3383        introduced within evals. See force_ident(). GSAR 96-10-12 */
3384     safestr = savepv(tmpbuf);
3385     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3386     SAVEHINTS();
3387     PL_hints = PL_op->op_targ;
3388     SAVESPTR(PL_compiling.cop_warnings);
3389     if (specialWARN(PL_curcop->cop_warnings))
3390         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3391     else {
3392         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3393         SAVEFREESV(PL_compiling.cop_warnings);
3394     }
3395     SAVESPTR(PL_compiling.cop_io);
3396     if (specialCopIO(PL_curcop->cop_io))
3397         PL_compiling.cop_io = PL_curcop->cop_io;
3398     else {
3399         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3400         SAVEFREESV(PL_compiling.cop_io);
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     I32 oldsaveix = PL_savestack_ix;
4140     I32 oldscopeix = PL_scopestack_ix;
4141     I32 result;
4142     GvSV(PL_firstgv) = a;
4143     GvSV(PL_secondgv) = b;
4144     PL_stack_sp = PL_stack_base;
4145     PL_op = PL_sortcop;
4146     CALLRUNOPS(aTHX);
4147     if (PL_stack_sp != PL_stack_base + 1)
4148         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4149     if (!SvNIOKp(*PL_stack_sp))
4150         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4151     result = SvIV(*PL_stack_sp);
4152     while (PL_scopestack_ix > oldscopeix) {
4153         LEAVE;
4154     }
4155     leave_scope(oldsaveix);
4156     return result;
4157 }
4158
4159 static I32
4160 sortcv_stacked(pTHXo_ SV *a, SV *b)
4161 {
4162     I32 oldsaveix = PL_savestack_ix;
4163     I32 oldscopeix = PL_scopestack_ix;
4164     I32 result;
4165     AV *av;
4166
4167 #ifdef USE_THREADS
4168     av = (AV*)PL_curpad[0];
4169 #else
4170     av = GvAV(PL_defgv);
4171 #endif
4172
4173     if (AvMAX(av) < 1) {
4174         SV** ary = AvALLOC(av);
4175         if (AvARRAY(av) != ary) {
4176             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4177             SvPVX(av) = (char*)ary;
4178         }
4179         if (AvMAX(av) < 1) {
4180             AvMAX(av) = 1;
4181             Renew(ary,2,SV*);
4182             SvPVX(av) = (char*)ary;
4183         }
4184     }
4185     AvFILLp(av) = 1;
4186
4187     AvARRAY(av)[0] = a;
4188     AvARRAY(av)[1] = b;
4189     PL_stack_sp = PL_stack_base;
4190     PL_op = PL_sortcop;
4191     CALLRUNOPS(aTHX);
4192     if (PL_stack_sp != PL_stack_base + 1)
4193         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4194     if (!SvNIOKp(*PL_stack_sp))
4195         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4196     result = SvIV(*PL_stack_sp);
4197     while (PL_scopestack_ix > oldscopeix) {
4198         LEAVE;
4199     }
4200     leave_scope(oldsaveix);
4201     return result;
4202 }
4203
4204 static I32
4205 sortcv_xsub(pTHXo_ SV *a, SV *b)
4206 {
4207     dSP;
4208     I32 oldsaveix = PL_savestack_ix;
4209     I32 oldscopeix = PL_scopestack_ix;
4210     I32 result;
4211     CV *cv=(CV*)PL_sortcop;
4212
4213     SP = PL_stack_base;
4214     PUSHMARK(SP);
4215     EXTEND(SP, 2);
4216     *++SP = a;
4217     *++SP = b;
4218     PUTBACK;
4219     (void)(*CvXSUB(cv))(aTHXo_ cv);
4220     if (PL_stack_sp != PL_stack_base + 1)
4221         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4222     if (!SvNIOKp(*PL_stack_sp))
4223         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4224     result = SvIV(*PL_stack_sp);
4225     while (PL_scopestack_ix > oldscopeix) {
4226         LEAVE;
4227     }
4228     leave_scope(oldsaveix);
4229     return result;
4230 }
4231
4232
4233 static I32
4234 sv_ncmp(pTHXo_ SV *a, SV *b)
4235 {
4236     NV nv1 = SvNV(a);
4237     NV nv2 = SvNV(b);
4238     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4239 }
4240
4241 static I32
4242 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4243 {
4244     IV iv1 = SvIV(a);
4245     IV iv2 = SvIV(b);
4246     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4247 }
4248 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4249           *svp = Nullsv;                                \
4250           if (PL_amagic_generation) { \
4251             if (SvAMAGIC(left)||SvAMAGIC(right))\
4252                 *svp = amagic_call(left, \
4253                                    right, \
4254                                    CAT2(meth,_amg), \
4255                                    0); \
4256           } \
4257         } STMT_END
4258
4259 static I32
4260 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4261 {
4262     SV *tmpsv;
4263     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4264     if (tmpsv) {
4265         NV d;
4266
4267         if (SvIOK(tmpsv)) {
4268             I32 i = SvIVX(tmpsv);
4269             if (i > 0)
4270                return 1;
4271             return i? -1 : 0;
4272         }
4273         d = SvNV(tmpsv);
4274         if (d > 0)
4275            return 1;
4276         return d? -1 : 0;
4277      }
4278      return sv_ncmp(aTHXo_ a, b);
4279 }
4280
4281 static I32
4282 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4283 {
4284     SV *tmpsv;
4285     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4286     if (tmpsv) {
4287         NV d;
4288
4289         if (SvIOK(tmpsv)) {
4290             I32 i = SvIVX(tmpsv);
4291             if (i > 0)
4292                return 1;
4293             return i? -1 : 0;
4294         }
4295         d = SvNV(tmpsv);
4296         if (d > 0)
4297            return 1;
4298         return d? -1 : 0;
4299     }
4300     return sv_i_ncmp(aTHXo_ a, b);
4301 }
4302
4303 static I32
4304 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4305 {
4306     SV *tmpsv;
4307     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4308     if (tmpsv) {
4309         NV d;
4310
4311         if (SvIOK(tmpsv)) {
4312             I32 i = SvIVX(tmpsv);
4313             if (i > 0)
4314                return 1;
4315             return i? -1 : 0;
4316         }
4317         d = SvNV(tmpsv);
4318         if (d > 0)
4319            return 1;
4320         return d? -1 : 0;
4321     }
4322     return sv_cmp(str1, str2);
4323 }
4324
4325 static I32
4326 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4327 {
4328     SV *tmpsv;
4329     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4330     if (tmpsv) {
4331         NV d;
4332
4333         if (SvIOK(tmpsv)) {
4334             I32 i = SvIVX(tmpsv);
4335             if (i > 0)
4336                return 1;
4337             return i? -1 : 0;
4338         }
4339         d = SvNV(tmpsv);
4340         if (d > 0)
4341            return 1;
4342         return d? -1 : 0;
4343     }
4344     return sv_cmp_locale(str1, str2);
4345 }
4346
4347 static I32
4348 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4349 {
4350     SV *datasv = FILTER_DATA(idx);
4351     int filter_has_file = IoLINES(datasv);
4352     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4353     SV *filter_state = (SV *)IoTOP_GV(datasv);
4354     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4355     int len = 0;
4356
4357     /* I was having segfault trouble under Linux 2.2.5 after a
4358        parse error occured.  (Had to hack around it with a test
4359        for PL_error_count == 0.)  Solaris doesn't segfault --
4360        not sure where the trouble is yet.  XXX */
4361
4362     if (filter_has_file) {
4363         len = FILTER_READ(idx+1, buf_sv, maxlen);
4364     }
4365
4366     if (filter_sub && len >= 0) {
4367         djSP;
4368         int count;
4369
4370         ENTER;
4371         SAVE_DEFSV;
4372         SAVETMPS;
4373         EXTEND(SP, 2);
4374
4375         DEFSV = buf_sv;
4376         PUSHMARK(SP);
4377         PUSHs(sv_2mortal(newSViv(maxlen)));
4378         if (filter_state) {
4379             PUSHs(filter_state);
4380         }
4381         PUTBACK;
4382         count = call_sv(filter_sub, G_SCALAR);
4383         SPAGAIN;
4384
4385         if (count > 0) {
4386             SV *out = POPs;
4387             if (SvOK(out)) {
4388                 len = SvIV(out);
4389             }
4390         }
4391
4392         PUTBACK;
4393         FREETMPS;
4394         LEAVE;
4395     }
4396
4397     if (len <= 0) {
4398         IoLINES(datasv) = 0;
4399         if (filter_child_proc) {
4400             SvREFCNT_dec(filter_child_proc);
4401             IoFMT_GV(datasv) = Nullgv;
4402         }
4403         if (filter_state) {
4404             SvREFCNT_dec(filter_state);
4405             IoTOP_GV(datasv) = Nullgv;
4406         }
4407         if (filter_sub) {
4408             SvREFCNT_dec(filter_sub);
4409             IoBOTTOM_GV(datasv) = Nullgv;
4410         }
4411         filter_del(run_user_filter);
4412     }
4413
4414     return len;
4415 }
4416
4417 #ifdef PERL_OBJECT
4418
4419 static I32
4420 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4421 {
4422     return sv_cmp_locale(str1, str2);
4423 }
4424
4425 static I32
4426 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4427 {
4428     return sv_cmp(str1, str2);
4429 }
4430
4431 #endif /* PERL_OBJECT */