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