pp_ctl.c

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