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