pp_ctl.c

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