Context Navigation

source: trunk/third/perl/pp_ctl.c @ 14545

Visit:

Revision 14545, 112.0 KB checked in by ghudson, 25 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.

Line
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	if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1525	PUSHs(cx->blk_eval.cur_text);
1526	PUSHs(&PL_sv_no);
1527	}
1528	/* try blocks have old_namesv == 0 */
1529	else if (cx->blk_eval.old_namesv) {
1530	PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1531	PUSHs(&PL_sv_yes);
1532	}
1533	}
1534	else {
1535	PUSHs(&PL_sv_undef);
1536	PUSHs(&PL_sv_undef);
1537	}
1538	if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1539	&& CopSTASH_eq(PL_curcop, PL_debstash))
1540	{
1541	AV *ary = cx->blk_sub.argarray;
1542	int off = AvARRAY(ary) - AvALLOC(ary);
1543
1544	if (!PL_dbargs) {
1545	GV* tmpgv;
1546	PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1547	SVt_PVAV)));
1548	GvMULTI_on(tmpgv);
1549	AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1550	}
1551
1552	if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1553	av_extend(PL_dbargs, AvFILLp(ary) + off);
1554	Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1555	AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1556	}
1557	/* XXX only hints propagated via op_private are currently
1558	* visible (others are not easily accessible, since they
1559	* use the global PL_hints) */
1560	PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1561	HINT_PRIVATE_MASK)));
1562	{
1563	SV * mask ;
1564	SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1565	if (old_warnings == pWARN_NONE \|\| old_warnings == pWARN_STD)
1566	mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1567	else if (old_warnings == pWARN_ALL)
1568	mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1569	else
1570	mask = newSVsv(old_warnings);
1571	PUSHs(sv_2mortal(mask));
1572	}
1573	RETURN;
1574	}
1575
1576	PP(pp_reset)
1577	{
1578	djSP;
1579	char *tmps;
1580	STRLEN n_a;
1581
1582	if (MAXARG < 1)
1583	tmps = "";
1584	else
1585	tmps = POPpx;
1586	sv_reset(tmps, CopSTASH(PL_curcop));
1587	PUSHs(&PL_sv_yes);
1588	RETURN;
1589	}
1590
1591	PP(pp_lineseq)
1592	{
1593	return NORMAL;
1594	}
1595
1596	PP(pp_dbstate)
1597	{
1598	PL_curcop = (COP*)PL_op;
1599	TAINT_NOT; /* Each statement is presumed innocent */
1600	PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1601	FREETMPS;
1602
1603	if (PL_op->op_private \|\| SvIV(PL_DBsingle) \|\| SvIV(PL_DBsignal) \|\| SvIV(PL_DBtrace))
1604	{
1605	djSP;
1606	register CV *cv;
1607	register PERL_CONTEXT *cx;
1608	I32 gimme = G_ARRAY;
1609	I32 hasargs;
1610	GV *gv;
1611
1612	gv = PL_DBgv;
1613	cv = GvCV(gv);
1614	if (!cv)
1615	DIE(aTHX_ "No DB::DB routine defined");
1616
1617	if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1618	return NORMAL;
1619
1620	ENTER;
1621	SAVETMPS;
1622
1623	SAVEI32(PL_debug);
1624	SAVESTACK_POS();
1625	PL_debug = 0;
1626	hasargs = 0;
1627	SPAGAIN;
1628
1629	push_return(PL_op->op_next);
1630	PUSHBLOCK(cx, CXt_SUB, SP);
1631	PUSHSUB(cx);
1632	CvDEPTH(cv)++;
1633	(void)SvREFCNT_inc(cv);
1634	SAVEVPTR(PL_curpad);
1635	PL_curpad = AvARRAY((AV)av_fetch(CvPADLIST(cv),1,FALSE));
1636	RETURNOP(CvSTART(cv));
1637	}
1638	else
1639	return NORMAL;
1640	}
1641
1642	PP(pp_scope)
1643	{
1644	return NORMAL;
1645	}
1646
1647	PP(pp_enteriter)
1648	{
1649	djSP; dMARK;
1650	register PERL_CONTEXT *cx;
1651	I32 gimme = GIMME_V;
1652	SV **svp;
1653	U32 cxtype = CXt_LOOP;
1654	#ifdef USE_ITHREADS
1655	void *iterdata;
1656	#endif
1657
1658	ENTER;
1659	SAVETMPS;
1660
1661	#ifdef USE_THREADS
1662	if (PL_op->op_flags & OPf_SPECIAL) {
1663	dTHR;
1664	svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1665	SAVEGENERICSV(*svp);
1666	*svp = NEWSV(0,0);
1667	}
1668	else
1669	#endif /* USE_THREADS */
1670	if (PL_op->op_targ) {
1671	svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1672	SAVESPTR(*svp);
1673	#ifdef USE_ITHREADS
1674	iterdata = (void*)PL_op->op_targ;
1675	cxtype \|= CXp_PADVAR;
1676	#endif
1677	}
1678	else {
1679	GV gv = (GV)POPs;
1680	svp = &GvSV(gv); /* symbol table variable */
1681	SAVEGENERICSV(*svp);
1682	*svp = NEWSV(0,0);
1683	#ifdef USE_ITHREADS
1684	iterdata = (void*)gv;
1685	#endif
1686	}
1687
1688	ENTER;
1689
1690	PUSHBLOCK(cx, cxtype, SP);
1691	#ifdef USE_ITHREADS
1692	PUSHLOOP(cx, iterdata, MARK);
1693	#else
1694	PUSHLOOP(cx, svp, MARK);
1695	#endif
1696	if (PL_op->op_flags & OPf_STACKED) {
1697	cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1698	if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1699	dPOPss;
1700	if (SvNIOKp(sv) \|\| !SvPOKp(sv) \|\|
1701	SvNIOKp(cx->blk_loop.iterary) \|\| !SvPOKp(cx->blk_loop.iterary) \|\|
1702	(looks_like_number(sv) && *SvPVX(sv) != '0' &&
1703	looks_like_number((SV*)cx->blk_loop.iterary) &&
1704	*SvPVX(cx->blk_loop.iterary) != '0'))
1705	{
1706	if (SvNV(sv) < IV_MIN \|\|
1707	SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1708	DIE(aTHX_ "Range iterator outside integer range");
1709	cx->blk_loop.iterix = SvIV(sv);
1710	cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1711	}
1712	else
1713	cx->blk_loop.iterlval = newSVsv(sv);
1714	}
1715	}
1716	else {
1717	cx->blk_loop.iterary = PL_curstack;
1718	AvFILLp(PL_curstack) = SP - PL_stack_base;
1719	cx->blk_loop.iterix = MARK - PL_stack_base;
1720	}
1721
1722	RETURN;
1723	}
1724
1725	PP(pp_enterloop)
1726	{
1727	djSP;
1728	register PERL_CONTEXT *cx;
1729	I32 gimme = GIMME_V;
1730
1731	ENTER;
1732	SAVETMPS;
1733	ENTER;
1734
1735	PUSHBLOCK(cx, CXt_LOOP, SP);
1736	PUSHLOOP(cx, 0, SP);
1737
1738	RETURN;
1739	}
1740
1741	PP(pp_leaveloop)
1742	{
1743	djSP;
1744	register PERL_CONTEXT *cx;
1745	I32 gimme;
1746	SV **newsp;
1747	PMOP *newpm;
1748	SV **mark;
1749
1750	POPBLOCK(cx,newpm);
1751	mark = newsp;
1752	newsp = PL_stack_base + cx->blk_loop.resetsp;
1753
1754	TAINT_NOT;
1755	if (gimme == G_VOID)
1756	; /* do nothing */
1757	else if (gimme == G_SCALAR) {
1758	if (mark < SP)
1759	++newsp = sv_mortalcopy(SP);
1760	else
1761	*++newsp = &PL_sv_undef;
1762	}
1763	else {
1764	while (mark < SP) {
1765	++newsp = sv_mortalcopy(++mark);
1766	TAINT_NOT; /* Each item is independent */
1767	}
1768	}
1769	SP = newsp;
1770	PUTBACK;
1771
1772	POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1773	PL_curpm = newpm; /* ... and pop $1 et al */
1774
1775	LEAVE;
1776	LEAVE;
1777
1778	return NORMAL;
1779	}
1780
1781	PP(pp_return)
1782	{
1783	djSP; dMARK;
1784	I32 cxix;
1785	register PERL_CONTEXT *cx;
1786	bool popsub2 = FALSE;
1787	bool clear_errsv = FALSE;
1788	I32 gimme;
1789	SV **newsp;
1790	PMOP *newpm;
1791	I32 optype = 0;
1792	SV *sv;
1793
1794	if (PL_curstackinfo->si_type == PERLSI_SORT) {
1795	if (cxstack_ix == PL_sortcxix
1796	\|\| dopoptosub(cxstack_ix) <= PL_sortcxix)
1797	{
1798	if (cxstack_ix > PL_sortcxix)
1799	dounwind(PL_sortcxix);
1800	AvARRAY(PL_curstack)[1] = *SP;
1801	PL_stack_sp = PL_stack_base + 1;
1802	return 0;
1803	}
1804	}
1805
1806	cxix = dopoptosub(cxstack_ix);
1807	if (cxix < 0)
1808	DIE(aTHX_ "Can't return outside a subroutine");
1809	if (cxix < cxstack_ix)
1810	dounwind(cxix);
1811
1812	POPBLOCK(cx,newpm);
1813	switch (CxTYPE(cx)) {
1814	case CXt_SUB:
1815	popsub2 = TRUE;
1816	break;
1817	case CXt_EVAL:
1818	if (!(PL_in_eval & EVAL_KEEPERR))
1819	clear_errsv = TRUE;
1820	POPEVAL(cx);
1821	if (CxTRYBLOCK(cx))
1822	break;
1823	if (AvFILLp(PL_comppad_name) >= 0)
1824	free_closures();
1825	lex_end();
1826	if (optype == OP_REQUIRE &&
1827	(MARK == SP \|\| (gimme == G_SCALAR && !SvTRUE(*SP))) )
1828	{
1829	/* Unassume the success we assumed earlier. */
1830	SV *nsv = cx->blk_eval.old_namesv;
1831	(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1832	DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1833	}
1834	break;
1835	case CXt_FORMAT:
1836	POPFORMAT(cx);
1837	break;
1838	default:
1839	DIE(aTHX_ "panic: return");
1840	}
1841
1842	TAINT_NOT;
1843	if (gimme == G_SCALAR) {
1844	if (MARK < SP) {
1845	if (popsub2) {
1846	if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1847	if (SvTEMP(TOPs)) {
1848	++newsp = SvREFCNT_inc(SP);
1849	FREETMPS;
1850	sv_2mortal(*newsp);
1851	}
1852	else {
1853	sv = SvREFCNT_inc(SP); / FREETMPS could clobber it */
1854	FREETMPS;
1855	*++newsp = sv_mortalcopy(sv);
1856	SvREFCNT_dec(sv);
1857	}
1858	}
1859	else
1860	++newsp = (SvTEMP(SP)) ? SP : sv_mortalcopy(SP);
1861	}
1862	else
1863	++newsp = sv_mortalcopy(SP);
1864	}
1865	else
1866	*++newsp = &PL_sv_undef;
1867	}
1868	else if (gimme == G_ARRAY) {
1869	while (++MARK <= SP) {
1870	++newsp = (popsub2 && SvTEMP(MARK))
1871	? MARK : sv_mortalcopy(MARK);
1872	TAINT_NOT; /* Each item is independent */
1873	}
1874	}
1875	PL_stack_sp = newsp;
1876
1877	/* Stack values are safe: */
1878	if (popsub2) {
1879	POPSUB(cx,sv); /* release CV and @_ ... */
1880	}
1881	else
1882	sv = Nullsv;
1883	PL_curpm = newpm; /* ... and pop $1 et al */
1884
1885	LEAVE;
1886	LEAVESUB(sv);
1887	if (clear_errsv)
1888	sv_setpv(ERRSV,"");
1889	return pop_return();
1890	}
1891
1892	PP(pp_last)
1893	{
1894	djSP;
1895	I32 cxix;
1896	register PERL_CONTEXT *cx;
1897	I32 pop2 = 0;
1898	I32 gimme;
1899	I32 optype;
1900	OP *nextop;
1901	SV **newsp;
1902	PMOP *newpm;
1903	SV **mark;
1904	SV *sv = Nullsv;
1905
1906	if (PL_op->op_flags & OPf_SPECIAL) {
1907	cxix = dopoptoloop(cxstack_ix);
1908	if (cxix < 0)
1909	DIE(aTHX_ "Can't \"last\" outside a loop block");
1910	}
1911	else {
1912	cxix = dopoptolabel(cPVOP->op_pv);
1913	if (cxix < 0)
1914	DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1915	}
1916	if (cxix < cxstack_ix)
1917	dounwind(cxix);
1918
1919	POPBLOCK(cx,newpm);
1920	mark = newsp;
1921	switch (CxTYPE(cx)) {
1922	case CXt_LOOP:
1923	pop2 = CXt_LOOP;
1924	newsp = PL_stack_base + cx->blk_loop.resetsp;
1925	nextop = cx->blk_loop.last_op->op_next;
1926	break;
1927	case CXt_SUB:
1928	pop2 = CXt_SUB;
1929	nextop = pop_return();
1930	break;
1931	case CXt_EVAL:
1932	POPEVAL(cx);
1933	nextop = pop_return();
1934	break;
1935	case CXt_FORMAT:
1936	POPFORMAT(cx);
1937	nextop = pop_return();
1938	break;
1939	default:
1940	DIE(aTHX_ "panic: last");
1941	}
1942
1943	TAINT_NOT;
1944	if (gimme == G_SCALAR) {
1945	if (MARK < SP)
1946	++newsp = ((pop2 == CXt_SUB) && SvTEMP(SP))
1947	? SP : sv_mortalcopy(SP);
1948	else
1949	*++newsp = &PL_sv_undef;
1950	}
1951	else if (gimme == G_ARRAY) {
1952	while (++MARK <= SP) {
1953	++newsp = ((pop2 == CXt_SUB) && SvTEMP(MARK))
1954	? MARK : sv_mortalcopy(MARK);
1955	TAINT_NOT; /* Each item is independent */
1956	}
1957	}
1958	SP = newsp;
1959	PUTBACK;
1960
1961	/* Stack values are safe: */
1962	switch (pop2) {
1963	case CXt_LOOP:
1964	POPLOOP(cx); /* release loop vars ... */
1965	LEAVE;
1966	break;
1967	case CXt_SUB:
1968	POPSUB(cx,sv); /* release CV and @_ ... */
1969	break;
1970	}
1971	PL_curpm = newpm; /* ... and pop $1 et al */
1972
1973	LEAVE;
1974	LEAVESUB(sv);
1975	return nextop;
1976	}
1977
1978	PP(pp_next)
1979	{
1980	I32 cxix;
1981	register PERL_CONTEXT *cx;
1982	I32 oldsave;
1983
1984	if (PL_op->op_flags & OPf_SPECIAL) {
1985	cxix = dopoptoloop(cxstack_ix);
1986	if (cxix < 0)
1987	DIE(aTHX_ "Can't \"next\" outside a loop block");
1988	}
1989	else {
1990	cxix = dopoptolabel(cPVOP->op_pv);
1991	if (cxix < 0)
1992	DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1993	}
1994	if (cxix < cxstack_ix)
1995	dounwind(cxix);
1996
1997	TOPBLOCK(cx);
1998
1999	/* clean scope, but only if there's no continue block */
2000	if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) {
2001	oldsave = PL_scopestack[PL_scopestack_ix - 1];
2002	LEAVE_SCOPE(oldsave);
2003	}
2004	return cx->blk_loop.next_op;
2005	}
2006
2007	PP(pp_redo)
2008	{
2009	I32 cxix;
2010	register PERL_CONTEXT *cx;
2011	I32 oldsave;
2012
2013	if (PL_op->op_flags & OPf_SPECIAL) {
2014	cxix = dopoptoloop(cxstack_ix);
2015	if (cxix < 0)
2016	DIE(aTHX_ "Can't \"redo\" outside a loop block");
2017	}
2018	else {
2019	cxix = dopoptolabel(cPVOP->op_pv);
2020	if (cxix < 0)
2021	DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2022	}
2023	if (cxix < cxstack_ix)
2024	dounwind(cxix);
2025
2026	TOPBLOCK(cx);
2027	oldsave = PL_scopestack[PL_scopestack_ix - 1];
2028	LEAVE_SCOPE(oldsave);
2029	return cx->blk_loop.redo_op;
2030	}
2031
2032	STATIC OP *
2033	S_dofindlabel(pTHX_ OP o, char label, OP opstack, OP oplimit)
2034	{
2035	OP *kid;
2036	OP **ops = opstack;
2037	static char too_deep[] = "Target of goto is too deeply nested";
2038
2039	if (ops >= oplimit)
2040	Perl_croak(aTHX_ too_deep);
2041	if (o->op_type == OP_LEAVE \|\|
2042	o->op_type == OP_SCOPE \|\|
2043	o->op_type == OP_LEAVELOOP \|\|
2044	o->op_type == OP_LEAVETRY)
2045	{
2046	*ops++ = cUNOPo->op_first;
2047	if (ops >= oplimit)
2048	Perl_croak(aTHX_ too_deep);
2049	}
2050	*ops = 0;
2051	if (o->op_flags & OPf_KIDS) {
2052	dTHR;
2053	/* First try all the kids at this level, since that's likeliest. */
2054	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2055	if ((kid->op_type == OP_NEXTSTATE \|\| kid->op_type == OP_DBSTATE) &&
2056	kCOP->cop_label && strEQ(kCOP->cop_label, label))
2057	return kid;
2058	}
2059	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2060	if (kid == PL_lastgotoprobe)
2061	continue;
2062	if ((kid->op_type == OP_NEXTSTATE \|\| kid->op_type == OP_DBSTATE) &&
2063	(ops == opstack \|\|
2064	(ops[-1]->op_type != OP_NEXTSTATE &&
2065	ops[-1]->op_type != OP_DBSTATE)))
2066	*ops++ = kid;
2067	if ((o = dofindlabel(kid, label, ops, oplimit)))
2068	return o;
2069	}
2070	}
2071	*ops = 0;
2072	return 0;
2073	}
2074
2075	PP(pp_dump)
2076	{
2077	return pp_goto();
2078	/NOTREACHED/
2079	}
2080
2081	PP(pp_goto)
2082	{
2083	djSP;
2084	OP *retop = 0;
2085	I32 ix;
2086	register PERL_CONTEXT *cx;
2087	#define GOTO_DEPTH 64
2088	OP *enterops[GOTO_DEPTH];
2089	char *label;
2090	int do_dump = (PL_op->op_type == OP_DUMP);
2091	static char must_have_label[] = "goto must have label";
2092
2093	label = 0;
2094	if (PL_op->op_flags & OPf_STACKED) {
2095	SV *sv = POPs;
2096	STRLEN n_a;
2097
2098	/* This egregious kludge implements goto &subroutine */
2099	if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2100	I32 cxix;
2101	register PERL_CONTEXT *cx;
2102	CV* cv = (CV*)SvRV(sv);
2103	SV** mark;
2104	I32 items = 0;
2105	I32 oldsave;
2106
2107	retry:
2108	if (!CvROOT(cv) && !CvXSUB(cv)) {
2109	GV *gv = CvGV(cv);
2110	GV *autogv;
2111	if (gv) {
2112	SV *tmpstr;
2113	/* autoloaded stub? */
2114	if (cv != GvCV(gv) && (cv = GvCV(gv)))
2115	goto retry;
2116	autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2117	GvNAMELEN(gv), FALSE);
2118	if (autogv && (cv = GvCV(autogv)))
2119	goto retry;
2120	tmpstr = sv_newmortal();
2121	gv_efullname3(tmpstr, gv, Nullch);
2122	DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2123	}
2124	DIE(aTHX_ "Goto undefined subroutine");
2125	}
2126
2127	/* First do some returnish stuff. */
2128	cxix = dopoptosub(cxstack_ix);
2129	if (cxix < 0)
2130	DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2131	if (cxix < cxstack_ix)
2132	dounwind(cxix);
2133	TOPBLOCK(cx);
2134	if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2135	DIE(aTHX_ "Can't goto subroutine from an eval-string");
2136	mark = PL_stack_sp;
2137	if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2138	/* put @_ back onto stack */
2139	AV* av = cx->blk_sub.argarray;
2140
2141	items = AvFILLp(av) + 1;
2142	PL_stack_sp++;
2143	EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2144	Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2145	PL_stack_sp += items;
2146	#ifndef USE_THREADS
2147	SvREFCNT_dec(GvAV(PL_defgv));
2148	GvAV(PL_defgv) = cx->blk_sub.savearray;
2149	#endif /* USE_THREADS */
2150	/* abandon @_ if it got reified */
2151	if (AvREAL(av)) {
2152	(void)sv_2mortal((SV)av); / delay until return */
2153	av = newAV();
2154	av_extend(av, items-1);
2155	AvFLAGS(av) = AVf_REIFY;
2156	PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2157	}
2158	}
2159	else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2160	AV* av;
2161	#ifdef USE_THREADS
2162	av = (AV*)PL_curpad[0];
2163	#else
2164	av = GvAV(PL_defgv);
2165	#endif
2166	items = AvFILLp(av) + 1;
2167	PL_stack_sp++;
2168	EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2169	Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2170	PL_stack_sp += items;
2171	}
2172	if (CxTYPE(cx) == CXt_SUB &&
2173	!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2174	SvREFCNT_dec(cx->blk_sub.cv);
2175	oldsave = PL_scopestack[PL_scopestack_ix - 1];
2176	LEAVE_SCOPE(oldsave);
2177
2178	/* Now do some callish stuff. */
2179	SAVETMPS;
2180	if (CvXSUB(cv)) {
2181	#ifdef PERL_XSUB_OLDSTYLE
2182	if (CvOLDSTYLE(cv)) {
2183	I32 (*fp3)(int,int,int);
2184	while (SP > mark) {
2185	SP[1] = SP[0];
2186	SP--;
2187	}
2188	fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2189	items = (*fp3)(CvXSUBANY(cv).any_i32,
2190	mark - PL_stack_base + 1,
2191	items);
2192	SP = PL_stack_base + items;
2193	}
2194	else
2195	#endif /* PERL_XSUB_OLDSTYLE */
2196	{
2197	SV **newsp;
2198	I32 gimme;
2199
2200	PL_stack_sp--; /* There is no cv arg. */
2201	/* Push a mark for the start of arglist */
2202	PUSHMARK(mark);
2203	(void)(*CvXSUB(cv))(aTHXo_ cv);
2204	/* Pop the current context like a decent sub should */
2205	POPBLOCK(cx, PL_curpm);
2206	/* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2207	}
2208	LEAVE;
2209	return pop_return();
2210	}
2211	else {
2212	AV* padlist = CvPADLIST(cv);
2213	SV** svp = AvARRAY(padlist);
2214	if (CxTYPE(cx) == CXt_EVAL) {
2215	PL_in_eval = cx->blk_eval.old_in_eval;
2216	PL_eval_root = cx->blk_eval.old_eval_root;
2217	cx->cx_type = CXt_SUB;
2218	cx->blk_sub.hasargs = 0;
2219	}
2220	cx->blk_sub.cv = cv;
2221	cx->blk_sub.olddepth = CvDEPTH(cv);
2222	CvDEPTH(cv)++;
2223	if (CvDEPTH(cv) < 2)
2224	(void)SvREFCNT_inc(cv);
2225	else { /* save temporaries on recursion? */
2226	if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2227	sub_crush_depth(cv);
2228	if (CvDEPTH(cv) > AvFILLp(padlist)) {
2229	AV *newpad = newAV();
2230	SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2231	I32 ix = AvFILLp((AV*)svp[1]);
2232	I32 names_fill = AvFILLp((AV*)svp[0]);
2233	svp = AvARRAY(svp[0]);
2234	for ( ;ix > 0; ix--) {
2235	if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2236	char *name = SvPVX(svp[ix]);
2237	if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2238	\|\| *name == '&')
2239	{
2240	/* outer lexical or anon code */
2241	av_store(newpad, ix,
2242	SvREFCNT_inc(oldpad[ix]) );
2243	}
2244	else { /* our own lexical */
2245	if (*name == '@')
2246	av_store(newpad, ix, sv = (SV*)newAV());
2247	else if (*name == '%')
2248	av_store(newpad, ix, sv = (SV*)newHV());
2249	else
2250	av_store(newpad, ix, sv = NEWSV(0,0));
2251	SvPADMY_on(sv);
2252	}
2253	}
2254	else if (IS_PADGV(oldpad[ix]) \|\| IS_PADCONST(oldpad[ix])) {
2255	av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2256	}
2257	else {
2258	av_store(newpad, ix, sv = NEWSV(0,0));
2259	SvPADTMP_on(sv);
2260	}
2261	}
2262	if (cx->blk_sub.hasargs) {
2263	AV* av = newAV();
2264	av_extend(av, 0);
2265	av_store(newpad, 0, (SV*)av);
2266	AvFLAGS(av) = AVf_REIFY;
2267	}
2268	av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2269	AvFILLp(padlist) = CvDEPTH(cv);
2270	svp = AvARRAY(padlist);
2271	}
2272	}
2273	#ifdef USE_THREADS
2274	if (!cx->blk_sub.hasargs) {
2275	AV* av = (AV*)PL_curpad[0];
2276
2277	items = AvFILLp(av) + 1;
2278	if (items) {
2279	/* Mark is at the end of the stack. */
2280	EXTEND(SP, items);
2281	Copy(AvARRAY(av), SP + 1, items, SV*);
2282	SP += items;
2283	PUTBACK ;
2284	}
2285	}
2286	#endif /* USE_THREADS */
2287	SAVEVPTR(PL_curpad);
2288	PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2289	#ifndef USE_THREADS
2290	if (cx->blk_sub.hasargs)
2291	#endif /* USE_THREADS */
2292	{
2293	AV* av = (AV*)PL_curpad[0];
2294	SV** ary;
2295
2296	#ifndef USE_THREADS
2297	cx->blk_sub.savearray = GvAV(PL_defgv);
2298	GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2299	#endif /* USE_THREADS */
2300	cx->blk_sub.argarray = av;
2301	++mark;
2302
2303	if (items >= AvMAX(av) + 1) {
2304	ary = AvALLOC(av);
2305	if (AvARRAY(av) != ary) {
2306	AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2307	SvPVX(av) = (char*)ary;
2308	}
2309	if (items >= AvMAX(av) + 1) {
2310	AvMAX(av) = items - 1;
2311	Renew(ary,items+1,SV*);
2312	AvALLOC(av) = ary;
2313	SvPVX(av) = (char*)ary;
2314	}
2315	}
2316	Copy(mark,AvARRAY(av),items,SV*);
2317	AvFILLp(av) = items - 1;
2318	assert(!AvREAL(av));
2319	while (items--) {
2320	if (*mark)
2321	SvTEMP_off(*mark);
2322	mark++;
2323	}
2324	}
2325	if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2326	/*
2327	* We do not care about using sv to call CV;
2328	* it's for informational purposes only.
2329	*/
2330	SV *sv = GvSV(PL_DBsub);
2331	CV *gotocv;
2332
2333	if (PERLDB_SUB_NN) {
2334	SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2335	} else {
2336	save_item(sv);
2337	gv_efullname3(sv, CvGV(cv), Nullch);
2338	}
2339	if ( PERLDB_GOTO
2340	&& (gotocv = get_cv("DB::goto", FALSE)) ) {
2341	PUSHMARK( PL_stack_sp );
2342	call_sv((SV*)gotocv, G_SCALAR \| G_NODEBUG);
2343	PL_stack_sp--;
2344	}
2345	}
2346	RETURNOP(CvSTART(cv));
2347	}
2348	}
2349	else {
2350	label = SvPV(sv,n_a);
2351	if (!(do_dump \|\| *label))
2352	DIE(aTHX_ must_have_label);
2353	}
2354	}
2355	else if (PL_op->op_flags & OPf_SPECIAL) {
2356	if (! do_dump)
2357	DIE(aTHX_ must_have_label);
2358	}
2359	else
2360	label = cPVOP->op_pv;
2361
2362	if (label && *label) {
2363	OP *gotoprobe = 0;
2364
2365	/* find label */
2366
2367	PL_lastgotoprobe = 0;
2368	*enterops = 0;
2369	for (ix = cxstack_ix; ix >= 0; ix--) {
2370	cx = &cxstack[ix];
2371	switch (CxTYPE(cx)) {
2372	case CXt_EVAL:
2373	gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2374	break;
2375	case CXt_LOOP:
2376	gotoprobe = cx->blk_oldcop->op_sibling;
2377	break;
2378	case CXt_SUBST:
2379	continue;
2380	case CXt_BLOCK:
2381	if (ix)
2382	gotoprobe = cx->blk_oldcop->op_sibling;
2383	else
2384	gotoprobe = PL_main_root;
2385	break;
2386	case CXt_SUB:
2387	if (CvDEPTH(cx->blk_sub.cv)) {
2388	gotoprobe = CvROOT(cx->blk_sub.cv);
2389	break;
2390	}
2391	/* FALL THROUGH */
2392	case CXt_FORMAT:
2393	case CXt_NULL:
2394	DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2395	default:
2396	if (ix)
2397	DIE(aTHX_ "panic: goto");
2398	gotoprobe = PL_main_root;
2399	break;
2400	}
2401	if (gotoprobe) {
2402	retop = dofindlabel(gotoprobe, label,
2403	enterops, enterops + GOTO_DEPTH);
2404	if (retop)
2405	break;
2406	}
2407	PL_lastgotoprobe = gotoprobe;
2408	}
2409	if (!retop)
2410	DIE(aTHX_ "Can't find label %s", label);
2411
2412	/* pop unwanted frames */
2413
2414	if (ix < cxstack_ix) {
2415	I32 oldsave;
2416
2417	if (ix < 0)
2418	ix = 0;
2419	dounwind(ix);
2420	TOPBLOCK(cx);
2421	oldsave = PL_scopestack[PL_scopestack_ix];
2422	LEAVE_SCOPE(oldsave);
2423	}
2424
2425	/* push wanted frames */
2426
2427	if (*enterops && enterops[1]) {
2428	OP *oldop = PL_op;
2429	for (ix = 1; enterops[ix]; ix++) {
2430	PL_op = enterops[ix];
2431	/* Eventually we may want to stack the needed arguments
2432	* for each op. For now, we punt on the hard ones. */
2433	if (PL_op->op_type == OP_ENTERITER)
2434	DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2435	CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2436	}
2437	PL_op = oldop;
2438	}
2439	}
2440
2441	if (do_dump) {
2442	#ifdef VMS
2443	if (!retop) retop = PL_main_start;
2444	#endif
2445	PL_restartop = retop;
2446	PL_do_undump = TRUE;
2447
2448	my_unexec();
2449
2450	PL_restartop = 0; /* hmm, must be GNU unexec().. */
2451	PL_do_undump = FALSE;
2452	}
2453
2454	RETURNOP(retop);
2455	}
2456
2457	PP(pp_exit)
2458	{
2459	djSP;
2460	I32 anum;
2461
2462	if (MAXARG < 1)
2463	anum = 0;
2464	else {
2465	anum = SvIVx(POPs);
2466	#ifdef VMS
2467	if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2468	anum = 0;
2469	#endif
2470	}
2471	PL_exit_flags \|= PERL_EXIT_EXPECTED;
2472	my_exit(anum);
2473	PUSHs(&PL_sv_undef);
2474	RETURN;
2475	}
2476
2477	#ifdef NOTYET
2478	PP(pp_nswitch)
2479	{
2480	djSP;
2481	NV value = SvNVx(GvSV(cCOP->cop_gv));
2482	register I32 match = I_32(value);
2483
2484	if (value < 0.0) {
2485	if (((NV)match) > value)
2486	--match; /* was fractional--truncate other way */
2487	}
2488	match -= cCOP->uop.scop.scop_offset;
2489	if (match < 0)
2490	match = 0;
2491	else if (match > cCOP->uop.scop.scop_max)
2492	match = cCOP->uop.scop.scop_max;
2493	PL_op = cCOP->uop.scop.scop_next[match];
2494	RETURNOP(PL_op);
2495	}
2496
2497	PP(pp_cswitch)
2498	{
2499	djSP;
2500	register I32 match;
2501
2502	if (PL_multiline)
2503	PL_op = PL_op->op_next; /* can't assume anything */
2504	else {
2505	STRLEN n_a;
2506	match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2507	match -= cCOP->uop.scop.scop_offset;
2508	if (match < 0)
2509	match = 0;
2510	else if (match > cCOP->uop.scop.scop_max)
2511	match = cCOP->uop.scop.scop_max;
2512	PL_op = cCOP->uop.scop.scop_next[match];
2513	}
2514	RETURNOP(PL_op);
2515	}
2516	#endif
2517
2518	/* Eval. */
2519
2520	STATIC void
2521	S_save_lines(pTHX_ AV array, SV sv)
2522	{
2523	register char *s = SvPVX(sv);
2524	register char *send = SvPVX(sv) + SvCUR(sv);
2525	register char *t;
2526	register I32 line = 1;
2527
2528	while (s && s < send) {
2529	SV *tmpstr = NEWSV(85,0);
2530
2531	sv_upgrade(tmpstr, SVt_PVMG);
2532	t = strchr(s, '\n');
2533	if (t)
2534	t++;
2535	else
2536	t = send;
2537
2538	sv_setpvn(tmpstr, s, t - s);
2539	av_store(array, line++, tmpstr);
2540	s = t;
2541	}
2542	}
2543
2544	#ifdef PERL_FLEXIBLE_EXCEPTIONS
2545	STATIC void *
2546	S_docatch_body(pTHX_ va_list args)
2547	{
2548	return docatch_body();
2549	}
2550	#endif
2551
2552	STATIC void *
2553	S_docatch_body(pTHX)
2554	{
2555	CALLRUNOPS(aTHX);
2556	return NULL;
2557	}
2558
2559	STATIC OP *
2560	S_docatch(pTHX_ OP *o)
2561	{
2562	dTHR;
2563	int ret;
2564	OP *oldop = PL_op;
2565	volatile PERL_SI *cursi = PL_curstackinfo;
2566	dJMPENV;
2567
2568	#ifdef DEBUGGING
2569	assert(CATCH_GET == TRUE);
2570	#endif
2571	PL_op = o;
2572	#ifdef PERL_FLEXIBLE_EXCEPTIONS
2573	redo_body:
2574	CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2575	#else
2576	JMPENV_PUSH(ret);
2577	#endif
2578	switch (ret) {
2579	case 0:
2580	#ifndef PERL_FLEXIBLE_EXCEPTIONS
2581	redo_body:
2582	docatch_body();
2583	#endif
2584	break;
2585	case 3:
2586	if (PL_restartop && cursi == PL_curstackinfo) {
2587	PL_op = PL_restartop;
2588	PL_restartop = 0;
2589	goto redo_body;
2590	}
2591	/* FALL THROUGH */
2592	default:
2593	JMPENV_POP;
2594	PL_op = oldop;
2595	JMPENV_JUMP(ret);
2596	/* NOTREACHED */
2597	}
2598	JMPENV_POP;
2599	PL_op = oldop;
2600	return Nullop;
2601	}
2602
2603	OP *
2604	Perl_sv_compile_2op(pTHX_ SV sv, OP* startop, char code, AV* avp)
2605	/* sv Text to convert to OP tree. */
2606	/* startop op_free() this to undo. */
2607	/* code Short string id of the caller. */
2608	{
2609	dSP; /* Make POPBLOCK work. */
2610	PERL_CONTEXT *cx;
2611	SV **newsp;
2612	I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2613	I32 optype;
2614	OP dummy;
2615	OP *rop;
2616	char tbuf[TYPE_DIGITS(long) + 12 + 10];
2617	char *tmpbuf = tbuf;
2618	char *safestr;
2619
2620	ENTER;
2621	lex_start(sv);
2622	SAVETMPS;
2623	/* switch to eval mode */
2624
2625	if (PL_curcop == &PL_compiling) {
2626	SAVECOPSTASH(&PL_compiling);
2627	CopSTASH_set(&PL_compiling, PL_curstash);
2628	}
2629	SAVECOPFILE(&PL_compiling);
2630	SAVECOPLINE(&PL_compiling);
2631	if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2632	SV *sv = sv_newmortal();
2633	Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2634	code, (unsigned long)++PL_evalseq,
2635	CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2636	tmpbuf = SvPVX(sv);
2637	}
2638	else
2639	sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2640	CopFILE_set(&PL_compiling, tmpbuf+2);
2641	CopLINE_set(&PL_compiling, 1);
2642	/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2643	deleting the eval's FILEGV from the stash before gv_check() runs
2644	(i.e. before run-time proper). To work around the coredump that
2645	ensues, we always turn GvMULTI_on for any globals that were
2646	introduced within evals. See force_ident(). GSAR 96-10-12 */
2647	safestr = savepv(tmpbuf);
2648	SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2649	SAVEHINTS();
2650	#ifdef OP_IN_REGISTER
2651	PL_opsave = op;
2652	#else
2653	SAVEVPTR(PL_op);
2654	#endif
2655	PL_hints = 0;
2656
2657	PL_op = &dummy;
2658	PL_op->op_type = OP_ENTEREVAL;
2659	PL_op->op_flags = 0; /* Avoid uninit warning. */
2660	PUSHBLOCK(cx, CXt_EVAL, SP);
2661	PUSHEVAL(cx, 0, Nullgv);
2662	rop = doeval(G_SCALAR, startop);
2663	POPBLOCK(cx,PL_curpm);
2664	POPEVAL(cx);
2665
2666	(*startop)->op_type = OP_NULL;
2667	(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2668	lex_end();
2669	avp = (AV)SvREFCNT_inc(PL_comppad);
2670	LEAVE;
2671	if (PL_curcop == &PL_compiling)
2672	PL_compiling.op_private = PL_hints;
2673	#ifdef OP_IN_REGISTER
2674	op = PL_opsave;
2675	#endif
2676	return rop;
2677	}
2678
2679	/* With USE_THREADS, eval_owner must be held on entry to doeval */
2680	STATIC OP *
2681	S_doeval(pTHX_ int gimme, OP** startop)
2682	{
2683	dSP;
2684	OP *saveop = PL_op;
2685	CV *caller;
2686	AV* comppadlist;
2687	I32 i;
2688
2689	PL_in_eval = EVAL_INEVAL;
2690
2691	PUSHMARK(SP);
2692
2693	/* set up a scratch pad */
2694
2695	SAVEI32(PL_padix);
2696	SAVEVPTR(PL_curpad);
2697	SAVESPTR(PL_comppad);
2698	SAVESPTR(PL_comppad_name);
2699	SAVEI32(PL_comppad_name_fill);
2700	SAVEI32(PL_min_intro_pending);
2701	SAVEI32(PL_max_intro_pending);
2702
2703	caller = PL_compcv;
2704	for (i = cxstack_ix - 1; i >= 0; i--) {
2705	PERL_CONTEXT *cx = &cxstack[i];
2706	if (CxTYPE(cx) == CXt_EVAL)
2707	break;
2708	else if (CxTYPE(cx) == CXt_SUB \|\| CxTYPE(cx) == CXt_FORMAT) {
2709	caller = cx->blk_sub.cv;
2710	break;
2711	}
2712	}
2713
2714	SAVESPTR(PL_compcv);
2715	PL_compcv = (CV*)NEWSV(1104,0);
2716	sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2717	CvEVAL_on(PL_compcv);
2718	#ifdef USE_THREADS
2719	CvOWNER(PL_compcv) = 0;
2720	New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2721	MUTEX_INIT(CvMUTEXP(PL_compcv));
2722	#endif /* USE_THREADS */
2723
2724	PL_comppad = newAV();
2725	av_push(PL_comppad, Nullsv);
2726	PL_curpad = AvARRAY(PL_comppad);
2727	PL_comppad_name = newAV();
2728	PL_comppad_name_fill = 0;
2729	PL_min_intro_pending = 0;
2730	PL_padix = 0;
2731	#ifdef USE_THREADS
2732	av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2733	PL_curpad[0] = (SV*)newAV();
2734	SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2735	#endif /* USE_THREADS */
2736
2737	comppadlist = newAV();
2738	AvREAL_off(comppadlist);
2739	av_store(comppadlist, 0, (SV*)PL_comppad_name);
2740	av_store(comppadlist, 1, (SV*)PL_comppad);
2741	CvPADLIST(PL_compcv) = comppadlist;
2742
2743	if (!saveop \|\|
2744	(saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2745	{
2746	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2747	}
2748
2749	SAVEFREESV(PL_compcv);
2750
2751	/* make sure we compile in the right package */
2752
2753	if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2754	SAVESPTR(PL_curstash);
2755	PL_curstash = CopSTASH(PL_curcop);
2756	}
2757	SAVESPTR(PL_beginav);
2758	PL_beginav = newAV();
2759	SAVEFREESV(PL_beginav);
2760
2761	/* try to compile it */
2762
2763	PL_eval_root = Nullop;
2764	PL_error_count = 0;
2765	PL_curcop = &PL_compiling;
2766	PL_curcop->cop_arybase = 0;
2767	SvREFCNT_dec(PL_rs);
2768	PL_rs = newSVpvn("\n", 1);
2769	if (saveop && saveop->op_flags & OPf_SPECIAL)
2770	PL_in_eval \|= EVAL_KEEPERR;
2771	else
2772	sv_setpv(ERRSV,"");
2773	if (yyparse() \|\| PL_error_count \|\| !PL_eval_root) {
2774	SV **newsp;
2775	I32 gimme;
2776	PERL_CONTEXT *cx;
2777	I32 optype = 0; /* Might be reset by POPEVAL. */
2778	STRLEN n_a;
2779
2780	PL_op = saveop;
2781	if (PL_eval_root) {
2782	op_free(PL_eval_root);
2783	PL_eval_root = Nullop;
2784	}
2785	SP = PL_stack_base + POPMARK; /* pop original mark */
2786	if (!startop) {
2787	POPBLOCK(cx,PL_curpm);
2788	POPEVAL(cx);
2789	pop_return();
2790	}
2791	lex_end();
2792	LEAVE;
2793	if (optype == OP_REQUIRE) {
2794	char* msg = SvPVx(ERRSV, n_a);
2795	DIE(aTHX_ "%sCompilation failed in require",
2796	*msg ? msg : "Unknown error\n");
2797	}
2798	else if (startop) {
2799	char* msg = SvPVx(ERRSV, n_a);
2800
2801	POPBLOCK(cx,PL_curpm);
2802	POPEVAL(cx);
2803	Perl_croak(aTHX_ "%sCompilation failed in regexp",
2804	(*msg ? msg : "Unknown error\n"));
2805	}
2806	SvREFCNT_dec(PL_rs);
2807	PL_rs = SvREFCNT_inc(PL_nrs);
2808	#ifdef USE_THREADS
2809	MUTEX_LOCK(&PL_eval_mutex);
2810	PL_eval_owner = 0;
2811	COND_SIGNAL(&PL_eval_cond);
2812	MUTEX_UNLOCK(&PL_eval_mutex);
2813	#endif /* USE_THREADS */
2814	RETPUSHUNDEF;
2815	}
2816	SvREFCNT_dec(PL_rs);
2817	PL_rs = SvREFCNT_inc(PL_nrs);
2818	CopLINE_set(&PL_compiling, 0);
2819	if (startop) {
2820	*startop = PL_eval_root;
2821	SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2822	CvOUTSIDE(PL_compcv) = Nullcv;
2823	} else
2824	SAVEFREEOP(PL_eval_root);
2825	if (gimme & G_VOID)
2826	scalarvoid(PL_eval_root);
2827	else if (gimme & G_ARRAY)
2828	list(PL_eval_root);
2829	else
2830	scalar(PL_eval_root);
2831
2832	DEBUG_x(dump_eval());
2833
2834	/* Register with debugger: */
2835	if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2836	CV *cv = get_cv("DB::postponed", FALSE);
2837	if (cv) {
2838	dSP;
2839	PUSHMARK(SP);
2840	XPUSHs((SV*)CopFILEGV(&PL_compiling));
2841	PUTBACK;
2842	call_sv((SV*)cv, G_DISCARD);
2843	}
2844	}
2845
2846	/* compiled okay, so do it */
2847
2848	CvDEPTH(PL_compcv) = 1;
2849	SP = PL_stack_base + POPMARK; /* pop original mark */
2850	PL_op = saveop; /* The caller may need it. */
2851	#ifdef USE_THREADS
2852	MUTEX_LOCK(&PL_eval_mutex);
2853	PL_eval_owner = 0;
2854	COND_SIGNAL(&PL_eval_cond);
2855	MUTEX_UNLOCK(&PL_eval_mutex);
2856	#endif /* USE_THREADS */
2857
2858	RETURNOP(PL_eval_start);
2859	}
2860
2861	STATIC PerlIO *
2862	S_doopen_pmc(pTHX_ const char name, const char mode)
2863	{
2864	STRLEN namelen = strlen(name);
2865	PerlIO *fp;
2866
2867	if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2868	SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2869	char *pmc = SvPV_nolen(pmcsv);
2870	Stat_t pmstat;
2871	Stat_t pmcstat;
2872	if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2873	fp = PerlIO_open(name, mode);
2874	}
2875	else {
2876	if (PerlLIO_stat(name, &pmstat) < 0 \|\|
2877	pmstat.st_mtime < pmcstat.st_mtime)
2878	{
2879	fp = PerlIO_open(pmc, mode);
2880	}
2881	else {
2882	fp = PerlIO_open(name, mode);
2883	}
2884	}
2885	SvREFCNT_dec(pmcsv);
2886	}
2887	else {
2888	fp = PerlIO_open(name, mode);
2889	}
2890	return fp;
2891	}
2892
2893	PP(pp_require)
2894	{
2895	djSP;
2896	register PERL_CONTEXT *cx;
2897	SV *sv;
2898	char *name;
2899	STRLEN len;
2900	char *tryname;
2901	SV *namesv = Nullsv;
2902	SV** svp;
2903	I32 gimme = G_SCALAR;
2904	PerlIO *tryrsfp = 0;
2905	STRLEN n_a;
2906	int filter_has_file = 0;
2907	GV *filter_child_proc = 0;
2908	SV *filter_state = 0;
2909	SV *filter_sub = 0;
2910
2911	sv = POPs;
2912	if (SvNIOKp(sv)) {
2913	UV rev, ver, sver;
2914	if (SvPOKp(sv)) { /* require v5.6.1 */
2915	I32 len;
2916	U8 s = (U8)SvPVX(sv);
2917	U8 end = (U8)SvPVX(sv) + SvCUR(sv);
2918	if (s < end) {
2919	rev = utf8_to_uv(s, &len);
2920	s += len;
2921	if (s < end) {
2922	ver = utf8_to_uv(s, &len);
2923	s += len;
2924	if (s < end)
2925	sver = utf8_to_uv(s, &len);
2926	else
2927	sver = 0;
2928	}
2929	else
2930	ver = 0;
2931	}
2932	else
2933	rev = 0;
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	}
2945	else if (!SvPOKp(sv)) { /* require 5.005_03 */
2946	if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2947	+ ((NV)PERL_SUBVERSION/(NV)1000000)
2948	+ 0.00000099 < SvNV(sv))
2949	{
2950	NV nrev = SvNV(sv);
2951	UV rev = (UV)nrev;
2952	NV nver = (nrev - rev) * 1000;
2953	UV ver = (UV)(nver + 0.0009);
2954	NV nsver = (nver - ver) * 1000;
2955	UV sver = (UV)(nsver + 0.0009);
2956
2957	/* help out with the "use 5.6" confusion */
2958	if (sver == 0 && (rev > 5 \|\| (rev == 5 && ver >= 100))) {
2959	DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2960	"this is only v%d.%d.%d, stopped"
2961	" (did you mean v%"UVuf".%"UVuf".0?)",
2962	rev, ver, sver, PERL_REVISION, PERL_VERSION,
2963	PERL_SUBVERSION, rev, ver/100);
2964	}
2965	else {
2966	DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2967	"this is only v%d.%d.%d, stopped",
2968	rev, ver, sver, PERL_REVISION, PERL_VERSION,
2969	PERL_SUBVERSION);
2970	}
2971	}
2972	}
2973	RETPUSHYES;
2974	}
2975	name = SvPV(sv, len);
2976	if (!(name && len > 0 && *name))
2977	DIE(aTHX_ "Null filename used");
2978	TAINT_PROPER("require");
2979	if (PL_op->op_type == OP_REQUIRE &&
2980	(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2981	*svp != &PL_sv_undef)
2982	RETPUSHYES;
2983
2984	/* prepare to compile file */
2985
2986	if (PERL_FILE_IS_ABSOLUTE(name)
2987	\|\| (*name == '.' && (name[1] == '/' \|\|
2988	(name[1] == '.' && name[2] == '/'))))
2989	{
2990	tryname = name;
2991	tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2992	}
2993	else {
2994	AV *ar = GvAVn(PL_incgv);
2995	I32 i;
2996	#ifdef VMS
2997	char *unixname;
2998	if ((unixname = tounixspec(name, Nullch)) != Nullch)
2999	#endif
3000	{
3001	namesv = NEWSV(806, 0);
3002	for (i = 0; i <= AvFILL(ar); i++) {
3003	SV dirsv = av_fetch(ar, i, TRUE);
3004
3005	if (SvROK(dirsv)) {
3006	int count;
3007	SV *loader = dirsv;
3008
3009	if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3010	loader = av_fetch((AV )SvRV(loader), 0, TRUE);
3011	}
3012
3013	Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3014	PTR2UV(SvANY(loader)), name);
3015	tryname = SvPVX(namesv);
3016	tryrsfp = 0;
3017
3018	ENTER;
3019	SAVETMPS;
3020	EXTEND(SP, 2);
3021
3022	PUSHMARK(SP);
3023	PUSHs(dirsv);
3024	PUSHs(sv);
3025	PUTBACK;
3026	count = call_sv(loader, G_ARRAY);
3027	SPAGAIN;
3028
3029	if (count > 0) {
3030	int i = 0;
3031	SV *arg;
3032
3033	SP -= count - 1;
3034	arg = SP[i++];
3035
3036	if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3037	arg = SvRV(arg);
3038	}
3039
3040	if (SvTYPE(arg) == SVt_PVGV) {
3041	IO io = GvIO((GV )arg);
3042
3043	++filter_has_file;
3044
3045	if (io) {
3046	tryrsfp = IoIFP(io);
3047	if (IoTYPE(io) == '\|') {
3048	/* reading from a child process doesn't
3049	nest -- when returning from reading
3050	the inner module, the outer one is
3051	unreadable (closed?) I've tried to
3052	save the gv to manage the lifespan of
3053	the pipe, but this didn't help. XXX */
3054	filter_child_proc = (GV *)arg;
3055	(void)SvREFCNT_inc(filter_child_proc);
3056	}
3057	else {
3058	if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3059	PerlIO_close(IoOFP(io));
3060	}
3061	IoIFP(io) = Nullfp;
3062	IoOFP(io) = Nullfp;
3063	}
3064	}
3065
3066	if (i < count) {
3067	arg = SP[i++];
3068	}
3069	}
3070
3071	if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3072	filter_sub = arg;
3073	(void)SvREFCNT_inc(filter_sub);
3074
3075	if (i < count) {
3076	filter_state = SP[i];
3077	(void)SvREFCNT_inc(filter_state);
3078	}
3079
3080	if (tryrsfp == 0) {
3081	tryrsfp = PerlIO_open("/dev/null",
3082	PERL_SCRIPT_MODE);
3083	}
3084	}
3085	}
3086
3087	PUTBACK;
3088	FREETMPS;
3089	LEAVE;
3090
3091	if (tryrsfp) {
3092	break;
3093	}
3094
3095	filter_has_file = 0;
3096	if (filter_child_proc) {
3097	SvREFCNT_dec(filter_child_proc);
3098	filter_child_proc = 0;
3099	}
3100	if (filter_state) {
3101	SvREFCNT_dec(filter_state);
3102	filter_state = 0;
3103	}
3104	if (filter_sub) {
3105	SvREFCNT_dec(filter_sub);
3106	filter_sub = 0;
3107	}
3108	}
3109	else {
3110	char *dir = SvPVx(dirsv, n_a);
3111	#ifdef VMS
3112	char *unixdir;
3113	if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3114	continue;
3115	sv_setpv(namesv, unixdir);
3116	sv_catpv(namesv, unixname);
3117	#else
3118	Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3119	#endif
3120	TAINT_PROPER("require");
3121	tryname = SvPVX(namesv);
3122	tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3123	if (tryrsfp) {
3124	if (tryname[0] == '.' && tryname[1] == '/')
3125	tryname += 2;
3126	break;
3127	}
3128	}
3129	}
3130	}
3131	}
3132	SAVECOPFILE(&PL_compiling);
3133	CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3134	SvREFCNT_dec(namesv);
3135	if (!tryrsfp) {
3136	if (PL_op->op_type == OP_REQUIRE) {
3137	char *msgstr = name;
3138	if (namesv) { /* did we lookup @INC? */
3139	SV *msg = sv_2mortal(newSVpv(msgstr,0));
3140	SV *dirmsgsv = NEWSV(0, 0);
3141	AV *ar = GvAVn(PL_incgv);
3142	I32 i;
3143	sv_catpvn(msg, " in @INC", 8);
3144	if (instr(SvPVX(msg), ".h "))
3145	sv_catpv(msg, " (change .h to .ph maybe?)");
3146	if (instr(SvPVX(msg), ".ph "))
3147	sv_catpv(msg, " (did you run h2ph?)");
3148	sv_catpv(msg, " (@INC contains:");
3149	for (i = 0; i <= AvFILL(ar); i++) {
3150	char dir = SvPVx(av_fetch(ar, i, TRUE), n_a);
3151	Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3152	sv_catsv(msg, dirmsgsv);
3153	}
3154	sv_catpvn(msg, ")", 1);
3155	SvREFCNT_dec(dirmsgsv);
3156	msgstr = SvPV_nolen(msg);
3157	}
3158	DIE(aTHX_ "Can't locate %s", msgstr);
3159	}
3160
3161	RETPUSHUNDEF;
3162	}
3163	else
3164	SETERRNO(0, SS$_NORMAL);
3165
3166	/* Assume success here to prevent recursive requirement. */
3167	(void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3168	newSVpv(CopFILE(&PL_compiling), 0), 0 );
3169
3170	ENTER;
3171	SAVETMPS;
3172	lex_start(sv_2mortal(newSVpvn("",0)));
3173	SAVEGENERICSV(PL_rsfp_filters);
3174	PL_rsfp_filters = Nullav;
3175
3176	PL_rsfp = tryrsfp;
3177	SAVEHINTS();
3178	PL_hints = 0;
3179	SAVESPTR(PL_compiling.cop_warnings);
3180	if (PL_dowarn & G_WARN_ALL_ON)
3181	PL_compiling.cop_warnings = pWARN_ALL ;
3182	else if (PL_dowarn & G_WARN_ALL_OFF)
3183	PL_compiling.cop_warnings = pWARN_NONE ;
3184	else
3185	PL_compiling.cop_warnings = pWARN_STD ;
3186
3187	if (filter_sub \|\| filter_child_proc) {
3188	SV *datasv = filter_add(run_user_filter, Nullsv);
3189	IoLINES(datasv) = filter_has_file;
3190	IoFMT_GV(datasv) = (GV *)filter_child_proc;
3191	IoTOP_GV(datasv) = (GV *)filter_state;
3192	IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3193	}
3194
3195	/* switch to eval mode */
3196	push_return(PL_op->op_next);
3197	PUSHBLOCK(cx, CXt_EVAL, SP);
3198	PUSHEVAL(cx, name, Nullgv);
3199
3200	SAVECOPLINE(&PL_compiling);
3201	CopLINE_set(&PL_compiling, 0);
3202
3203	PUTBACK;
3204	#ifdef USE_THREADS
3205	MUTEX_LOCK(&PL_eval_mutex);
3206	if (PL_eval_owner && PL_eval_owner != thr)
3207	while (PL_eval_owner)
3208	COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3209	PL_eval_owner = thr;
3210	MUTEX_UNLOCK(&PL_eval_mutex);
3211	#endif /* USE_THREADS */
3212	return DOCATCH(doeval(G_SCALAR, NULL));
3213	}
3214
3215	PP(pp_dofile)
3216	{
3217	return pp_require();
3218	}
3219
3220	PP(pp_entereval)
3221	{
3222	djSP;
3223	register PERL_CONTEXT *cx;
3224	dPOPss;
3225	I32 gimme = GIMME_V, was = PL_sub_generation;
3226	char tbuf[TYPE_DIGITS(long) + 12];
3227	char *tmpbuf = tbuf;
3228	char *safestr;
3229	STRLEN len;
3230	OP *ret;
3231
3232	if (!SvPV(sv,len) \|\| !len)
3233	RETPUSHUNDEF;
3234	TAINT_PROPER("eval");
3235
3236	ENTER;
3237	lex_start(sv);
3238	SAVETMPS;
3239
3240	/* switch to eval mode */
3241
3242	SAVECOPFILE(&PL_compiling);
3243	if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3244	SV *sv = sv_newmortal();
3245	Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3246	(unsigned long)++PL_evalseq,
3247	CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3248	tmpbuf = SvPVX(sv);
3249	}
3250	else
3251	sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3252	CopFILE_set(&PL_compiling, tmpbuf+2);
3253	CopLINE_set(&PL_compiling, 1);
3254	/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3255	deleting the eval's FILEGV from the stash before gv_check() runs
3256	(i.e. before run-time proper). To work around the coredump that
3257	ensues, we always turn GvMULTI_on for any globals that were
3258	introduced within evals. See force_ident(). GSAR 96-10-12 */
3259	safestr = savepv(tmpbuf);
3260	SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3261	SAVEHINTS();
3262	PL_hints = PL_op->op_targ;
3263	SAVESPTR(PL_compiling.cop_warnings);
3264	if (!specialWARN(PL_compiling.cop_warnings)) {
3265	PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3266	SAVEFREESV(PL_compiling.cop_warnings) ;
3267	}
3268
3269	push_return(PL_op->op_next);
3270	PUSHBLOCK(cx, (CXt_EVAL\|CXp_REAL), SP);
3271	PUSHEVAL(cx, 0, Nullgv);
3272
3273	/* prepare to compile string */
3274
3275	if (PERLDB_LINE && PL_curstash != PL_debstash)
3276	save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3277	PUTBACK;
3278	#ifdef USE_THREADS
3279	MUTEX_LOCK(&PL_eval_mutex);
3280	if (PL_eval_owner && PL_eval_owner != thr)
3281	while (PL_eval_owner)
3282	COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3283	PL_eval_owner = thr;
3284	MUTEX_UNLOCK(&PL_eval_mutex);
3285	#endif /* USE_THREADS */
3286	ret = doeval(gimme, NULL);
3287	if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3288	&& ret != PL_op->op_next) { /* Successive compilation. */
3289	strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3290	}
3291	return DOCATCH(ret);
3292	}
3293
3294	PP(pp_leaveeval)
3295	{
3296	djSP;
3297	register SV **mark;
3298	SV **newsp;
3299	PMOP *newpm;
3300	I32 gimme;
3301	register PERL_CONTEXT *cx;
3302	OP *retop;
3303	U8 save_flags = PL_op -> op_flags;
3304	I32 optype;
3305
3306	POPBLOCK(cx,newpm);
3307	POPEVAL(cx);
3308	retop = pop_return();
3309
3310	TAINT_NOT;
3311	if (gimme == G_VOID)
3312	MARK = newsp;
3313	else if (gimme == G_SCALAR) {
3314	MARK = newsp + 1;
3315	if (MARK <= SP) {
3316	if (SvFLAGS(TOPs) & SVs_TEMP)
3317	*MARK = TOPs;
3318	else
3319	*MARK = sv_mortalcopy(TOPs);
3320	}
3321	else {
3322	MEXTEND(mark,0);
3323	*MARK = &PL_sv_undef;
3324	}
3325	SP = MARK;
3326	}
3327	else {
3328	/* in case LEAVE wipes old return values */
3329	for (mark = newsp + 1; mark <= SP; mark++) {
3330	if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3331	mark = sv_mortalcopy(mark);
3332	TAINT_NOT; /* Each item is independent */
3333	}
3334	}
3335	}
3336	PL_curpm = newpm; /* Don't pop $1 et al till now */
3337
3338	if (AvFILLp(PL_comppad_name) >= 0)
3339	free_closures();
3340
3341	#ifdef DEBUGGING
3342	assert(CvDEPTH(PL_compcv) == 1);
3343	#endif
3344	CvDEPTH(PL_compcv) = 0;
3345	lex_end();
3346
3347	if (optype == OP_REQUIRE &&
3348	!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3349	{
3350	/* Unassume the success we assumed earlier. */
3351	SV *nsv = cx->blk_eval.old_namesv;
3352	(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3353	retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3354	/* die_where() did LEAVE, or we won't be here */
3355	}
3356	else {
3357	LEAVE;
3358	if (!(save_flags & OPf_SPECIAL))
3359	sv_setpv(ERRSV,"");
3360	}
3361
3362	RETURNOP(retop);
3363	}
3364
3365	PP(pp_entertry)
3366	{
3367	djSP;
3368	register PERL_CONTEXT *cx;
3369	I32 gimme = GIMME_V;
3370
3371	ENTER;
3372	SAVETMPS;
3373
3374	push_return(cLOGOP->op_other->op_next);
3375	PUSHBLOCK(cx, (CXt_EVAL\|CXp_TRYBLOCK), SP);
3376	PUSHEVAL(cx, 0, 0);
3377	PL_eval_root = PL_op; /* Only needed so that goto works right. */
3378
3379	PL_in_eval = EVAL_INEVAL;
3380	sv_setpv(ERRSV,"");
3381	PUTBACK;
3382	return DOCATCH(PL_op->op_next);
3383	}
3384
3385	PP(pp_leavetry)
3386	{
3387	djSP;
3388	register SV **mark;
3389	SV **newsp;
3390	PMOP *newpm;
3391	I32 gimme;
3392	register PERL_CONTEXT *cx;
3393	I32 optype;
3394
3395	POPBLOCK(cx,newpm);
3396	POPEVAL(cx);
3397	pop_return();
3398
3399	TAINT_NOT;
3400	if (gimme == G_VOID)
3401	SP = newsp;
3402	else if (gimme == G_SCALAR) {
3403	MARK = newsp + 1;
3404	if (MARK <= SP) {
3405	if (SvFLAGS(TOPs) & (SVs_PADTMP\|SVs_TEMP))
3406	*MARK = TOPs;
3407	else
3408	*MARK = sv_mortalcopy(TOPs);
3409	}
3410	else {
3411	MEXTEND(mark,0);
3412	*MARK = &PL_sv_undef;
3413	}
3414	SP = MARK;
3415	}
3416	else {
3417	/* in case LEAVE wipes old return values */
3418	for (mark = newsp + 1; mark <= SP; mark++) {
3419	if (!(SvFLAGS(*mark) & (SVs_PADTMP\|SVs_TEMP))) {
3420	mark = sv_mortalcopy(mark);
3421	TAINT_NOT; /* Each item is independent */
3422	}
3423	}
3424	}
3425	PL_curpm = newpm; /* Don't pop $1 et al till now */
3426
3427	LEAVE;
3428	sv_setpv(ERRSV,"");
3429	RETURN;
3430	}
3431
3432	STATIC void
3433	S_doparseform(pTHX_ SV *sv)
3434	{
3435	STRLEN len;
3436	register char *s = SvPV_force(sv, len);
3437	register char *send = s + len;
3438	register char *base;
3439	register I32 skipspaces = 0;
3440	bool noblank;
3441	bool repeat;
3442	bool postspace = FALSE;
3443	U16 *fops;
3444	register U16 *fpc;
3445	U16 *linepc;
3446	register I32 arg;
3447	bool ischop;
3448
3449	if (len == 0)
3450	Perl_croak(aTHX_ "Null picture in formline");
3451
3452	New(804, fops, (send - s)3+10, U16); / Almost certainly too long... */
3453	fpc = fops;
3454
3455	if (s < send) {
3456	linepc = fpc;
3457	*fpc++ = FF_LINEMARK;
3458	noblank = repeat = FALSE;
3459	base = s;
3460	}
3461
3462	while (s <= send) {
3463	switch (*s++) {
3464	default:
3465	skipspaces = 0;
3466	continue;
3467
3468	case '~':
3469	if (*s == '~') {
3470	repeat = TRUE;
3471	*s = ' ';
3472	}
3473	noblank = TRUE;
3474	s[-1] = ' ';
3475	/* FALL THROUGH */
3476	case ' ': case '\t':
3477	skipspaces++;
3478	continue;
3479
3480	case '\n': case 0:
3481	arg = s - base;
3482	skipspaces++;
3483	arg -= skipspaces;
3484	if (arg) {
3485	if (postspace)
3486	*fpc++ = FF_SPACE;
3487	*fpc++ = FF_LITERAL;
3488	*fpc++ = arg;
3489	}
3490	postspace = FALSE;
3491	if (s <= send)
3492	skipspaces--;
3493	if (skipspaces) {
3494	*fpc++ = FF_SKIP;
3495	*fpc++ = skipspaces;
3496	}
3497	skipspaces = 0;
3498	if (s <= send)
3499	*fpc++ = FF_NEWLINE;
3500	if (noblank) {
3501	*fpc++ = FF_BLANK;
3502	if (repeat)
3503	arg = fpc - linepc + 1;
3504	else
3505	arg = 0;
3506	*fpc++ = arg;
3507	}
3508	if (s < send) {
3509	linepc = fpc;
3510	*fpc++ = FF_LINEMARK;
3511	noblank = repeat = FALSE;
3512	base = s;
3513	}
3514	else
3515	s++;
3516	continue;
3517
3518	case '@':
3519	case '^':
3520	ischop = s[-1] == '^';
3521
3522	if (postspace) {
3523	*fpc++ = FF_SPACE;
3524	postspace = FALSE;
3525	}
3526	arg = (s - base) - 1;
3527	if (arg) {
3528	*fpc++ = FF_LITERAL;
3529	*fpc++ = arg;
3530	}
3531
3532	base = s - 1;
3533	*fpc++ = FF_FETCH;
3534	if (s == '') {
3535	s++;
3536	*fpc++ = 0;
3537	*fpc++ = FF_LINEGLOB;
3538	}
3539	else if (s == '#' \|\| (s == '.' && s[1] == '#')) {
3540	arg = ischop ? 512 : 0;
3541	base = s - 1;
3542	while (*s == '#')
3543	s++;
3544	if (*s == '.') {
3545	char *f;
3546	s++;
3547	f = s;
3548	while (*s == '#')
3549	s++;
3550	arg \|= 256 + (s - f);
3551	}
3552	fpc++ = s - base; / fieldsize for FETCH */
3553	*fpc++ = FF_DECIMAL;
3554	*fpc++ = arg;
3555	}
3556	else {
3557	I32 prespace = 0;
3558	bool ismore = FALSE;
3559
3560	if (*s == '>') {
3561	while (*++s == '>') ;
3562	prespace = FF_SPACE;
3563	}
3564	else if (*s == '\|') {
3565	while (*++s == '\|') ;
3566	prespace = FF_HALFSPACE;
3567	postspace = TRUE;
3568	}
3569	else {
3570	if (*s == '<')
3571	while (*++s == '<') ;
3572	postspace = TRUE;
3573	}
3574	if (*s == '.' && s[1] == '.' && s[2] == '.') {
3575	s += 3;
3576	ismore = TRUE;
3577	}
3578	fpc++ = s - base; / fieldsize for FETCH */
3579
3580	*fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3581
3582	if (prespace)
3583	*fpc++ = prespace;
3584	*fpc++ = FF_ITEM;
3585	if (ismore)
3586	*fpc++ = FF_MORE;
3587	if (ischop)
3588	*fpc++ = FF_CHOP;
3589	}
3590	base = s;
3591	skipspaces = 0;
3592	continue;
3593	}
3594	}
3595	*fpc++ = FF_END;
3596
3597	arg = fpc - fops;
3598	{ /* need to jump to the next word */
3599	int z;
3600	z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3601	SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3602	s = SvPVX(sv) + SvCUR(sv) + z;
3603	}
3604	Copy(fops, s, arg, U16);
3605	Safefree(fops);
3606	sv_magic(sv, Nullsv, 'f', Nullch, 0);
3607	SvCOMPILED_on(sv);
3608	}
3609
3610	/*
3611	* The rest of this file was derived from source code contributed
3612	* by Tom Horsley.
3613	*
3614	* NOTE: this code was derived from Tom Horsley's qsort replacement
3615	* and should not be confused with the original code.
3616	*/
3617
3618	/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3619
3620	Permission granted to distribute under the same terms as perl which are
3621	(briefly):
3622
3623	This program is free software; you can redistribute it and/or modify
3624	it under the terms of either:
3625
3626	a) the GNU General Public License as published by the Free
3627	Software Foundation; either version 1, or (at your option) any
3628	later version, or
3629
3630	b) the "Artistic License" which comes with this Kit.
3631
3632	Details on the perl license can be found in the perl source code which
3633	may be located via the www.perl.com web page.
3634
3635	This is the most wonderfulest possible qsort I can come up with (and
3636	still be mostly portable) My (limited) tests indicate it consistently
3637	does about 20% fewer calls to compare than does the qsort in the Visual
3638	C++ library, other vendors may vary.
3639
3640	Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3641	others I invented myself (or more likely re-invented since they seemed
3642	pretty obvious once I watched the algorithm operate for a while).
3643
3644	Most of this code was written while watching the Marlins sweep the Giants
3645	in the 1997 National League Playoffs - no Braves fans allowed to use this
3646	code (just kidding :-).
3647
3648	I realize that if I wanted to be true to the perl tradition, the only
3649	comment in this file would be something like:
3650
3651	...they shuffled back towards the rear of the line. 'No, not at the
3652	rear!' the slave-driver shouted. 'Three files up. And stay there...
3653
3654	However, I really needed to violate that tradition just so I could keep
3655	track of what happens myself, not to mention some poor fool trying to
3656	understand this years from now :-).
3657	*/
3658
3659	/* ********************************************************** Configuration */
3660
3661	#ifndef QSORT_ORDER_GUESS
3662	#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3663	#endif
3664
3665	/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3666	future processing - a good max upper bound is log base 2 of memory size
3667	(32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3668	safely be smaller than that since the program is taking up some space and
3669	most operating systems only let you grab some subset of contiguous
3670	memory (not to mention that you are normally sorting data larger than
3671	1 byte element size :-).
3672	*/
3673	#ifndef QSORT_MAX_STACK
3674	#define QSORT_MAX_STACK 32
3675	#endif
3676
3677	/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3678	Anything bigger and we use qsort. If you make this too small, the qsort
3679	will probably break (or become less efficient), because it doesn't expect
3680	the middle element of a partition to be the same as the right or left -
3681	you have been warned).
3682	*/
3683	#ifndef QSORT_BREAK_EVEN
3684	#define QSORT_BREAK_EVEN 6
3685	#endif
3686
3687	/* ************************************************************* Data Types */
3688
3689	/* hold left and right index values of a partition waiting to be sorted (the
3690	partition includes both left and right - right is NOT one past the end or
3691	anything like that).
3692	*/
3693	struct partition_stack_entry {
3694	int left;
3695	int right;
3696	#ifdef QSORT_ORDER_GUESS
3697	int qsort_break_even;
3698	#endif
3699	};
3700
3701	/* ******************************************************* Shorthand Macros */
3702
3703	/* Note that these macros will be used from inside the qsort function where
3704	we happen to know that the variable 'elt_size' contains the size of an
3705	array element and the variable 'temp' points to enough space to hold a
3706	temp element and the variable 'array' points to the array being sorted
3707	and 'compare' is the pointer to the compare routine.
3708
3709	Also note that there are very many highly architecture specific ways
3710	these might be sped up, but this is simply the most generally portable
3711	code I could think of.
3712	*/
3713
3714	/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3715	*/
3716	#define qsort_cmp(elt1, elt2) \
3717	((*compare)(aTHXo_ array[elt1], array[elt2]))
3718
3719	#ifdef QSORT_ORDER_GUESS
3720	#define QSORT_NOTICE_SWAP swapped++;
3721	#else
3722	#define QSORT_NOTICE_SWAP
3723	#endif
3724
3725	/* swaps contents of array elements elt1, elt2.
3726	*/
3727	#define qsort_swap(elt1, elt2) \
3728	STMT_START { \
3729	QSORT_NOTICE_SWAP \
3730	temp = array[elt1]; \
3731	array[elt1] = array[elt2]; \
3732	array[elt2] = temp; \
3733	} STMT_END
3734
3735	/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3736	elt3 and elt3 gets elt1.
3737	*/
3738	#define qsort_rotate(elt1, elt2, elt3) \
3739	STMT_START { \
3740	QSORT_NOTICE_SWAP \
3741	temp = array[elt1]; \
3742	array[elt1] = array[elt2]; \
3743	array[elt2] = array[elt3]; \
3744	array[elt3] = temp; \
3745	} STMT_END
3746
3747	/* ************************************************************ Debug stuff */
3748
3749	#ifdef QSORT_DEBUG
3750
3751	static void
3752	break_here()
3753	{
3754	return; /* good place to set a breakpoint */
3755	}
3756
3757	#define qsort_assert(t) (void)( (t) \|\| (break_here(), 0) )
3758
3759	static void
3760	doqsort_all_asserts(
3761	void * array,
3762	size_t num_elts,
3763	size_t elt_size,
3764	int (compare)(const void elt1, const void * elt2),
3765	int pc_left, int pc_right, int u_left, int u_right)
3766	{
3767	int i;
3768
3769	qsort_assert(pc_left <= pc_right);
3770	qsort_assert(u_right < pc_left);
3771	qsort_assert(pc_right < u_left);
3772	for (i = u_right + 1; i < pc_left; ++i) {
3773	qsort_assert(qsort_cmp(i, pc_left) < 0);
3774	}
3775	for (i = pc_left; i < pc_right; ++i) {
3776	qsort_assert(qsort_cmp(i, pc_right) == 0);
3777	}
3778	for (i = pc_right + 1; i < u_left; ++i) {
3779	qsort_assert(qsort_cmp(pc_right, i) < 0);
3780	}
3781	}
3782
3783	#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3784	doqsort_all_asserts(array, num_elts, elt_size, compare, \
3785	PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3786
3787	#else
3788
3789	#define qsort_assert(t) ((void)0)
3790
3791	#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3792
3793	#endif
3794
3795	/* ****************************************************************** qsort */
3796
3797	STATIC void
3798	S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3799	{
3800	register SV * temp;
3801
3802	struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3803	int next_stack_entry = 0;
3804
3805	int part_left;
3806	int part_right;
3807	#ifdef QSORT_ORDER_GUESS
3808	int qsort_break_even;
3809	int swapped;
3810	#endif
3811
3812	/* Make sure we actually have work to do.
3813	*/
3814	if (num_elts <= 1) {
3815	return;
3816	}
3817
3818	/* Setup the initial partition definition and fall into the sorting loop
3819	*/
3820	part_left = 0;
3821	part_right = (int)(num_elts - 1);
3822	#ifdef QSORT_ORDER_GUESS
3823	qsort_break_even = QSORT_BREAK_EVEN;
3824	#else
3825	#define qsort_break_even QSORT_BREAK_EVEN
3826	#endif
3827	for ( ; ; ) {
3828	if ((part_right - part_left) >= qsort_break_even) {
3829	/* OK, this is gonna get hairy, so lets try to document all the
3830	concepts and abbreviations and variables and what they keep
3831	track of:
3832
3833	pc: pivot chunk - the set of array elements we accumulate in the
3834	middle of the partition, all equal in value to the original
3835	pivot element selected. The pc is defined by:
3836
3837	pc_left - the leftmost array index of the pc
3838	pc_right - the rightmost array index of the pc
3839
3840	we start with pc_left == pc_right and only one element
3841	in the pivot chunk (but it can grow during the scan).
3842
3843	u: uncompared elements - the set of elements in the partition
3844	we have not yet compared to the pivot value. There are two
3845	uncompared sets during the scan - one to the left of the pc
3846	and one to the right.
3847
3848	u_right - the rightmost index of the left side's uncompared set
3849	u_left - the leftmost index of the right side's uncompared set
3850
3851	The leftmost index of the left sides's uncompared set
3852	doesn't need its own variable because it is always defined
3853	by the leftmost edge of the whole partition (part_left). The
3854	same goes for the rightmost edge of the right partition
3855	(part_right).
3856
3857	We know there are no uncompared elements on the left once we
3858	get u_right < part_left and no uncompared elements on the
3859	right once u_left > part_right. When both these conditions
3860	are met, we have completed the scan of the partition.
3861
3862	Any elements which are between the pivot chunk and the
3863	uncompared elements should be less than the pivot value on
3864	the left side and greater than the pivot value on the right
3865	side (in fact, the goal of the whole algorithm is to arrange
3866	for that to be true and make the groups of less-than and
3867	greater-then elements into new partitions to sort again).
3868
3869	As you marvel at the complexity of the code and wonder why it
3870	has to be so confusing. Consider some of the things this level
3871	of confusion brings:
3872
3873	Once I do a compare, I squeeze every ounce of juice out of it. I
3874	never do compare calls I don't have to do, and I certainly never
3875	do redundant calls.
3876
3877	I also never swap any elements unless I can prove there is a
3878	good reason. Many sort algorithms will swap a known value with
3879	an uncompared value just to get things in the right place (or
3880	avoid complexity :-), but that uncompared value, once it gets
3881	compared, may then have to be swapped again. A lot of the
3882	complexity of this code is due to the fact that it never swaps
3883	anything except compared values, and it only swaps them when the
3884	compare shows they are out of position.
3885	*/
3886	int pc_left, pc_right;
3887	int u_right, u_left;
3888
3889	int s;
3890
3891	pc_left = ((part_left + part_right) / 2);
3892	pc_right = pc_left;
3893	u_right = pc_left - 1;
3894	u_left = pc_right + 1;
3895
3896	/* Qsort works best when the pivot value is also the median value
3897	in the partition (unfortunately you can't find the median value
3898	without first sorting :-), so to give the algorithm a helping
3899	hand, we pick 3 elements and sort them and use the median value
3900	of that tiny set as the pivot value.
3901
3902	Some versions of qsort like to use the left middle and right as
3903	the 3 elements to sort so they can insure the ends of the
3904	partition will contain values which will stop the scan in the
3905	compare loop, but when you have to call an arbitrarily complex
3906	routine to do a compare, its really better to just keep track of
3907	array index values to know when you hit the edge of the
3908	partition and avoid the extra compare. An even better reason to
3909	avoid using a compare call is the fact that you can drop off the
3910	edge of the array if someone foolishly provides you with an
3911	unstable compare function that doesn't always provide consistent
3912	results.
3913
3914	So, since it is simpler for us to compare the three adjacent
3915	elements in the middle of the partition, those are the ones we
3916	pick here (conveniently pointed at by u_right, pc_left, and
3917	u_left). The values of the left, center, and right elements
3918	are refered to as l c and r in the following comments.
3919	*/
3920
3921	#ifdef QSORT_ORDER_GUESS
3922	swapped = 0;
3923	#endif
3924	s = qsort_cmp(u_right, pc_left);
3925	if (s < 0) {
3926	/* l < c */
3927	s = qsort_cmp(pc_left, u_left);
3928	/* if l < c, c < r - already in order - nothing to do */
3929	if (s == 0) {
3930	/* l < c, c == r - already in order, pc grows */
3931	++pc_right;
3932	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3933	} else if (s > 0) {
3934	/* l < c, c > r - need to know more */
3935	s = qsort_cmp(u_right, u_left);
3936	if (s < 0) {
3937	/* l < c, c > r, l < r - swap c & r to get ordered */
3938	qsort_swap(pc_left, u_left);
3939	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3940	} else if (s == 0) {
3941	/* l < c, c > r, l == r - swap c&r, grow pc */
3942	qsort_swap(pc_left, u_left);
3943	--pc_left;
3944	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3945	} else {
3946	/* l < c, c > r, l > r - make lcr into rlc to get ordered */
3947	qsort_rotate(pc_left, u_right, u_left);
3948	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3949	}
3950	}
3951	} else if (s == 0) {
3952	/* l == c */
3953	s = qsort_cmp(pc_left, u_left);
3954	if (s < 0) {
3955	/* l == c, c < r - already in order, grow pc */
3956	--pc_left;
3957	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3958	} else if (s == 0) {
3959	/* l == c, c == r - already in order, grow pc both ways */
3960	--pc_left;
3961	++pc_right;
3962	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3963	} else {
3964	/* l == c, c > r - swap l & r, grow pc */
3965	qsort_swap(u_right, u_left);
3966	++pc_right;
3967	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3968	}
3969	} else {
3970	/* l > c */
3971	s = qsort_cmp(pc_left, u_left);
3972	if (s < 0) {
3973	/* l > c, c < r - need to know more */
3974	s = qsort_cmp(u_right, u_left);
3975	if (s < 0) {
3976	/* l > c, c < r, l < r - swap l & c to get ordered */
3977	qsort_swap(u_right, pc_left);
3978	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3979	} else if (s == 0) {
3980	/* l > c, c < r, l == r - swap l & c, grow pc */
3981	qsort_swap(u_right, pc_left);
3982	++pc_right;
3983	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3984	} else {
3985	/* l > c, c < r, l > r - rotate lcr into crl to order */
3986	qsort_rotate(u_right, pc_left, u_left);
3987	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3988	}
3989	} else if (s == 0) {
3990	/* l > c, c == r - swap ends, grow pc */
3991	qsort_swap(u_right, u_left);
3992	--pc_left;
3993	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3994	} else {
3995	/* l > c, c > r - swap ends to get in order */
3996	qsort_swap(u_right, u_left);
3997	qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3998	}
3999	}
4000	/* We now know the 3 middle elements have been compared and
4001	arranged in the desired order, so we can shrink the uncompared
4002	sets on both sides
4003	*/
4004	--u_right;
4005	++u_left;
4006	qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4007
4008	/* The above massive nested if was the simple part :-). We now have
4009	the middle 3 elements ordered and we need to scan through the
4010	uncompared sets on either side, swapping elements that are on
4011	the wrong side or simply shuffling equal elements around to get
4012	all equal elements into the pivot chunk.
4013	*/
4014
4015	for ( ; ; ) {
4016	int still_work_on_left;
4017	int still_work_on_right;
4018
4019	/* Scan the uncompared values on the left. If I find a value
4020	equal to the pivot value, move it over so it is adjacent to
4021	the pivot chunk and expand the pivot chunk. If I find a value
4022	less than the pivot value, then just leave it - its already
4023	on the correct side of the partition. If I find a greater
4024	value, then stop the scan.
4025	*/
4026	while ((still_work_on_left = (u_right >= part_left))) {
4027	s = qsort_cmp(u_right, pc_left);
4028	if (s < 0) {
4029	--u_right;
4030	} else if (s == 0) {
4031	--pc_left;
4032	if (pc_left != u_right) {
4033	qsort_swap(u_right, pc_left);
4034	}
4035	--u_right;
4036	} else {
4037	break;
4038	}
4039	qsort_assert(u_right < pc_left);
4040	qsort_assert(pc_left <= pc_right);
4041	qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4042	qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4043	}
4044
4045	/* Do a mirror image scan of uncompared values on the right
4046	*/
4047	while ((still_work_on_right = (u_left <= part_right))) {
4048	s = qsort_cmp(pc_right, u_left);
4049	if (s < 0) {
4050	++u_left;
4051	} else if (s == 0) {
4052	++pc_right;
4053	if (pc_right != u_left) {
4054	qsort_swap(pc_right, u_left);
4055	}
4056	++u_left;
4057	} else {
4058	break;
4059	}
4060	qsort_assert(u_left > pc_right);
4061	qsort_assert(pc_left <= pc_right);
4062	qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4063	qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4064	}
4065
4066	if (still_work_on_left) {
4067	/* I know I have a value on the left side which needs to be
4068	on the right side, but I need to know more to decide
4069	exactly the best thing to do with it.
4070	*/
4071	if (still_work_on_right) {
4072	/* I know I have values on both side which are out of
4073	position. This is a big win because I kill two birds
4074	with one swap (so to speak). I can advance the
4075	uncompared pointers on both sides after swapping both
4076	of them into the right place.
4077	*/
4078	qsort_swap(u_right, u_left);
4079	--u_right;
4080	++u_left;
4081	qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4082	} else {
4083	/* I have an out of position value on the left, but the
4084	right is fully scanned, so I "slide" the pivot chunk
4085	and any less-than values left one to make room for the
4086	greater value over on the right. If the out of position
4087	value is immediately adjacent to the pivot chunk (there
4088	are no less-than values), I can do that with a swap,
4089	otherwise, I have to rotate one of the less than values
4090	into the former position of the out of position value
4091	and the right end of the pivot chunk into the left end
4092	(got all that?).
4093	*/
4094	--pc_left;
4095	if (pc_left == u_right) {
4096	qsort_swap(u_right, pc_right);
4097	qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4098	} else {
4099	qsort_rotate(u_right, pc_left, pc_right);
4100	qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4101	}
4102	--pc_right;
4103	--u_right;
4104	}
4105	} else if (still_work_on_right) {
4106	/* Mirror image of complex case above: I have an out of
4107	position value on the right, but the left is fully
4108	scanned, so I need to shuffle things around to make room
4109	for the right value on the left.
4110	*/
4111	++pc_right;
4112	if (pc_right == u_left) {
4113	qsort_swap(u_left, pc_left);
4114	qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4115	} else {
4116	qsort_rotate(pc_right, pc_left, u_left);
4117	qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4118	}
4119	++pc_left;
4120	++u_left;
4121	} else {
4122	/* No more scanning required on either side of partition,
4123	break out of loop and figure out next set of partitions
4124	*/
4125	break;
4126	}
4127	}
4128
4129	/* The elements in the pivot chunk are now in the right place. They
4130	will never move or be compared again. All I have to do is decide
4131	what to do with the stuff to the left and right of the pivot
4132	chunk.
4133
4134	Notes on the QSORT_ORDER_GUESS ifdef code:
4135
4136	1. If I just built these partitions without swapping any (or
4137	very many) elements, there is a chance that the elements are
4138	already ordered properly (being properly ordered will
4139	certainly result in no swapping, but the converse can't be
4140	proved :-).
4141
4142	2. A (properly written) insertion sort will run faster on
4143	already ordered data than qsort will.
4144
4145	3. Perhaps there is some way to make a good guess about
4146	switching to an insertion sort earlier than partition size 6
4147	(for instance - we could save the partition size on the stack
4148	and increase the size each time we find we didn't swap, thus
4149	switching to insertion sort earlier for partitions with a
4150	history of not swapping).
4151
4152	4. Naturally, if I just switch right away, it will make
4153	artificial benchmarks with pure ascending (or descending)
4154	data look really good, but is that a good reason in general?
4155	Hard to say...
4156	*/
4157
4158	#ifdef QSORT_ORDER_GUESS
4159	if (swapped < 3) {
4160	#if QSORT_ORDER_GUESS == 1
4161	qsort_break_even = (part_right - part_left) + 1;
4162	#endif
4163	#if QSORT_ORDER_GUESS == 2
4164	qsort_break_even *= 2;
4165	#endif
4166	#if QSORT_ORDER_GUESS == 3
4167	int prev_break = qsort_break_even;
4168	qsort_break_even *= qsort_break_even;
4169	if (qsort_break_even < prev_break) {
4170	qsort_break_even = (part_right - part_left) + 1;
4171	}
4172	#endif
4173	} else {
4174	qsort_break_even = QSORT_BREAK_EVEN;
4175	}
4176	#endif
4177
4178	if (part_left < pc_left) {
4179	/* There are elements on the left which need more processing.
4180	Check the right as well before deciding what to do.
4181	*/
4182	if (pc_right < part_right) {
4183	/* We have two partitions to be sorted. Stack the biggest one
4184	and process the smallest one on the next iteration. This
4185	minimizes the stack height by insuring that any additional
4186	stack entries must come from the smallest partition which
4187	(because it is smallest) will have the fewest
4188	opportunities to generate additional stack entries.
4189	*/
4190	if ((part_right - pc_right) > (pc_left - part_left)) {
4191	/* stack the right partition, process the left */
4192	partition_stack[next_stack_entry].left = pc_right + 1;
4193	partition_stack[next_stack_entry].right = part_right;
4194	#ifdef QSORT_ORDER_GUESS
4195	partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4196	#endif
4197	part_right = pc_left - 1;
4198	} else {
4199	/* stack the left partition, process the right */
4200	partition_stack[next_stack_entry].left = part_left;
4201	partition_stack[next_stack_entry].right = pc_left - 1;
4202	#ifdef QSORT_ORDER_GUESS
4203	partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4204	#endif
4205	part_left = pc_right + 1;
4206	}
4207	qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4208	++next_stack_entry;
4209	} else {
4210	/* The elements on the left are the only remaining elements
4211	that need sorting, arrange for them to be processed as the
4212	next partition.
4213	*/
4214	part_right = pc_left - 1;
4215	}
4216	} else if (pc_right < part_right) {
4217	/* There is only one chunk on the right to be sorted, make it
4218	the new partition and loop back around.
4219	*/
4220	part_left = pc_right + 1;
4221	} else {
4222	/* This whole partition wound up in the pivot chunk, so
4223	we need to get a new partition off the stack.
4224	*/
4225	if (next_stack_entry == 0) {
4226	/* the stack is empty - we are done */
4227	break;
4228	}
4229	--next_stack_entry;
4230	part_left = partition_stack[next_stack_entry].left;
4231	part_right = partition_stack[next_stack_entry].right;
4232	#ifdef QSORT_ORDER_GUESS
4233	qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4234	#endif
4235	}
4236	} else {
4237	/* This partition is too small to fool with qsort complexity, just
4238	do an ordinary insertion sort to minimize overhead.
4239	*/
4240	int i;
4241	/* Assume 1st element is in right place already, and start checking
4242	at 2nd element to see where it should be inserted.
4243	*/
4244	for (i = part_left + 1; i <= part_right; ++i) {
4245	int j;
4246	/* Scan (backwards - just in case 'i' is already in right place)
4247	through the elements already sorted to see if the ith element
4248	belongs ahead of one of them.
4249	*/
4250	for (j = i - 1; j >= part_left; --j) {
4251	if (qsort_cmp(i, j) >= 0) {
4252	/* i belongs right after j
4253	*/
4254	break;
4255	}
4256	}
4257	++j;
4258	if (j != i) {
4259	/* Looks like we really need to move some things
4260	*/
4261	int k;
4262	temp = array[i];
4263	for (k = i - 1; k >= j; --k)
4264	array[k + 1] = array[k];
4265	array[j] = temp;
4266	}
4267	}
4268
4269	/* That partition is now sorted, grab the next one, or get out
4270	of the loop if there aren't any more.
4271	*/
4272
4273	if (next_stack_entry == 0) {
4274	/* the stack is empty - we are done */
4275	break;
4276	}
4277	--next_stack_entry;
4278	part_left = partition_stack[next_stack_entry].left;
4279	part_right = partition_stack[next_stack_entry].right;
4280	#ifdef QSORT_ORDER_GUESS
4281	qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4282	#endif
4283	}
4284	}
4285
4286	/* Believe it or not, the array is sorted at this point! */
4287	}
4288
4289
4290	#ifdef PERL_OBJECT
4291	#undef this
4292	#define this pPerl
4293	#include "XSUB.h"
4294	#endif
4295
4296
4297	static I32
4298	sortcv(pTHXo_ SV a, SV b)
4299	{
4300	dTHR;
4301	I32 oldsaveix = PL_savestack_ix;
4302	I32 oldscopeix = PL_scopestack_ix;
4303	I32 result;
4304	GvSV(PL_firstgv) = a;
4305	GvSV(PL_secondgv) = b;
4306	PL_stack_sp = PL_stack_base;
4307	PL_op = PL_sortcop;
4308	CALLRUNOPS(aTHX);
4309	if (PL_stack_sp != PL_stack_base + 1)
4310	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4311	if (!SvNIOKp(*PL_stack_sp))
4312	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4313	result = SvIV(*PL_stack_sp);
4314	while (PL_scopestack_ix > oldscopeix) {
4315	LEAVE;
4316	}
4317	leave_scope(oldsaveix);
4318	return result;
4319	}
4320
4321	static I32
4322	sortcv_stacked(pTHXo_ SV a, SV b)
4323	{
4324	dTHR;
4325	I32 oldsaveix = PL_savestack_ix;
4326	I32 oldscopeix = PL_scopestack_ix;
4327	I32 result;
4328	AV *av;
4329
4330	#ifdef USE_THREADS
4331	av = (AV*)PL_curpad[0];
4332	#else
4333	av = GvAV(PL_defgv);
4334	#endif
4335
4336	if (AvMAX(av) < 1) {
4337	SV** ary = AvALLOC(av);
4338	if (AvARRAY(av) != ary) {
4339	AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4340	SvPVX(av) = (char*)ary;
4341	}
4342	if (AvMAX(av) < 1) {
4343	AvMAX(av) = 1;
4344	Renew(ary,2,SV*);
4345	SvPVX(av) = (char*)ary;
4346	}
4347	}
4348	AvFILLp(av) = 1;
4349
4350	AvARRAY(av)[0] = a;
4351	AvARRAY(av)[1] = b;
4352	PL_stack_sp = PL_stack_base;
4353	PL_op = PL_sortcop;
4354	CALLRUNOPS(aTHX);
4355	if (PL_stack_sp != PL_stack_base + 1)
4356	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4357	if (!SvNIOKp(*PL_stack_sp))
4358	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4359	result = SvIV(*PL_stack_sp);
4360	while (PL_scopestack_ix > oldscopeix) {
4361	LEAVE;
4362	}
4363	leave_scope(oldsaveix);
4364	return result;
4365	}
4366
4367	static I32
4368	sortcv_xsub(pTHXo_ SV a, SV b)
4369	{
4370	dSP;
4371	I32 oldsaveix = PL_savestack_ix;
4372	I32 oldscopeix = PL_scopestack_ix;
4373	I32 result;
4374	CV cv=(CV)PL_sortcop;
4375
4376	SP = PL_stack_base;
4377	PUSHMARK(SP);
4378	EXTEND(SP, 2);
4379	*++SP = a;
4380	*++SP = b;
4381	PUTBACK;
4382	(void)(*CvXSUB(cv))(aTHXo_ cv);
4383	if (PL_stack_sp != PL_stack_base + 1)
4384	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4385	if (!SvNIOKp(*PL_stack_sp))
4386	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4387	result = SvIV(*PL_stack_sp);
4388	while (PL_scopestack_ix > oldscopeix) {
4389	LEAVE;
4390	}
4391	leave_scope(oldsaveix);
4392	return result;
4393	}
4394
4395
4396	static I32
4397	sv_ncmp(pTHXo_ SV a, SV b)
4398	{
4399	NV nv1 = SvNV(a);
4400	NV nv2 = SvNV(b);
4401	return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4402	}
4403
4404	static I32
4405	sv_i_ncmp(pTHXo_ SV a, SV b)
4406	{
4407	IV iv1 = SvIV(a);
4408	IV iv2 = SvIV(b);
4409	return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4410	}
4411	#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4412	*svp = Nullsv; \
4413	if (PL_amagic_generation) { \
4414	if (SvAMAGIC(left)\|\|SvAMAGIC(right))\
4415	*svp = amagic_call(left, \
4416	right, \
4417	CAT2(meth,_amg), \
4418	0); \
4419	} \
4420	} STMT_END
4421
4422	static I32
4423	amagic_ncmp(pTHXo_ register SV a, register SV b)
4424	{
4425	SV *tmpsv;
4426	tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4427	if (tmpsv) {
4428	NV d;
4429
4430	if (SvIOK(tmpsv)) {
4431	I32 i = SvIVX(tmpsv);
4432	if (i > 0)
4433	return 1;
4434	return i? -1 : 0;
4435	}
4436	d = SvNV(tmpsv);
4437	if (d > 0)
4438	return 1;
4439	return d? -1 : 0;
4440	}
4441	return sv_ncmp(aTHXo_ a, b);
4442	}
4443
4444	static I32
4445	amagic_i_ncmp(pTHXo_ register SV a, register SV b)
4446	{
4447	SV *tmpsv;
4448	tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4449	if (tmpsv) {
4450	NV d;
4451
4452	if (SvIOK(tmpsv)) {
4453	I32 i = SvIVX(tmpsv);
4454	if (i > 0)
4455	return 1;
4456	return i? -1 : 0;
4457	}
4458	d = SvNV(tmpsv);
4459	if (d > 0)
4460	return 1;
4461	return d? -1 : 0;
4462	}
4463	return sv_i_ncmp(aTHXo_ a, b);
4464	}
4465
4466	static I32
4467	amagic_cmp(pTHXo_ register SV str1, register SV str2)
4468	{
4469	SV *tmpsv;
4470	tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4471	if (tmpsv) {
4472	NV d;
4473
4474	if (SvIOK(tmpsv)) {
4475	I32 i = SvIVX(tmpsv);
4476	if (i > 0)
4477	return 1;
4478	return i? -1 : 0;
4479	}
4480	d = SvNV(tmpsv);
4481	if (d > 0)
4482	return 1;
4483	return d? -1 : 0;
4484	}
4485	return sv_cmp(str1, str2);
4486	}
4487
4488	static I32
4489	amagic_cmp_locale(pTHXo_ register SV str1, register SV str2)
4490	{
4491	SV *tmpsv;
4492	tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4493	if (tmpsv) {
4494	NV d;
4495
4496	if (SvIOK(tmpsv)) {
4497	I32 i = SvIVX(tmpsv);
4498	if (i > 0)
4499	return 1;
4500	return i? -1 : 0;
4501	}
4502	d = SvNV(tmpsv);
4503	if (d > 0)
4504	return 1;
4505	return d? -1 : 0;
4506	}
4507	return sv_cmp_locale(str1, str2);
4508	}
4509
4510	static I32
4511	run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4512	{
4513	SV *datasv = FILTER_DATA(idx);
4514	int filter_has_file = IoLINES(datasv);
4515	GV filter_child_proc = (GV )IoFMT_GV(datasv);
4516	SV filter_state = (SV )IoTOP_GV(datasv);
4517	SV filter_sub = (SV )IoBOTTOM_GV(datasv);
4518	int len = 0;
4519
4520	/* I was having segfault trouble under Linux 2.2.5 after a
4521	parse error occured. (Had to hack around it with a test
4522	for PL_error_count == 0.) Solaris doesn't segfault --
4523	not sure where the trouble is yet. XXX */
4524
4525	if (filter_has_file) {
4526	len = FILTER_READ(idx+1, buf_sv, maxlen);
4527	}
4528
4529	if (filter_sub && len >= 0) {
4530	djSP;
4531	int count;
4532
4533	ENTER;
4534	SAVE_DEFSV;
4535	SAVETMPS;
4536	EXTEND(SP, 2);
4537
4538	DEFSV = buf_sv;
4539	PUSHMARK(SP);
4540	PUSHs(sv_2mortal(newSViv(maxlen)));
4541	if (filter_state) {
4542	PUSHs(filter_state);
4543	}
4544	PUTBACK;
4545	count = call_sv(filter_sub, G_SCALAR);
4546	SPAGAIN;
4547
4548	if (count > 0) {
4549	SV *out = POPs;
4550	if (SvOK(out)) {
4551	len = SvIV(out);
4552	}
4553	}
4554
4555	PUTBACK;
4556	FREETMPS;
4557	LEAVE;
4558	}
4559
4560	if (len <= 0) {
4561	IoLINES(datasv) = 0;
4562	if (filter_child_proc) {
4563	SvREFCNT_dec(filter_child_proc);
4564	IoFMT_GV(datasv) = Nullgv;
4565	}
4566	if (filter_state) {
4567	SvREFCNT_dec(filter_state);
4568	IoTOP_GV(datasv) = Nullgv;
4569	}
4570	if (filter_sub) {
4571	SvREFCNT_dec(filter_sub);
4572	IoBOTTOM_GV(datasv) = Nullgv;
4573	}
4574	filter_del(run_user_filter);
4575	}
4576
4577	return len;
4578	}
4579
4580	#ifdef PERL_OBJECT
4581
4582	static I32
4583	sv_cmp_locale_static(pTHXo_ register SV str1, register SV str2)
4584	{
4585	return sv_cmp_locale(str1, str2);
4586	}
4587
4588	static I32
4589	sv_cmp_static(pTHXo_ register SV str1, register SV str2)
4590	{
4591	return sv_cmp(str1, str2);
4592	}
4593
4594	#endif /* PERL_OBJECT */

Note: See TracBrowser for help on using the repository browser.

Download in other formats: