pp_ctl.c

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