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->op_pmregexp);
  99         pm->op_pmregexp = ReREFCNT_inc(re);
 100     }
 101     else {
 102         t = SvPV(tmpstr, len);
 103
 104         /* Check against the last compiled regexp. */
 105         if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
 106             pm->op_pmregexp->prelen != len ||
 107             memNE(pm->op_pmregexp->precomp, t, len))
 108         {
 109             if (pm->op_pmregexp) {
 110                 ReREFCNT_dec(pm->op_pmregexp);
 111                 pm->op_pmregexp = Null(REGEXP*);        /* crucial if regcomp aborts */
 112             }
 113             if (PL_op->op_flags & OPf_SPECIAL)
 114                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 115
 116             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 117             if (DO_UTF8(tmpstr))
 118                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 119             else {
 120                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 121                 if (pm->op_pmdynflags & PMdf_UTF8)
 122                     t = (char*)bytes_to_utf8((U8*)t, &len);
 123             }
 124             pm->op_pmregexp = 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->op_pmregexp->prelen && PL_curpm)
 142         pm = PL_curpm;
 143     else if (strEQ("\\s+", pm->op_pmregexp->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 #ifdef USE_THREADS
2836     CvOWNER(PL_compcv) = 0;
2837     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2838     MUTEX_INIT(CvMUTEXP(PL_compcv));
2839 #endif /* USE_THREADS */
2840
2841     PL_comppad = newAV();
2842     av_push(PL_comppad, Nullsv);
2843     PL_curpad = AvARRAY(PL_comppad);
2844     PL_comppad_name = newAV();
2845     PL_comppad_name_fill = 0;
2846     PL_min_intro_pending = 0;
2847     PL_padix = 0;
2848 #ifdef USE_THREADS
2849     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2850     PL_curpad[0] = (SV*)newAV();
2851     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2852 #endif /* USE_THREADS */
2853
2854     comppadlist = newAV();
2855     AvREAL_off(comppadlist);
2856     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2857     av_store(comppadlist, 1, (SV*)PL_comppad);
2858     CvPADLIST(PL_compcv) = comppadlist;
2859
2860     if (!saveop ||
2861         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2862     {
2863         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2864     }
2865
2866     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2867
2868     /* make sure we compile in the right package */
2869
2870     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2871         SAVESPTR(PL_curstash);
2872         PL_curstash = CopSTASH(PL_curcop);
2873     }
2874     SAVESPTR(PL_beginav);
2875     PL_beginav = newAV();
2876     SAVEFREESV(PL_beginav);
2877     SAVEI32(PL_error_count);
2878
2879     /* try to compile it */
2880
2881     PL_eval_root = Nullop;
2882     PL_error_count = 0;
2883     PL_curcop = &PL_compiling;
2884     PL_curcop->cop_arybase = 0;
2885     SvREFCNT_dec(PL_rs);
2886     PL_rs = newSVpvn("\n", 1);
2887     if (saveop && saveop->op_flags & OPf_SPECIAL)
2888         PL_in_eval |= EVAL_KEEPERR;
2889     else
2890         sv_setpv(ERRSV,"");
2891     if (yyparse() || PL_error_count || !PL_eval_root) {
2892         SV **newsp;
2893         I32 gimme;
2894         PERL_CONTEXT *cx;
2895         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2896         STRLEN n_a;
2897
2898         PL_op = saveop;
2899         if (PL_eval_root) {
2900             op_free(PL_eval_root);
2901             PL_eval_root = Nullop;
2902         }
2903         SP = PL_stack_base + POPMARK;           /* pop original mark */
2904         if (!startop) {
2905             POPBLOCK(cx,PL_curpm);
2906             POPEVAL(cx);
2907             pop_return();
2908         }
2909         lex_end();
2910         LEAVE;
2911         if (optype == OP_REQUIRE) {
2912             char* msg = SvPVx(ERRSV, n_a);
2913             DIE(aTHX_ "%sCompilation failed in require",
2914                 *msg ? msg : "Unknown error\n");
2915         }
2916         else if (startop) {
2917             char* msg = SvPVx(ERRSV, n_a);
2918
2919             POPBLOCK(cx,PL_curpm);
2920             POPEVAL(cx);
2921             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2922                        (*msg ? msg : "Unknown error\n"));
2923         }
2924         SvREFCNT_dec(PL_rs);
2925         PL_rs = SvREFCNT_inc(PL_nrs);
2926 #ifdef USE_THREADS
2927         MUTEX_LOCK(&PL_eval_mutex);
2928         PL_eval_owner = 0;
2929         COND_SIGNAL(&PL_eval_cond);
2930         MUTEX_UNLOCK(&PL_eval_mutex);
2931 #endif /* USE_THREADS */
2932         RETPUSHUNDEF;
2933     }
2934     SvREFCNT_dec(PL_rs);
2935     PL_rs = SvREFCNT_inc(PL_nrs);
2936     CopLINE_set(&PL_compiling, 0);
2937     if (startop) {
2938         *startop = PL_eval_root;
2939         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2940         CvOUTSIDE(PL_compcv) = Nullcv;
2941     } else
2942         SAVEFREEOP(PL_eval_root);
2943     if (gimme & G_VOID)
2944         scalarvoid(PL_eval_root);
2945     else if (gimme & G_ARRAY)
2946         list(PL_eval_root);
2947     else
2948         scalar(PL_eval_root);
2949
2950     DEBUG_x(dump_eval());
2951
2952     /* Register with debugger: */
2953     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2954         CV *cv = get_cv("DB::postponed", FALSE);
2955         if (cv) {
2956             dSP;
2957             PUSHMARK(SP);
2958             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2959             PUTBACK;
2960             call_sv((SV*)cv, G_DISCARD);
2961         }
2962     }
2963
2964     /* compiled okay, so do it */
2965
2966     CvDEPTH(PL_compcv) = 1;
2967     SP = PL_stack_base + POPMARK;               /* pop original mark */
2968     PL_op = saveop;                     /* The caller may need it. */
2969     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2970 #ifdef USE_THREADS
2971     MUTEX_LOCK(&PL_eval_mutex);
2972     PL_eval_owner = 0;
2973     COND_SIGNAL(&PL_eval_cond);
2974     MUTEX_UNLOCK(&PL_eval_mutex);
2975 #endif /* USE_THREADS */
2976
2977     RETURNOP(PL_eval_start);
2978 }
2979
2980 STATIC PerlIO *
2981 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2982 {
2983     STRLEN namelen = strlen(name);
2984     PerlIO *fp;
2985
2986     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2987         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2988         char *pmc = SvPV_nolen(pmcsv);
2989         Stat_t pmstat;
2990         Stat_t pmcstat;
2991         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2992             fp = PerlIO_open(name, mode);
2993         }
2994         else {
2995             if (PerlLIO_stat(name, &pmstat) < 0 ||
2996                 pmstat.st_mtime < pmcstat.st_mtime)
2997             {
2998                 fp = PerlIO_open(pmc, mode);
2999             }
3000             else {
3001                 fp = PerlIO_open(name, mode);
3002             }
3003         }
3004         SvREFCNT_dec(pmcsv);
3005     }
3006     else {
3007         fp = PerlIO_open(name, mode);
3008     }
3009     return fp;
3010 }
3011
3012 PP(pp_require)
3013 {
3014     dSP;
3015     register PERL_CONTEXT *cx;
3016     SV *sv;
3017     char *name;
3018     STRLEN len;
3019     char *tryname = Nullch;
3020     SV *namesv = Nullsv;
3021     SV** svp;
3022     I32 gimme = GIMME_V;
3023     PerlIO *tryrsfp = 0;
3024     STRLEN n_a;
3025     int filter_has_file = 0;
3026     GV *filter_child_proc = 0;
3027     SV *filter_state = 0;
3028     SV *filter_sub = 0;
3029
3030     sv = POPs;
3031     if (SvNIOKp(sv)) {
3032         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
3033             UV rev = 0, ver = 0, sver = 0;
3034             STRLEN len;
3035             U8 *s = (U8*)SvPVX(sv);
3036             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3037             if (s < end) {
3038                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3039                 s += len;
3040                 if (s < end) {
3041                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3042                     s += len;
3043                     if (s < end)
3044                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3045                 }
3046             }
3047             if (PERL_REVISION < rev
3048                 || (PERL_REVISION == rev
3049                     && (PERL_VERSION < ver
3050                         || (PERL_VERSION == ver
3051                             && PERL_SUBVERSION < sver))))
3052             {
3053                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3054                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3055                     PERL_VERSION, PERL_SUBVERSION);
3056             }
3057             RETPUSHYES;
3058         }
3059         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3060             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3061                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3062                 + 0.00000099 < SvNV(sv))
3063             {
3064                 NV nrev = SvNV(sv);
3065                 UV rev = (UV)nrev;
3066                 NV nver = (nrev - rev) * 1000;
3067                 UV ver = (UV)(nver + 0.0009);
3068                 NV nsver = (nver - ver) * 1000;
3069                 UV sver = (UV)(nsver + 0.0009);
3070
3071                 /* help out with the "use 5.6" confusion */
3072                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3073                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3074                         "this is only v%d.%d.%d, stopped"
3075                         " (did you mean v%"UVuf".%"UVuf".0?)",
3076                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3077                         PERL_SUBVERSION, rev, ver/100);
3078                 }
3079                 else {
3080                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3081                         "this is only v%d.%d.%d, stopped",
3082                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3083                         PERL_SUBVERSION);
3084                 }
3085             }
3086             RETPUSHYES;
3087         }
3088     }
3089     name = SvPV(sv, len);
3090     if (!(name && len > 0 && *name))
3091         DIE(aTHX_ "Null filename used");
3092     TAINT_PROPER("require");
3093     if (PL_op->op_type == OP_REQUIRE &&
3094       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3095       *svp != &PL_sv_undef)
3096         RETPUSHYES;
3097
3098     /* prepare to compile file */
3099
3100 #ifdef MACOS_TRADITIONAL
3101     if (PERL_FILE_IS_ABSOLUTE(name)
3102         || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3103     {
3104         tryname = name;
3105         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3106         /* We consider paths of the form :a:b ambiguous and interpret them first
3107            as global then as local
3108         */
3109         if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3110             goto trylocal;
3111     }
3112     else
3113 trylocal: {
3114 #else
3115     if (PERL_FILE_IS_ABSOLUTE(name)
3116         || (*name == '.' && (name[1] == '/' ||
3117                              (name[1] == '.' && name[2] == '/'))))
3118     {
3119         tryname = name;
3120         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3121     }
3122     else {
3123 #endif
3124         AV *ar = GvAVn(PL_incgv);
3125         I32 i;
3126 #ifdef VMS
3127         char *unixname;
3128         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3129 #endif
3130         {
3131             namesv = NEWSV(806, 0);
3132             for (i = 0; i <= AvFILL(ar); i++) {
3133                 SV *dirsv = *av_fetch(ar, i, TRUE);
3134
3135                 if (SvROK(dirsv)) {
3136                     int count;
3137                     SV *loader = dirsv;
3138
3139                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3140                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3141                     }
3142
3143                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3144                                    PTR2UV(SvANY(loader)), name);
3145                     tryname = SvPVX(namesv);
3146                     tryrsfp = 0;
3147
3148                     ENTER;
3149                     SAVETMPS;
3150                     EXTEND(SP, 2);
3151
3152                     PUSHMARK(SP);
3153                     PUSHs(dirsv);
3154                     PUSHs(sv);
3155                     PUTBACK;
3156                     if (sv_isobject(loader))
3157                         count = call_method("INC", G_ARRAY);
3158                     else
3159                         count = call_sv(loader, G_ARRAY);
3160                     SPAGAIN;
3161
3162                     if (count > 0) {
3163                         int i = 0;
3164                         SV *arg;
3165
3166                         SP -= count - 1;
3167                         arg = SP[i++];
3168
3169                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3170                             arg = SvRV(arg);
3171                         }
3172
3173                         if (SvTYPE(arg) == SVt_PVGV) {
3174                             IO *io = GvIO((GV *)arg);
3175
3176                             ++filter_has_file;
3177
3178                             if (io) {
3179                                 tryrsfp = IoIFP(io);
3180                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3181                                     /* reading from a child process doesn't
3182                                        nest -- when returning from reading
3183                                        the inner module, the outer one is
3184                                        unreadable (closed?)  I've tried to
3185                                        save the gv to manage the lifespan of
3186                                        the pipe, but this didn't help. XXX */
3187                                     filter_child_proc = (GV *)arg;
3188                                     (void)SvREFCNT_inc(filter_child_proc);
3189                                 }
3190                                 else {
3191                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3192                                         PerlIO_close(IoOFP(io));
3193                                     }
3194                                     IoIFP(io) = Nullfp;
3195                                     IoOFP(io) = Nullfp;
3196                                 }
3197                             }
3198
3199                             if (i < count) {
3200                                 arg = SP[i++];
3201                             }
3202                         }
3203
3204                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3205                             filter_sub = arg;
3206                             (void)SvREFCNT_inc(filter_sub);
3207
3208                             if (i < count) {
3209                                 filter_state = SP[i];
3210                                 (void)SvREFCNT_inc(filter_state);
3211                             }
3212
3213                             if (tryrsfp == 0) {
3214                                 tryrsfp = PerlIO_open("/dev/null",
3215                                                       PERL_SCRIPT_MODE);
3216                             }
3217                         }
3218                     }
3219
3220                     PUTBACK;
3221                     FREETMPS;
3222                     LEAVE;
3223
3224                     if (tryrsfp) {
3225                         break;
3226                     }
3227
3228                     filter_has_file = 0;
3229                     if (filter_child_proc) {
3230                         SvREFCNT_dec(filter_child_proc);
3231                         filter_child_proc = 0;
3232                     }
3233                     if (filter_state) {
3234                         SvREFCNT_dec(filter_state);
3235                         filter_state = 0;
3236                     }
3237                     if (filter_sub) {
3238                         SvREFCNT_dec(filter_sub);
3239                         filter_sub = 0;
3240                     }
3241                 }
3242                 else {
3243                     char *dir = SvPVx(dirsv, n_a);
3244 #ifdef MACOS_TRADITIONAL
3245                     char buf[256];
3246                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3247 #else
3248 #ifdef VMS
3249                     char *unixdir;
3250                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3251                         continue;
3252                     sv_setpv(namesv, unixdir);
3253                     sv_catpv(namesv, unixname);
3254 #else
3255                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3256 #endif
3257 #endif
3258                     TAINT_PROPER("require");
3259                     tryname = SvPVX(namesv);
3260 #ifdef MACOS_TRADITIONAL
3261                     {
3262                         /* Convert slashes in the name part, but not the directory part, to colons */
3263                         char * colon;
3264                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3265                             *colon++ = ':';
3266                     }
3267 #endif
3268                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3269                     if (tryrsfp) {
3270                         if (tryname[0] == '.' && tryname[1] == '/')
3271                             tryname += 2;
3272                         break;
3273                     }
3274                 }
3275             }
3276         }
3277     }
3278     SAVECOPFILE_FREE(&PL_compiling);
3279     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3280     SvREFCNT_dec(namesv);
3281     if (!tryrsfp) {
3282         if (PL_op->op_type == OP_REQUIRE) {
3283             char *msgstr = name;
3284             if (namesv) {                       /* did we lookup @INC? */
3285                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3286                 SV *dirmsgsv = NEWSV(0, 0);
3287                 AV *ar = GvAVn(PL_incgv);
3288                 I32 i;
3289                 sv_catpvn(msg, " in @INC", 8);
3290                 if (instr(SvPVX(msg), ".h "))
3291                     sv_catpv(msg, " (change .h to .ph maybe?)");
3292                 if (instr(SvPVX(msg), ".ph "))
3293                     sv_catpv(msg, " (did you run h2ph?)");
3294                 sv_catpv(msg, " (@INC contains:");
3295                 for (i = 0; i <= AvFILL(ar); i++) {
3296                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3297                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3298                     sv_catsv(msg, dirmsgsv);
3299                 }
3300                 sv_catpvn(msg, ")", 1);
3301                 SvREFCNT_dec(dirmsgsv);
3302                 msgstr = SvPV_nolen(msg);
3303             }
3304             DIE(aTHX_ "Can't locate %s", msgstr);
3305         }
3306
3307         RETPUSHUNDEF;
3308     }
3309     else
3310         SETERRNO(0, SS$_NORMAL);
3311
3312     /* Assume success here to prevent recursive requirement. */
3313     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3314                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3315
3316     ENTER;
3317     SAVETMPS;
3318     lex_start(sv_2mortal(newSVpvn("",0)));
3319     SAVEGENERICSV(PL_rsfp_filters);
3320     PL_rsfp_filters = Nullav;
3321
3322     PL_rsfp = tryrsfp;
3323     SAVEHINTS();
3324     PL_hints = 0;
3325     SAVESPTR(PL_compiling.cop_warnings);
3326     if (PL_dowarn & G_WARN_ALL_ON)
3327         PL_compiling.cop_warnings = pWARN_ALL ;
3328     else if (PL_dowarn & G_WARN_ALL_OFF)
3329         PL_compiling.cop_warnings = pWARN_NONE ;
3330     else
3331         PL_compiling.cop_warnings = pWARN_STD ;
3332     SAVESPTR(PL_compiling.cop_io);
3333     PL_compiling.cop_io = Nullsv;
3334
3335     if (filter_sub || filter_child_proc) {
3336         SV *datasv = filter_add(run_user_filter, Nullsv);
3337         IoLINES(datasv) = filter_has_file;
3338         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3339         IoTOP_GV(datasv) = (GV *)filter_state;
3340         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3341     }
3342
3343     /* switch to eval mode */
3344     push_return(PL_op->op_next);
3345     PUSHBLOCK(cx, CXt_EVAL, SP);
3346     PUSHEVAL(cx, name, Nullgv);
3347
3348     SAVECOPLINE(&PL_compiling);
3349     CopLINE_set(&PL_compiling, 0);
3350
3351     PUTBACK;
3352 #ifdef USE_THREADS
3353     MUTEX_LOCK(&PL_eval_mutex);
3354     if (PL_eval_owner && PL_eval_owner != thr)
3355         while (PL_eval_owner)
3356             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3357     PL_eval_owner = thr;
3358     MUTEX_UNLOCK(&PL_eval_mutex);
3359 #endif /* USE_THREADS */
3360     return DOCATCH(doeval(gimme, NULL));
3361 }
3362
3363 PP(pp_dofile)
3364 {
3365     return pp_require();
3366 }
3367
3368 PP(pp_entereval)
3369 {
3370     dSP;
3371     register PERL_CONTEXT *cx;
3372     dPOPss;
3373     I32 gimme = GIMME_V, was = PL_sub_generation;
3374     char tbuf[TYPE_DIGITS(long) + 12];
3375     char *tmpbuf = tbuf;
3376     char *safestr;
3377     STRLEN len;
3378     OP *ret;
3379
3380     if (!SvPV(sv,len) || !len)
3381         RETPUSHUNDEF;
3382     TAINT_PROPER("eval");
3383
3384     ENTER;
3385     lex_start(sv);
3386     SAVETMPS;
3387
3388     /* switch to eval mode */
3389
3390     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3391         SV *sv = sv_newmortal();
3392         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3393                        (unsigned long)++PL_evalseq,
3394                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3395         tmpbuf = SvPVX(sv);
3396     }
3397     else
3398         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3399     SAVECOPFILE_FREE(&PL_compiling);
3400     CopFILE_set(&PL_compiling, tmpbuf+2);
3401     SAVECOPLINE(&PL_compiling);
3402     CopLINE_set(&PL_compiling, 1);
3403     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3404        deleting the eval's FILEGV from the stash before gv_check() runs
3405        (i.e. before run-time proper). To work around the coredump that
3406        ensues, we always turn GvMULTI_on for any globals that were
3407        introduced within evals. See force_ident(). GSAR 96-10-12 */
3408     safestr = savepv(tmpbuf);
3409     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3410     SAVEHINTS();
3411     PL_hints = PL_op->op_targ;
3412     SAVESPTR(PL_compiling.cop_warnings);
3413     if (specialWARN(PL_curcop->cop_warnings))
3414         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3415     else {
3416         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3417         SAVEFREESV(PL_compiling.cop_warnings);
3418     }
3419     SAVESPTR(PL_compiling.cop_io);
3420     if (specialCopIO(PL_curcop->cop_io))
3421         PL_compiling.cop_io = PL_curcop->cop_io;
3422     else {
3423         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3424         SAVEFREESV(PL_compiling.cop_io);
3425     }
3426
3427     push_return(PL_op->op_next);
3428     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3429     PUSHEVAL(cx, 0, Nullgv);
3430
3431     /* prepare to compile string */
3432
3433     if (PERLDB_LINE && PL_curstash != PL_debstash)
3434         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3435     PUTBACK;
3436 #ifdef USE_THREADS
3437     MUTEX_LOCK(&PL_eval_mutex);
3438     if (PL_eval_owner && PL_eval_owner != thr)
3439         while (PL_eval_owner)
3440             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3441     PL_eval_owner = thr;
3442     MUTEX_UNLOCK(&PL_eval_mutex);
3443 #endif /* USE_THREADS */
3444     ret = doeval(gimme, NULL);
3445     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3446         && ret != PL_op->op_next) {     /* Successive compilation. */
3447         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3448     }
3449     return DOCATCH(ret);
3450 }
3451
3452 PP(pp_leaveeval)
3453 {
3454     dSP;
3455     register SV **mark;
3456     SV **newsp;
3457     PMOP *newpm;
3458     I32 gimme;
3459     register PERL_CONTEXT *cx;
3460     OP *retop;
3461     U8 save_flags = PL_op -> op_flags;
3462     I32 optype;
3463
3464     POPBLOCK(cx,newpm);
3465     POPEVAL(cx);
3466     retop = pop_return();
3467
3468     TAINT_NOT;
3469     if (gimme == G_VOID)
3470         MARK = newsp;
3471     else if (gimme == G_SCALAR) {
3472         MARK = newsp + 1;
3473         if (MARK <= SP) {
3474             if (SvFLAGS(TOPs) & SVs_TEMP)
3475                 *MARK = TOPs;
3476             else
3477                 *MARK = sv_mortalcopy(TOPs);
3478         }
3479         else {
3480             MEXTEND(mark,0);
3481             *MARK = &PL_sv_undef;
3482         }
3483         SP = MARK;
3484     }
3485     else {
3486         /* in case LEAVE wipes old return values */
3487         for (mark = newsp + 1; mark <= SP; mark++) {
3488             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3489                 *mark = sv_mortalcopy(*mark);
3490                 TAINT_NOT;      /* Each item is independent */
3491             }
3492         }
3493     }
3494     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3495
3496 #ifdef DEBUGGING
3497     assert(CvDEPTH(PL_compcv) == 1);
3498 #endif
3499     CvDEPTH(PL_compcv) = 0;
3500     lex_end();
3501
3502     if (optype == OP_REQUIRE &&
3503         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3504     {
3505         /* Unassume the success we assumed earlier. */
3506         SV *nsv = cx->blk_eval.old_namesv;
3507         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3508         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3509         /* die_where() did LEAVE, or we won't be here */
3510     }
3511     else {
3512         LEAVE;
3513         if (!(save_flags & OPf_SPECIAL))
3514             sv_setpv(ERRSV,"");
3515     }
3516
3517     RETURNOP(retop);
3518 }
3519
3520 PP(pp_entertry)
3521 {
3522     dSP;
3523     register PERL_CONTEXT *cx;
3524     I32 gimme = GIMME_V;
3525
3526     ENTER;
3527     SAVETMPS;
3528
3529     push_return(cLOGOP->op_other->op_next);
3530     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3531     PUSHEVAL(cx, 0, 0);
3532
3533     PL_in_eval = EVAL_INEVAL;
3534     sv_setpv(ERRSV,"");
3535     PUTBACK;
3536     return DOCATCH(PL_op->op_next);
3537 }
3538
3539 PP(pp_leavetry)
3540 {
3541     dSP;
3542     register SV **mark;
3543     SV **newsp;
3544     PMOP *newpm;
3545     I32 gimme;
3546     register PERL_CONTEXT *cx;
3547     I32 optype;
3548
3549     POPBLOCK(cx,newpm);
3550     POPEVAL(cx);
3551     pop_return();
3552
3553     TAINT_NOT;
3554     if (gimme == G_VOID)
3555         SP = newsp;
3556     else if (gimme == G_SCALAR) {
3557         MARK = newsp + 1;
3558         if (MARK <= SP) {
3559             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3560                 *MARK = TOPs;
3561             else
3562                 *MARK = sv_mortalcopy(TOPs);
3563         }
3564         else {
3565             MEXTEND(mark,0);
3566             *MARK = &PL_sv_undef;
3567         }
3568         SP = MARK;
3569     }
3570     else {
3571         /* in case LEAVE wipes old return values */
3572         for (mark = newsp + 1; mark <= SP; mark++) {
3573             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3574                 *mark = sv_mortalcopy(*mark);
3575                 TAINT_NOT;      /* Each item is independent */
3576             }
3577         }
3578     }
3579     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3580
3581     LEAVE;
3582     sv_setpv(ERRSV,"");
3583     RETURN;
3584 }
3585
3586 STATIC void
3587 S_doparseform(pTHX_ SV *sv)
3588 {
3589     STRLEN len;
3590     register char *s = SvPV_force(sv, len);
3591     register char *send = s + len;
3592     register char *base = Nullch;
3593     register I32 skipspaces = 0;
3594     bool noblank   = FALSE;
3595     bool repeat    = FALSE;
3596     bool postspace = FALSE;
3597     U16 *fops;
3598     register U16 *fpc;
3599     U16 *linepc = 0;
3600     register I32 arg;
3601     bool ischop;
3602
3603     if (len == 0)
3604         Perl_croak(aTHX_ "Null picture in formline");
3605
3606     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3607     fpc = fops;
3608
3609     if (s < send) {
3610         linepc = fpc;
3611         *fpc++ = FF_LINEMARK;
3612         noblank = repeat = FALSE;
3613         base = s;
3614     }
3615
3616     while (s <= send) {
3617         switch (*s++) {
3618         default:
3619             skipspaces = 0;
3620             continue;
3621
3622         case '~':
3623             if (*s == '~') {
3624                 repeat = TRUE;
3625                 *s = ' ';
3626             }
3627             noblank = TRUE;
3628             s[-1] = ' ';
3629             /* FALL THROUGH */
3630         case ' ': case '\t':
3631             skipspaces++;
3632             continue;
3633
3634         case '\n': case 0:
3635             arg = s - base;
3636             skipspaces++;
3637             arg -= skipspaces;
3638             if (arg) {
3639                 if (postspace)
3640                     *fpc++ = FF_SPACE;
3641                 *fpc++ = FF_LITERAL;
3642                 *fpc++ = arg;
3643             }
3644             postspace = FALSE;
3645             if (s <= send)
3646                 skipspaces--;
3647             if (skipspaces) {
3648                 *fpc++ = FF_SKIP;
3649                 *fpc++ = skipspaces;
3650             }
3651             skipspaces = 0;
3652             if (s <= send)
3653                 *fpc++ = FF_NEWLINE;
3654             if (noblank) {
3655                 *fpc++ = FF_BLANK;
3656                 if (repeat)
3657                     arg = fpc - linepc + 1;
3658                 else
3659                     arg = 0;
3660                 *fpc++ = arg;
3661             }
3662             if (s < send) {
3663                 linepc = fpc;
3664                 *fpc++ = FF_LINEMARK;
3665                 noblank = repeat = FALSE;
3666                 base = s;
3667             }
3668             else
3669                 s++;
3670             continue;
3671
3672         case '@':
3673         case '^':
3674             ischop = s[-1] == '^';
3675
3676             if (postspace) {
3677                 *fpc++ = FF_SPACE;
3678                 postspace = FALSE;
3679             }
3680             arg = (s - base) - 1;
3681             if (arg) {
3682                 *fpc++ = FF_LITERAL;
3683                 *fpc++ = arg;
3684             }
3685
3686             base = s - 1;
3687             *fpc++ = FF_FETCH;
3688             if (*s == '*') {
3689                 s++;
3690                 *fpc++ = 0;
3691                 *fpc++ = FF_LINEGLOB;
3692             }
3693             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3694                 arg = ischop ? 512 : 0;
3695                 base = s - 1;
3696                 while (*s == '#')
3697                     s++;
3698                 if (*s == '.') {
3699                     char *f;
3700                     s++;
3701                     f = s;
3702                     while (*s == '#')
3703                         s++;
3704                     arg |= 256 + (s - f);
3705                 }
3706                 *fpc++ = s - base;              /* fieldsize for FETCH */
3707                 *fpc++ = FF_DECIMAL;
3708                 *fpc++ = arg;
3709             }
3710             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3711                 arg = ischop ? 512 : 0;
3712                 base = s - 1;
3713                 s++;                                /* skip the '0' first */
3714                 while (*s == '#')
3715                     s++;
3716                 if (*s == '.') {
3717                     char *f;
3718                     s++;
3719                     f = s;
3720                     while (*s == '#')
3721                         s++;
3722                     arg |= 256 + (s - f);
3723                 }
3724                 *fpc++ = s - base;                /* fieldsize for FETCH */
3725                 *fpc++ = FF_0DECIMAL;
3726                 *fpc++ = arg;
3727             }
3728             else {
3729                 I32 prespace = 0;
3730                 bool ismore = FALSE;
3731
3732                 if (*s == '>') {
3733                     while (*++s == '>') ;
3734                     prespace = FF_SPACE;
3735                 }
3736                 else if (*s == '|') {
3737                     while (*++s == '|') ;
3738                     prespace = FF_HALFSPACE;
3739                     postspace = TRUE;
3740                 }
3741                 else {
3742                     if (*s == '<')
3743                         while (*++s == '<') ;
3744                     postspace = TRUE;
3745                 }
3746                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3747                     s += 3;
3748                     ismore = TRUE;
3749                 }
3750                 *fpc++ = s - base;              /* fieldsize for FETCH */
3751
3752                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3753
3754                 if (prespace)
3755                     *fpc++ = prespace;
3756                 *fpc++ = FF_ITEM;
3757                 if (ismore)
3758                     *fpc++ = FF_MORE;
3759                 if (ischop)
3760                     *fpc++ = FF_CHOP;
3761             }
3762             base = s;
3763             skipspaces = 0;
3764             continue;
3765         }
3766     }
3767     *fpc++ = FF_END;
3768
3769     arg = fpc - fops;
3770     { /* need to jump to the next word */
3771         int z;
3772         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3773         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3774         s = SvPVX(sv) + SvCUR(sv) + z;
3775     }
3776     Copy(fops, s, arg, U16);
3777     Safefree(fops);
3778     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3779     SvCOMPILED_on(sv);
3780 }
3781
3782 /*
3783  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3784  *
3785  * The original code was written in conjunction with BSD Computer Software
3786  * Research Group at University of California, Berkeley.
3787  *
3788  * See also: "Optimistic Merge Sort" (SODA '92)
3789  *
3790  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3791  *
3792  * The code can be distributed under the same terms as Perl itself.
3793  *
3794  */
3795
3796 #ifdef  TESTHARNESS
3797 #include <sys/types.h>
3798 typedef void SV;
3799 #define pTHXo_
3800 #define pTHX_
3801 #define STATIC
3802 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3803 #define Safefree(VAR) free(VAR)
3804 typedef int  (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3805 #endif  /* TESTHARNESS */
3806
3807 typedef char * aptr;            /* pointer for arithmetic on sizes */
3808 typedef SV * gptr;              /* pointers in our lists */
3809
3810 /* Binary merge internal sort, with a few special mods
3811 ** for the special perl environment it now finds itself in.
3812 **
3813 ** Things that were once options have been hotwired
3814 ** to values suitable for this use.  In particular, we'll always
3815 ** initialize looking for natural runs, we'll always produce stable
3816 ** output, and we'll always do Peter McIlroy's binary merge.
3817 */
3818
3819 /* Pointer types for arithmetic and storage and convenience casts */
3820
3821 #define APTR(P) ((aptr)(P))
3822 #define GPTP(P) ((gptr *)(P))
3823 #define GPPP(P) ((gptr **)(P))
3824
3825
3826 /* byte offset from pointer P to (larger) pointer Q */
3827 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3828
3829 #define PSIZE sizeof(gptr)
3830
3831 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3832
3833 #ifdef  PSHIFT
3834 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
3835 #define PNBYTE(N)       ((N) << (PSHIFT))
3836 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
3837 #else
3838 /* Leave optimization to compiler */
3839 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
3840 #define PNBYTE(N)       ((N) * (PSIZE))
3841 #define PINDEX(P, N)    (GPTP(P) + (N))
3842 #endif
3843
3844 /* Pointer into other corresponding to pointer into this */
3845 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3846
3847 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3848
3849
3850 /* Runs are identified by a pointer in the auxilliary list.
3851 ** The pointer is at the start of the list,
3852 ** and it points to the start of the next list.
3853 ** NEXT is used as an lvalue, too.
3854 */
3855
3856 #define NEXT(P)         (*GPPP(P))
3857
3858
3859 /* PTHRESH is the minimum number of pairs with the same sense to justify
3860 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
3861 ** not just elements, so PTHRESH == 8 means a run of 16.
3862 */
3863
3864 #define PTHRESH (8)
3865
3866 /* RTHRESH is the number of elements in a run that must compare low
3867 ** to the low element from the opposing run before we justify
3868 ** doing a binary rampup instead of single stepping.
3869 ** In random input, N in a row low should only happen with
3870 ** probability 2^(1-N), so we can risk that we are dealing
3871 ** with orderly input without paying much when we aren't.
3872 */
3873
3874 #define RTHRESH (6)
3875
3876
3877 /*
3878 ** Overview of algorithm and variables.
3879 ** The array of elements at list1 will be organized into runs of length 2,
3880 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
3881 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3882 **
3883 ** Unless otherwise specified, pair pointers address the first of two elements.
3884 **
3885 ** b and b+1 are a pair that compare with sense ``sense''.
3886 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3887 **
3888 ** p2 parallels b in the list2 array, where runs are defined by
3889 ** a pointer chain.
3890 **
3891 ** t represents the ``top'' of the adjacent pairs that might extend
3892 ** the run beginning at b.  Usually, t addresses a pair
3893 ** that compares with opposite sense from (b,b+1).
3894 ** However, it may also address a singleton element at the end of list1,
3895 ** or it may be equal to ``last'', the first element beyond list1.
3896 **
3897 ** r addresses the Nth pair following b.  If this would be beyond t,
3898 ** we back it off to t.  Only when r is less than t do we consider the
3899 ** run long enough to consider checking.
3900 **
3901 ** q addresses a pair such that the pairs at b through q already form a run.
3902 ** Often, q will equal b, indicating we only are sure of the pair itself.
3903 ** However, a search on the previous cycle may have revealed a longer run,
3904 ** so q may be greater than b.
3905 **
3906 ** p is used to work back from a candidate r, trying to reach q,
3907 ** which would mean b through r would be a run.  If we discover such a run,
3908 ** we start q at r and try to push it further towards t.
3909 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3910 ** In any event, after the check (if any), we have two main cases.
3911 **
3912 ** 1) Short run.  b <= q < p <= r <= t.
3913 **      b through q is a run (perhaps trivial)
3914 **      q through p are uninteresting pairs
3915 **      p through r is a run
3916 **
3917 ** 2) Long run.  b < r <= q < t.
3918 **      b through q is a run (of length >= 2 * PTHRESH)
3919 **
3920 ** Note that degenerate cases are not only possible, but likely.
3921 ** For example, if the pair following b compares with opposite sense,
3922 ** then b == q < p == r == t.
3923 */
3924
3925
3926 static void
3927 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3928 {
3929     int sense;
3930     register gptr *b, *p, *q, *t, *p2;
3931     register gptr c, *last, *r;
3932     gptr *savep;
3933
3934     b = list1;
3935     last = PINDEX(b, nmemb);
3936     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3937     for (p2 = list2; b < last; ) {
3938         /* We just started, or just reversed sense.
3939         ** Set t at end of pairs with the prevailing sense.
3940         */
3941         for (p = b+2, t = p; ++p < last; t = ++p) {
3942             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3943         }
3944         q = b;
3945         /* Having laid out the playing field, look for long runs */
3946         do {
3947             p = r = b + (2 * PTHRESH);
3948             if (r >= t) p = r = t;      /* too short to care about */
3949             else {
3950                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3951                        ((p -= 2) > q));
3952                 if (p <= q) {
3953                     /* b through r is a (long) run.
3954                     ** Extend it as far as possible.
3955                     */
3956                     p = q = r;
3957                     while (((p += 2) < t) &&
3958                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3959                     r = p = q + 2;      /* no simple pairs, no after-run */
3960                 }
3961             }
3962             if (q > b) {                /* run of greater than 2 at b */
3963                 savep = p;
3964                 p = q += 2;
3965                 /* pick up singleton, if possible */
3966                 if ((p == t) &&
3967                     ((t + 1) == last) &&
3968                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3969                     savep = r = p = q = last;
3970                 p2 = NEXT(p2) = p2 + (p - b);
3971                 if (sense) while (b < --p) {
3972                     c = *b;
3973                     *b++ = *p;
3974                     *p = c;
3975                 }
3976                 p = savep;
3977             }
3978             while (q < p) {             /* simple pairs */
3979                 p2 = NEXT(p2) = p2 + 2;
3980                 if (sense) {
3981                     c = *q++;
3982                     *(q-1) = *q;
3983                     *q++ = c;
3984                 } else q += 2;
3985             }
3986             if (((b = p) == t) && ((t+1) == last)) {
3987                 NEXT(p2) = p2 + 1;
3988                 b++;
3989             }
3990             q = r;
3991         } while (b < t);
3992         sense = !sense;
3993     }
3994     return;
3995 }
3996
3997
3998 /* Overview of bmerge variables:
3999 **
4000 ** list1 and list2 address the main and auxiliary arrays.
4001 ** They swap identities after each merge pass.
4002 ** Base points to the original list1, so we can tell if
4003 ** the pointers ended up where they belonged (or must be copied).
4004 **
4005 ** When we are merging two lists, f1 and f2 are the next elements
4006 ** on the respective lists.  l1 and l2 mark the end of the lists.
4007 ** tp2 is the current location in the merged list.
4008 **
4009 ** p1 records where f1 started.
4010 ** After the merge, a new descriptor is built there.
4011 **
4012 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4013 ** It is used to identify and delimit the runs.
4014 **
4015 ** In the heat of determining where q, the greater of the f1/f2 elements,
4016 ** belongs in the other list, b, t and p, represent bottom, top and probe
4017 ** locations, respectively, in the other list.
4018 ** They make convenient temporary pointers in other places.
4019 */
4020
4021 STATIC void
4022 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4023 {
4024     int i, run;
4025     int sense;
4026     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4027     gptr *aux, *list2, *p2, *last;
4028     gptr *base = list1;
4029     gptr *p1;
4030
4031     if (nmemb <= 1) return;     /* sorted trivially */
4032     New(799,list2,nmemb,gptr);  /* allocate auxilliary array */
4033     aux = list2;
4034     dynprep(aTHX_ list1, list2, nmemb, cmp);
4035     last = PINDEX(list2, nmemb);
4036     while (NEXT(list2) != last) {
4037         /* More than one run remains.  Do some merging to reduce runs. */
4038         l2 = p1 = list1;
4039         for (tp2 = p2 = list2; p2 != last;) {
4040             /* The new first run begins where the old second list ended.
4041             ** Use the p2 ``parallel'' pointer to identify the end of the run.
4042             */
4043             f1 = l2;
4044             t = NEXT(p2);
4045             f2 = l1 = POTHER(t, list2, list1);
4046             if (t != last) t = NEXT(t);
4047             l2 = POTHER(t, list2, list1);
4048             p2 = t;
4049             while (f1 < l1 && f2 < l2) {
4050                 /* If head 1 is larger than head 2, find ALL the elements
4051                 ** in list 2 strictly less than head1, write them all,
4052                 ** then head 1.  Then compare the new heads, and repeat,
4053                 ** until one or both lists are exhausted.
4054                 **
4055                 ** In all comparisons (after establishing
4056                 ** which head to merge) the item to merge
4057                 ** (at pointer q) is the first operand of
4058                 ** the comparison.  When we want to know
4059                 ** if ``q is strictly less than the other'',
4060                 ** we can't just do
4061                 **    cmp(q, other) < 0
4062                 ** because stability demands that we treat equality
4063                 ** as high when q comes from l2, and as low when
4064                 ** q was from l1.  So we ask the question by doing
4065                 **    cmp(q, other) <= sense
4066                 ** and make sense == 0 when equality should look low,
4067                 ** and -1 when equality should look high.
4068                 */
4069
4070
4071                 if (cmp(aTHX_ *f1, *f2) <= 0) {
4072                     q = f2; b = f1; t = l1;
4073                     sense = -1;
4074                 } else {
4075                     q = f1; b = f2; t = l2;
4076                     sense = 0;
4077                 }
4078
4079
4080                 /* ramp up
4081                 **
4082                 ** Leave t at something strictly
4083                 ** greater than q (or at the end of the list),
4084                 ** and b at something strictly less than q.
4085                 */
4086                 for (i = 1, run = 0 ;;) {
4087                     if ((p = PINDEX(b, i)) >= t) {
4088                         /* off the end */
4089                         if (((p = PINDEX(t, -1)) > b) &&
4090                             (cmp(aTHX_ *q, *p) <= sense))
4091                              t = p;
4092                         else b = p;
4093                         break;
4094                     } else if (cmp(aTHX_ *q, *p) <= sense) {
4095                         t = p;
4096                         break;
4097                     } else b = p;
4098                     if (++run >= RTHRESH) i += i;
4099                 }
4100
4101
4102                 /* q is known to follow b and must be inserted before t.
4103                 ** Increment b, so the range of possibilities is [b,t).
4104                 ** Round binary split down, to favor early appearance.
4105                 ** Adjust b and t until q belongs just before t.
4106                 */
4107
4108                 b++;
4109                 while (b < t) {
4110                     p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4111                     if (cmp(aTHX_ *q, *p) <= sense) {
4112                         t = p;
4113                     } else b = p + 1;
4114                 }
4115
4116
4117                 /* Copy all the strictly low elements */
4118
4119                 if (q == f1) {
4120                     FROMTOUPTO(f2, tp2, t);
4121                     *tp2++ = *f1++;
4122                 } else {
4123                     FROMTOUPTO(f1, tp2, t);
4124                     *tp2++ = *f2++;
4125                 }
4126             }
4127
4128
4129             /* Run out remaining list */
4130             if (f1 == l1) {
4131                    if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4132             } else              FROMTOUPTO(f1, tp2, l1);
4133             p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4134         }
4135         t = list1;
4136         list1 = list2;
4137         list2 = t;
4138         last = PINDEX(list2, nmemb);
4139     }
4140     if (base == list2) {
4141         last = PINDEX(list1, nmemb);
4142         FROMTOUPTO(list1, list2, last);
4143     }
4144     Safefree(aux);
4145     return;
4146 }
4147
4148
4149 #ifdef PERL_OBJECT
4150 #undef this
4151 #define this pPerl
4152 #include "XSUB.h"
4153 #endif
4154
4155
4156 static I32
4157 sortcv(pTHXo_ SV *a, SV *b)
4158 {
4159     I32 oldsaveix = PL_savestack_ix;
4160     I32 oldscopeix = PL_scopestack_ix;
4161     I32 result;
4162     GvSV(PL_firstgv) = a;
4163     GvSV(PL_secondgv) = b;
4164     PL_stack_sp = PL_stack_base;
4165     PL_op = PL_sortcop;
4166     CALLRUNOPS(aTHX);
4167     if (PL_stack_sp != PL_stack_base + 1)
4168         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4169     if (!SvNIOKp(*PL_stack_sp))
4170         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4171     result = SvIV(*PL_stack_sp);
4172     while (PL_scopestack_ix > oldscopeix) {
4173         LEAVE;
4174     }
4175     leave_scope(oldsaveix);
4176     return result;
4177 }
4178
4179 static I32
4180 sortcv_stacked(pTHXo_ SV *a, SV *b)
4181 {
4182     I32 oldsaveix = PL_savestack_ix;
4183     I32 oldscopeix = PL_scopestack_ix;
4184     I32 result;
4185     AV *av;
4186
4187 #ifdef USE_THREADS
4188     av = (AV*)PL_curpad[0];
4189 #else
4190     av = GvAV(PL_defgv);
4191 #endif
4192
4193     if (AvMAX(av) < 1) {
4194         SV** ary = AvALLOC(av);
4195         if (AvARRAY(av) != ary) {
4196             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4197             SvPVX(av) = (char*)ary;
4198         }
4199         if (AvMAX(av) < 1) {
4200             AvMAX(av) = 1;
4201             Renew(ary,2,SV*);
4202             SvPVX(av) = (char*)ary;
4203         }
4204     }
4205     AvFILLp(av) = 1;
4206
4207     AvARRAY(av)[0] = a;
4208     AvARRAY(av)[1] = b;
4209     PL_stack_sp = PL_stack_base;
4210     PL_op = PL_sortcop;
4211     CALLRUNOPS(aTHX);
4212     if (PL_stack_sp != PL_stack_base + 1)
4213         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4214     if (!SvNIOKp(*PL_stack_sp))
4215         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4216     result = SvIV(*PL_stack_sp);
4217     while (PL_scopestack_ix > oldscopeix) {
4218         LEAVE;
4219     }
4220     leave_scope(oldsaveix);
4221     return result;
4222 }
4223
4224 static I32
4225 sortcv_xsub(pTHXo_ SV *a, SV *b)
4226 {
4227     dSP;
4228     I32 oldsaveix = PL_savestack_ix;
4229     I32 oldscopeix = PL_scopestack_ix;
4230     I32 result;
4231     CV *cv=(CV*)PL_sortcop;
4232
4233     SP = PL_stack_base;
4234     PUSHMARK(SP);
4235     EXTEND(SP, 2);
4236     *++SP = a;
4237     *++SP = b;
4238     PUTBACK;
4239     (void)(*CvXSUB(cv))(aTHXo_ cv);
4240     if (PL_stack_sp != PL_stack_base + 1)
4241         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4242     if (!SvNIOKp(*PL_stack_sp))
4243         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4244     result = SvIV(*PL_stack_sp);
4245     while (PL_scopestack_ix > oldscopeix) {
4246         LEAVE;
4247     }
4248     leave_scope(oldsaveix);
4249     return result;
4250 }
4251
4252
4253 static I32
4254 sv_ncmp(pTHXo_ SV *a, SV *b)
4255 {
4256     NV nv1 = SvNV(a);
4257     NV nv2 = SvNV(b);
4258     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4259 }
4260
4261 static I32
4262 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4263 {
4264     IV iv1 = SvIV(a);
4265     IV iv2 = SvIV(b);
4266     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4267 }
4268 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4269           *svp = Nullsv;                                \
4270           if (PL_amagic_generation) { \
4271             if (SvAMAGIC(left)||SvAMAGIC(right))\
4272                 *svp = amagic_call(left, \
4273                                    right, \
4274                                    CAT2(meth,_amg), \
4275                                    0); \
4276           } \
4277         } STMT_END
4278
4279 static I32
4280 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4281 {
4282     SV *tmpsv;
4283     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4284     if (tmpsv) {
4285         NV d;
4286
4287         if (SvIOK(tmpsv)) {
4288             I32 i = SvIVX(tmpsv);
4289             if (i > 0)
4290                return 1;
4291             return i? -1 : 0;
4292         }
4293         d = SvNV(tmpsv);
4294         if (d > 0)
4295            return 1;
4296         return d? -1 : 0;
4297      }
4298      return sv_ncmp(aTHXo_ a, b);
4299 }
4300
4301 static I32
4302 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4303 {
4304     SV *tmpsv;
4305     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4306     if (tmpsv) {
4307         NV d;
4308
4309         if (SvIOK(tmpsv)) {
4310             I32 i = SvIVX(tmpsv);
4311             if (i > 0)
4312                return 1;
4313             return i? -1 : 0;
4314         }
4315         d = SvNV(tmpsv);
4316         if (d > 0)
4317            return 1;
4318         return d? -1 : 0;
4319     }
4320     return sv_i_ncmp(aTHXo_ a, b);
4321 }
4322
4323 static I32
4324 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4325 {
4326     SV *tmpsv;
4327     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4328     if (tmpsv) {
4329         NV d;
4330
4331         if (SvIOK(tmpsv)) {
4332             I32 i = SvIVX(tmpsv);
4333             if (i > 0)
4334                return 1;
4335             return i? -1 : 0;
4336         }
4337         d = SvNV(tmpsv);
4338         if (d > 0)
4339            return 1;
4340         return d? -1 : 0;
4341     }
4342     return sv_cmp(str1, str2);
4343 }
4344
4345 static I32
4346 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4347 {
4348     SV *tmpsv;
4349     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4350     if (tmpsv) {
4351         NV d;
4352
4353         if (SvIOK(tmpsv)) {
4354             I32 i = SvIVX(tmpsv);
4355             if (i > 0)
4356                return 1;
4357             return i? -1 : 0;
4358         }
4359         d = SvNV(tmpsv);
4360         if (d > 0)
4361            return 1;
4362         return d? -1 : 0;
4363     }
4364     return sv_cmp_locale(str1, str2);
4365 }
4366
4367 static I32
4368 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4369 {
4370     SV *datasv = FILTER_DATA(idx);
4371     int filter_has_file = IoLINES(datasv);
4372     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4373     SV *filter_state = (SV *)IoTOP_GV(datasv);
4374     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4375     int len = 0;
4376
4377     /* I was having segfault trouble under Linux 2.2.5 after a
4378        parse error occured.  (Had to hack around it with a test
4379        for PL_error_count == 0.)  Solaris doesn't segfault --
4380        not sure where the trouble is yet.  XXX */
4381
4382     if (filter_has_file) {
4383         len = FILTER_READ(idx+1, buf_sv, maxlen);
4384     }
4385
4386     if (filter_sub && len >= 0) {
4387         dSP;
4388         int count;
4389
4390         ENTER;
4391         SAVE_DEFSV;
4392         SAVETMPS;
4393         EXTEND(SP, 2);
4394
4395         DEFSV = buf_sv;
4396         PUSHMARK(SP);
4397         PUSHs(sv_2mortal(newSViv(maxlen)));
4398         if (filter_state) {
4399             PUSHs(filter_state);
4400         }
4401         PUTBACK;
4402         count = call_sv(filter_sub, G_SCALAR);
4403         SPAGAIN;
4404
4405         if (count > 0) {
4406             SV *out = POPs;
4407             if (SvOK(out)) {
4408                 len = SvIV(out);
4409             }
4410         }
4411
4412         PUTBACK;
4413         FREETMPS;
4414         LEAVE;
4415     }
4416
4417     if (len <= 0) {
4418         IoLINES(datasv) = 0;
4419         if (filter_child_proc) {
4420             SvREFCNT_dec(filter_child_proc);
4421             IoFMT_GV(datasv) = Nullgv;
4422         }
4423         if (filter_state) {
4424             SvREFCNT_dec(filter_state);
4425             IoTOP_GV(datasv) = Nullgv;
4426         }
4427         if (filter_sub) {
4428             SvREFCNT_dec(filter_sub);
4429             IoBOTTOM_GV(datasv) = Nullgv;
4430         }
4431         filter_del(run_user_filter);
4432     }
4433
4434     return len;
4435 }
4436
4437 #ifdef PERL_OBJECT
4438
4439 static I32
4440 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4441 {
4442     return sv_cmp_locale(str1, str2);
4443 }
4444
4445 static I32
4446 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4447 {
4448     return sv_cmp(str1, str2);
4449 }
4450
4451 #endif /* PERL_OBJECT */