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