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