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