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