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