pp_ctl.c

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