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