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