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