Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

pp_ctl.c@ 3296

Visit:

Last change on this file since 3296 was 3181, checked in by bird, 19 years ago
perl 5.8.8
File size: 92.5 KB

Line
1	/* pp_ctl.c
2	*
3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4	* 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
5	*
6	* You may distribute under the terms of either the GNU General Public
7	* License or the Artistic License, as specified in the README file.
8	*
9	*/
10
11	/*
12	* Now far ahead the Road has gone,
13	* And I must follow, if I can,
14	* Pursuing it with eager feet,
15	* Until it joins some larger way
16	* Where many paths and errands meet.
17	* And whither then? I cannot say.
18	*/
19
20	/* This file contains control-oriented pp ("push/pop") functions that
21	* execute the opcodes that make up a perl program. A typical pp function
22	* expects to find its arguments on the stack, and usually pushes its
23	* results onto the stack, hence the 'pp' terminology. Each OP structure
24	* contains a pointer to the relevant pp_foo() function.
25	*
26	* Control-oriented means things like pp_enteriter() and pp_next(), which
27	* alter the flow of control of the program.
28	*/
29
30
31	#include "EXTERN.h"
32	#define PERL_IN_PP_CTL_C
33	#include "perl.h"
34
35	#ifndef WORD_ALIGN
36	#define WORD_ALIGN sizeof(U32)
37	#endif
38
39	#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
40
41	static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
42
43	PP(pp_wantarray)
44	{
45	dSP;
46	I32 cxix;
47	EXTEND(SP, 1);
48
49	cxix = dopoptosub(cxstack_ix);
50	if (cxix < 0)
51	RETPUSHUNDEF;
52
53	switch (cxstack[cxix].blk_gimme) {
54	case G_ARRAY:
55	RETPUSHYES;
56	case G_SCALAR:
57	RETPUSHNO;
58	default:
59	RETPUSHUNDEF;
60	}
61	}
62
63	PP(pp_regcmaybe)
64	{
65	return NORMAL;
66	}
67
68	PP(pp_regcreset)
69	{
70	/* XXXX Should store the old value to allow for tie/overload - and
71	restore in regcomp, where marked with XXXX. */
72	PL_reginterp_cnt = 0;
73	TAINT_NOT;
74	return NORMAL;
75	}
76
77	PP(pp_regcomp)
78	{
79	dSP;
80	register PMOP pm = (PMOP)cLOGOP->op_other;
81	SV *tmpstr;
82	MAGIC mg = Null(MAGIC);
83
84	tmpstr = POPs;
85
86	/* prevent recompiling under /o and ithreads. */
87	#if defined(USE_ITHREADS) \|\| defined(USE_5005THREADS)
88	if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
89	RETURN;
90	#endif
91
92	if (SvROK(tmpstr)) {
93	SV *sv = SvRV(tmpstr);
94	if(SvMAGICAL(sv))
95	mg = mg_find(sv, PERL_MAGIC_qr);
96	}
97	if (mg) {
98	regexp * const re = (regexp *)mg->mg_obj;
99	ReREFCNT_dec(PM_GETRE(pm));
100	PM_SETRE(pm, ReREFCNT_inc(re));
101	}
102	else {
103	STRLEN len;
104	const char *t = SvPV_const(tmpstr, len);
105
106	/* Check against the last compiled regexp. */
107	if (!PM_GETRE(pm) \|\| !PM_GETRE(pm)->precomp \|\|
108	PM_GETRE(pm)->prelen != (I32)len \|\|
109	memNE(PM_GETRE(pm)->precomp, t, len))
110	{
111	if (PM_GETRE(pm)) {
112	ReREFCNT_dec(PM_GETRE(pm));
113	PM_SETRE(pm, Null(REGEXP)); / crucial if regcomp aborts */
114	}
115	if (PL_op->op_flags & OPf_SPECIAL)
116	PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
117
118	pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
119	if (DO_UTF8(tmpstr))
120	pm->op_pmdynflags \|= PMdf_DYN_UTF8;
121	else {
122	pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
123	if (pm->op_pmdynflags & PMdf_UTF8)
124	t = (char)bytes_to_utf8((U8)t, &len);
125	}
126	PM_SETRE(pm, CALLREGCOMP(aTHX_ (char )t, (char )t + len, pm));
127	if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
128	Safefree(t);
129	PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
130	inside tie/overload accessors. */
131	}
132	}
133
134	#ifndef INCOMPLETE_TAINTS
135	if (PL_tainting) {
136	if (PL_tainted)
137	pm->op_pmdynflags \|= PMdf_TAINTED;
138	else
139	pm->op_pmdynflags &= ~PMdf_TAINTED;
140	}
141	#endif
142
143	if (!PM_GETRE(pm)->prelen && PL_curpm)
144	pm = PL_curpm;
145	else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
146	pm->op_pmflags \|= PMf_WHITE;
147	else
148	pm->op_pmflags &= ~PMf_WHITE;
149
150	/* XXX runtime compiled output needs to move to the pad */
151	if (pm->op_pmflags & PMf_KEEP) {
152	pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
153	#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
154	/* XXX can't change the optree at runtime either */
155	cLOGOP->op_first->op_next = PL_op->op_next;
156	#endif
157	}
158	RETURN;
159	}
160
161	PP(pp_substcont)
162	{
163	dSP;
164	register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
165	register PMOP * const pm = (PMOP*) cLOGOP->op_other;
166	register SV * const dstr = cx->sb_dstr;
167	register char *s = cx->sb_s;
168	register char *m = cx->sb_m;
169	char *orig = cx->sb_orig;
170	register REGEXP * const rx = cx->sb_rx;
171	SV *nsv = Nullsv;
172	REGEXP *old = PM_GETRE(pm);
173	if(old != rx) {
174	if(old)
175	ReREFCNT_dec(old);
176	PM_SETRE(pm,rx);
177	}
178
179	rxres_restore(&cx->sb_rxres, rx);
180	RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
181
182	if (cx->sb_iters++) {
183	const I32 saviters = cx->sb_iters;
184	if (cx->sb_iters > cx->sb_maxiters)
185	DIE(aTHX_ "Substitution loop");
186
187	if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
188	cx->sb_rxtainted \|= 2;
189	sv_catsv(dstr, POPs);
190
191	/* Are we done */
192	if (cx->sb_once \|\| !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
193	s == m, cx->sb_targ, NULL,
194	((cx->sb_rflags & REXEC_COPY_STR)
195	? (REXEC_IGNOREPOS\|REXEC_NOT_FIRST)
196	: (REXEC_COPY_STR\|REXEC_IGNOREPOS\|REXEC_NOT_FIRST))))
197	{
198	SV * const targ = cx->sb_targ;
199
200	assert(cx->sb_strend >= s);
201	if(cx->sb_strend > s) {
202	if (DO_UTF8(dstr) && !SvUTF8(targ))
203	sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
204	else
205	sv_catpvn(dstr, s, cx->sb_strend - s);
206	}
207	cx->sb_rxtainted \|= RX_MATCH_TAINTED(rx);
208
209	SvPV_free(targ);
210	SvPV_set(targ, SvPVX(dstr));
211	SvCUR_set(targ, SvCUR(dstr));
212	SvLEN_set(targ, SvLEN(dstr));
213	if (DO_UTF8(dstr))
214	SvUTF8_on(targ);
215	SvPV_set(dstr, (char*)0);
216	sv_free(dstr);
217
218	TAINT_IF(cx->sb_rxtainted & 1);
219	PUSHs(sv_2mortal(newSViv(saviters - 1)));
220
221	(void)SvPOK_only_UTF8(targ);
222	TAINT_IF(cx->sb_rxtainted);
223	SvSETMAGIC(targ);
224	SvTAINT(targ);
225
226	LEAVE_SCOPE(cx->sb_oldsave);
227	ReREFCNT_dec(rx);
228	POPSUBST(cx);
229	RETURNOP(pm->op_next);
230	}
231	cx->sb_iters = saviters;
232	}
233	if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
234	m = s;
235	s = orig;
236	cx->sb_orig = orig = rx->subbeg;
237	s = orig + (m - s);
238	cx->sb_strend = s + (cx->sb_strend - m);
239	}
240	cx->sb_m = m = rx->startp[0] + orig;
241	if (m > s) {
242	if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
243	sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
244	else
245	sv_catpvn(dstr, s, m-s);
246	}
247	cx->sb_s = rx->endp[0] + orig;
248	{ /* Update the pos() information. */
249	SV * const sv = cx->sb_targ;
250	MAGIC *mg;
251	I32 i;
252	if (SvTYPE(sv) < SVt_PVMG)
253	(void)SvUPGRADE(sv, SVt_PVMG);
254	if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
255	sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
256	mg = mg_find(sv, PERL_MAGIC_regex_global);
257	}
258	i = m - orig;
259	if (DO_UTF8(sv))
260	sv_pos_b2u(sv, &i);
261	mg->mg_len = i;
262	}
263	if (old != rx)
264	(void)ReREFCNT_inc(rx);
265	cx->sb_rxtainted \|= RX_MATCH_TAINTED(rx);
266	rxres_save(&cx->sb_rxres, rx);
267	RETURNOP(pm->op_pmreplstart);
268	}
269
270	void
271	Perl_rxres_save(pTHX_ void *rsp, REGEXP rx)
272	{
273	UV p = (UV)*rsp;
274	U32 i;
275
276	if (!p \|\| p[1] < rx->nparens) {
277	i = 6 + rx->nparens * 2;
278	if (!p)
279	Newx(p, i, UV);
280	else
281	Renew(p, i, UV);
282	rsp = (void)p;
283	}
284
285	*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
286	RX_MATCH_COPIED_off(rx);
287
288	*p++ = rx->nparens;
289
290	*p++ = PTR2UV(rx->subbeg);
291	*p++ = (UV)rx->sublen;
292	for (i = 0; i <= rx->nparens; ++i) {
293	*p++ = (UV)rx->startp[i];
294	*p++ = (UV)rx->endp[i];
295	}
296	}
297
298	void
299	Perl_rxres_restore(pTHX_ void *rsp, REGEXP rx)
300	{
301	UV p = (UV)*rsp;
302	U32 i;
303
304	if (RX_MATCH_COPIED(rx))
305	Safefree(rx->subbeg);
306	RX_MATCH_COPIED_set(rx, *p);
307	*p++ = 0;
308
309	rx->nparens = *p++;
310
311	rx->subbeg = INT2PTR(char,p++);
312	rx->sublen = (I32)(*p++);
313	for (i = 0; i <= rx->nparens; ++i) {
314	rx->startp[i] = (I32)(*p++);
315	rx->endp[i] = (I32)(*p++);
316	}
317	}
318
319	void
320	Perl_rxres_free(pTHX_ void **rsp)
321	{
322	UV * const p = (UV)rsp;
323
324	if (p) {
325	#ifdef PERL_POISON
326	void tmp = INT2PTR(char,*p);
327	Safefree(tmp);
328	if (*p)
329	Poison(p, 1, sizeof(p));
330	#else
331	Safefree(INT2PTR(char,p));
332	#endif
333	Safefree(p);
334	rsp = Null(void);
335	}
336	}
337
338	PP(pp_formline)
339	{
340	dSP; dMARK; dORIGMARK;
341	register SV * const tmpForm = *++MARK;
342	register U32 *fpc;
343	register char *t;
344	const char *f;
345	register I32 arg;
346	register SV *sv = Nullsv;
347	const char *item = Nullch;
348	I32 itemsize = 0;
349	I32 fieldsize = 0;
350	I32 lines = 0;
351	bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
352	const char *chophere = Nullch;
353	char *linemark = Nullch;
354	NV value;
355	bool gotsome = FALSE;
356	STRLEN len;
357	const STRLEN fudge = SvPOK(tmpForm)
358	? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
359	bool item_is_utf8 = FALSE;
360	bool targ_is_utf8 = FALSE;
361	SV * nsv = Nullsv;
362	OP * parseres = 0;
363	const char *fmt;
364	bool oneline;
365
366	if (!SvMAGICAL(tmpForm) \|\| !SvCOMPILED(tmpForm)) {
367	if (SvREADONLY(tmpForm)) {
368	SvREADONLY_off(tmpForm);
369	parseres = doparseform(tmpForm);
370	SvREADONLY_on(tmpForm);
371	}
372	else
373	parseres = doparseform(tmpForm);
374	if (parseres)
375	return parseres;
376	}
377	SvPV_force(PL_formtarget, len);
378	if (DO_UTF8(PL_formtarget))
379	targ_is_utf8 = TRUE;
380	t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
381	t += len;
382	f = SvPV_const(tmpForm, len);
383	/* need to jump to the next word */
384	fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
385
386	for (;;) {
387	DEBUG_f( {
388	const char *name = "???";
389	arg = -1;
390	switch (*fpc) {
391	case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
392	case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
393	case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
394	case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
395	case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
396
397	case FF_CHECKNL: name = "CHECKNL"; break;
398	case FF_CHECKCHOP: name = "CHECKCHOP"; break;
399	case FF_SPACE: name = "SPACE"; break;
400	case FF_HALFSPACE: name = "HALFSPACE"; break;
401	case FF_ITEM: name = "ITEM"; break;
402	case FF_CHOP: name = "CHOP"; break;
403	case FF_LINEGLOB: name = "LINEGLOB"; break;
404	case FF_NEWLINE: name = "NEWLINE"; break;
405	case FF_MORE: name = "MORE"; break;
406	case FF_LINEMARK: name = "LINEMARK"; break;
407	case FF_END: name = "END"; break;
408	case FF_0DECIMAL: name = "0DECIMAL"; break;
409	case FF_LINESNGL: name = "LINESNGL"; break;
410	}
411	if (arg >= 0)
412	PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
413	else
414	PerlIO_printf(Perl_debug_log, "%-16s\n", name);
415	} );
416	switch (*fpc++) {
417	case FF_LINEMARK:
418	linemark = t;
419	lines++;
420	gotsome = FALSE;
421	break;
422
423	case FF_LITERAL:
424	arg = *fpc++;
425	if (targ_is_utf8 && !SvUTF8(tmpForm)) {
426	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
427	*t = '\0';
428	sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
429	t = SvEND(PL_formtarget);
430	break;
431	}
432	if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
433	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
434	*t = '\0';
435	sv_utf8_upgrade(PL_formtarget);
436	SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
437	t = SvEND(PL_formtarget);
438	targ_is_utf8 = TRUE;
439	}
440	while (arg--)
441	t++ = f++;
442	break;
443
444	case FF_SKIP:
445	f += *fpc++;
446	break;
447
448	case FF_FETCH:
449	arg = *fpc++;
450	f += arg;
451	fieldsize = arg;
452
453	if (MARK < SP)
454	sv = *++MARK;
455	else {
456	sv = &PL_sv_no;
457	if (ckWARN(WARN_SYNTAX))
458	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
459	}
460	break;
461
462	case FF_CHECKNL:
463	{
464	const char *send;
465	const char *s = item = SvPV_const(sv, len);
466	itemsize = len;
467	if (DO_UTF8(sv)) {
468	itemsize = sv_len_utf8(sv);
469	if (itemsize != (I32)len) {
470	I32 itembytes;
471	if (itemsize > fieldsize) {
472	itemsize = fieldsize;
473	itembytes = itemsize;
474	sv_pos_u2b(sv, &itembytes, 0);
475	}
476	else
477	itembytes = len;
478	send = chophere = s + itembytes;
479	while (s < send) {
480	if (*s & ~31)
481	gotsome = TRUE;
482	else if (*s == '\n')
483	break;
484	s++;
485	}
486	item_is_utf8 = TRUE;
487	itemsize = s - item;
488	sv_pos_b2u(sv, &itemsize);
489	break;
490	}
491	}
492	item_is_utf8 = FALSE;
493	if (itemsize > fieldsize)
494	itemsize = fieldsize;
495	send = chophere = s + itemsize;
496	while (s < send) {
497	if (*s & ~31)
498	gotsome = TRUE;
499	else if (*s == '\n')
500	break;
501	s++;
502	}
503	itemsize = s - item;
504	break;
505	}
506
507	case FF_CHECKCHOP:
508	{
509	const char *s = item = SvPV_const(sv, len);
510	itemsize = len;
511	if (DO_UTF8(sv)) {
512	itemsize = sv_len_utf8(sv);
513	if (itemsize != (I32)len) {
514	I32 itembytes;
515	if (itemsize <= fieldsize) {
516	const char *send = chophere = s + itemsize;
517	while (s < send) {
518	if (*s == '\r') {
519	itemsize = s - item;
520	chophere = s;
521	break;
522	}
523	if (*s++ & ~31)
524	gotsome = TRUE;
525	}
526	}
527	else {
528	const char *send;
529	itemsize = fieldsize;
530	itembytes = itemsize;
531	sv_pos_u2b(sv, &itembytes, 0);
532	send = chophere = s + itembytes;
533	while (s < send \|\| (s == send && isSPACE(*s))) {
534	if (isSPACE(*s)) {
535	if (chopspace)
536	chophere = s;
537	if (*s == '\r')
538	break;
539	}
540	else {
541	if (*s & ~31)
542	gotsome = TRUE;
543	if (strchr(PL_chopset, *s))
544	chophere = s + 1;
545	}
546	s++;
547	}
548	itemsize = chophere - item;
549	sv_pos_b2u(sv, &itemsize);
550	}
551	item_is_utf8 = TRUE;
552	break;
553	}
554	}
555	item_is_utf8 = FALSE;
556	if (itemsize <= fieldsize) {
557	const char *const send = chophere = s + itemsize;
558	while (s < send) {
559	if (*s == '\r') {
560	itemsize = s - item;
561	chophere = s;
562	break;
563	}
564	if (*s++ & ~31)
565	gotsome = TRUE;
566	}
567	}
568	else {
569	const char *send;
570	itemsize = fieldsize;
571	send = chophere = s + itemsize;
572	while (s < send \|\| (s == send && isSPACE(*s))) {
573	if (isSPACE(*s)) {
574	if (chopspace)
575	chophere = s;
576	if (*s == '\r')
577	break;
578	}
579	else {
580	if (*s & ~31)
581	gotsome = TRUE;
582	if (strchr(PL_chopset, *s))
583	chophere = s + 1;
584	}
585	s++;
586	}
587	itemsize = chophere - item;
588	}
589	break;
590	}
591
592	case FF_SPACE:
593	arg = fieldsize - itemsize;
594	if (arg) {
595	fieldsize -= arg;
596	while (arg-- > 0)
597	*t++ = ' ';
598	}
599	break;
600
601	case FF_HALFSPACE:
602	arg = fieldsize - itemsize;
603	if (arg) {
604	arg /= 2;
605	fieldsize -= arg;
606	while (arg-- > 0)
607	*t++ = ' ';
608	}
609	break;
610
611	case FF_ITEM:
612	{
613	const char *s = item;
614	arg = itemsize;
615	if (item_is_utf8) {
616	if (!targ_is_utf8) {
617	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
618	*t = '\0';
619	sv_utf8_upgrade(PL_formtarget);
620	SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
621	t = SvEND(PL_formtarget);
622	targ_is_utf8 = TRUE;
623	}
624	while (arg--) {
625	if (UTF8_IS_CONTINUED(*s)) {
626	STRLEN skip = UTF8SKIP(s);
627	switch (skip) {
628	default:
629	Move(s,t,skip,char);
630	s += skip;
631	t += skip;
632	break;
633	case 7: t++ = s++;
634	case 6: t++ = s++;
635	case 5: t++ = s++;
636	case 4: t++ = s++;
637	case 3: t++ = s++;
638	case 2: t++ = s++;
639	case 1: t++ = s++;
640	}
641	}
642	else {
643	if ( !((t++ = s++) & ~31) )
644	t[-1] = ' ';
645	}
646	}
647	break;
648	}
649	if (targ_is_utf8 && !item_is_utf8) {
650	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
651	*t = '\0';
652	sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
653	for (; t < SvEND(PL_formtarget); t++) {
654	#ifdef EBCDIC
655	const int ch = *t;
656	if (iscntrl(ch))
657	#else
658	if (!(*t & ~31))
659	#endif
660	*t = ' ';
661	}
662	break;
663	}
664	while (arg--) {
665	#ifdef EBCDIC
666	const int ch = t++ = s++;
667	if (iscntrl(ch))
668	#else
669	if ( !((t++ = s++) & ~31) )
670	#endif
671	t[-1] = ' ';
672	}
673	break;
674	}
675
676	case FF_CHOP:
677	{
678	const char *s = chophere;
679	if (chopspace) {
680	while (s && isSPACE(s))
681	s++;
682	}
683	sv_chop(sv,(char *)s);
684	SvSETMAGIC(sv);
685	break;
686	}
687
688	case FF_LINESNGL:
689	chopspace = 0;
690	oneline = TRUE;
691	goto ff_line;
692	case FF_LINEGLOB:
693	oneline = FALSE;
694	ff_line:
695	{
696	const char *s = item = SvPV_const(sv, len);
697	itemsize = len;
698	if ((item_is_utf8 = DO_UTF8(sv)))
699	itemsize = sv_len_utf8(sv);
700	if (itemsize) {
701	bool chopped = FALSE;
702	const char *const send = s + len;
703	gotsome = TRUE;
704	chophere = s + itemsize;
705	while (s < send) {
706	if (*s++ == '\n') {
707	if (oneline) {
708	chopped = TRUE;
709	chophere = s;
710	break;
711	} else {
712	if (s == send) {
713	itemsize--;
714	chopped = TRUE;
715	} else
716	lines++;
717	}
718	}
719	}
720	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
721	if (targ_is_utf8)
722	SvUTF8_on(PL_formtarget);
723	if (oneline) {
724	SvCUR_set(sv, chophere - item);
725	sv_catsv(PL_formtarget, sv);
726	SvCUR_set(sv, itemsize);
727	} else
728	sv_catsv(PL_formtarget, sv);
729	if (chopped)
730	SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
731	SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
732	t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
733	if (item_is_utf8)
734	targ_is_utf8 = TRUE;
735	}
736	break;
737	}
738
739	case FF_0DECIMAL:
740	arg = *fpc++;
741	#if defined(USE_LONG_DOUBLE)
742	fmt = (arg & 256) ? "%#0." PERL_PRIfldbl : "%0." PERL_PRIfldbl;
743	#else
744	fmt = (arg & 256) ? "%#0.f" : "%0.f";
745	#endif
746	goto ff_dec;
747	case FF_DECIMAL:
748	arg = *fpc++;
749	#if defined(USE_LONG_DOUBLE)
750	fmt = (arg & 256) ? "%#." PERL_PRIfldbl : "%." PERL_PRIfldbl;
751	#else
752	fmt = (arg & 256) ? "%#.f" : "%.f";
753	#endif
754	ff_dec:
755	/* If the field is marked with ^ and the value is undefined,
756	blank it out. */
757	if ((arg & 512) && !SvOK(sv)) {
758	arg = fieldsize;
759	while (arg--)
760	*t++ = ' ';
761	break;
762	}
763	gotsome = TRUE;
764	value = SvNV(sv);
765	/* overflow evidence */
766	if (num_overflow(value, fieldsize, arg)) {
767	arg = fieldsize;
768	while (arg--)
769	*t++ = '#';
770	break;
771	}
772	/* Formats aren't yet marked for locales, so assume "yes". */
773	{
774	STORE_NUMERIC_STANDARD_SET_LOCAL();
775	sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
776	RESTORE_NUMERIC_STANDARD();
777	}
778	t += fieldsize;
779	break;
780
781	case FF_NEWLINE:
782	f++;
783	while (t-- > linemark && *t == ' ') ;
784	t++;
785	*t++ = '\n';
786	break;
787
788	case FF_BLANK:
789	arg = *fpc++;
790	if (gotsome) {
791	if (arg) { /* repeat until fields exhausted? */
792	*t = '\0';
793	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
794	lines += FmLINES(PL_formtarget);
795	if (lines == 200) {
796	arg = t - linemark;
797	if (strnEQ(linemark, linemark - arg, arg))
798	DIE(aTHX_ "Runaway format");
799	}
800	if (targ_is_utf8)
801	SvUTF8_on(PL_formtarget);
802	FmLINES(PL_formtarget) = lines;
803	SP = ORIGMARK;
804	RETURNOP(cLISTOP->op_first);
805	}
806	}
807	else {
808	t = linemark;
809	lines--;
810	}
811	break;
812
813	case FF_MORE:
814	{
815	const char *s = chophere;
816	const char *send = item + len;
817	if (chopspace) {
818	while (s && isSPACE(s) && s < send)
819	s++;
820	}
821	if (s < send) {
822	char *s1;
823	arg = fieldsize - itemsize;
824	if (arg) {
825	fieldsize -= arg;
826	while (arg-- > 0)
827	*t++ = ' ';
828	}
829	s1 = t - 3;
830	if (strnEQ(s1," ",3)) {
831	while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
832	s1--;
833	}
834	*s1++ = '.';
835	*s1++ = '.';
836	*s1++ = '.';
837	}
838	break;
839	}
840	case FF_END:
841	*t = '\0';
842	SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
843	if (targ_is_utf8)
844	SvUTF8_on(PL_formtarget);
845	FmLINES(PL_formtarget) += lines;
846	SP = ORIGMARK;
847	RETPUSHYES;
848	}
849	}
850	}
851
852	PP(pp_grepstart)
853	{
854	dSP;
855	SV *src;
856
857	if (PL_stack_base + *PL_markstack_ptr == SP) {
858	(void)POPMARK;
859	if (GIMME_V == G_SCALAR)
860	XPUSHs(sv_2mortal(newSViv(0)));
861	RETURNOP(PL_op->op_next->op_next);
862	}
863	PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
864	pp_pushmark(); /* push dst */
865	pp_pushmark(); /* push src */
866	ENTER; /* enter outer scope */
867
868	SAVETMPS;
869	/* SAVE_DEFSV does not suffice here for USE_5005THREADS */
870	SAVESPTR(DEFSV);
871	ENTER; /* enter inner scope */
872	SAVEVPTR(PL_curpm);
873
874	src = PL_stack_base[*PL_markstack_ptr];
875	SvTEMP_off(src);
876	DEFSV = src;
877
878	PUTBACK;
879	if (PL_op->op_type == OP_MAPSTART)
880	pp_pushmark(); /* push top */
881	return ((LOGOP*)PL_op->op_next)->op_other;
882	}
883
884	PP(pp_mapstart)
885	{
886	DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
887	}
888
889	PP(pp_mapwhile)
890	{
891	dSP;
892	const I32 gimme = GIMME_V;
893	I32 items = (SP - PL_stack_base) - PL_markstack_ptr; / how many new items */
894	I32 count;
895	I32 shift;
896	SV** src;
897	SV** dst;
898
899	/* first, move source pointer to the next item in the source list */
900	++PL_markstack_ptr[-1];
901
902	/* if there are new items, push them into the destination list */
903	if (items && gimme != G_VOID) {
904	/* might need to make room back there first */
905	if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
906	/* XXX this implementation is very pessimal because the stack
907	* is repeatedly extended for every set of items. Is possible
908	* to do this without any stack extension or copying at all
909	* by maintaining a separate list over which the map iterates
910	* (like foreach does). --gsar */
911
912	/* everything in the stack after the destination list moves
913	* towards the end the stack by the amount of room needed */
914	shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
915
916	/* items to shift up (accounting for the moved source pointer) */
917	count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
918
919	/* This optimization is by Ben Tilly and it does
920	* things differently from what Sarathy (gsar)
921	* is describing. The downside of this optimization is
922	* that leaves "holes" (uninitialized and hopefully unused areas)
923	* to the Perl stack, but on the other hand this
924	* shouldn't be a problem. If Sarathy's idea gets
925	* implemented, this optimization should become
926	* irrelevant. --jhi */
927	if (shift < count)
928	shift = count; /* Avoid shifting too often --Ben Tilly */
929
930	EXTEND(SP,shift);
931	src = SP;
932	dst = (SP += shift);
933	PL_markstack_ptr[-1] += shift;
934	*PL_markstack_ptr += shift;
935	while (count--)
936	dst-- = src--;
937	}
938	/* copy the new items down to the destination list */
939	dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
940	if (gimme == G_ARRAY) {
941	while (items-- > 0)
942	*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
943	}
944	else {
945	/* scalar context: we don't care about which values map returns
946	* (we use undef here). And so we certainly don't want to do mortal
947	* copies of meaningless values. */
948	while (items-- > 0) {
949	(void)POPs;
950	*dst-- = &PL_sv_undef;
951	}
952	}
953	}
954	LEAVE; /* exit inner scope */
955
956	/* All done yet? */
957	if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
958
959	(void)POPMARK; /* pop top */
960	LEAVE; /* exit outer scope */
961	(void)POPMARK; /* pop src */
962	items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
963	(void)POPMARK; /* pop dst */
964	SP = PL_stack_base + POPMARK; /* pop original mark */
965	if (gimme == G_SCALAR) {
966	dTARGET;
967	XPUSHi(items);
968	}
969	else if (gimme == G_ARRAY)
970	SP += items;
971	RETURN;
972	}
973	else {
974	SV *src;
975
976	ENTER; /* enter inner scope */
977	SAVEVPTR(PL_curpm);
978
979	/* set $_ to the new source item */
980	src = PL_stack_base[PL_markstack_ptr[-1]];
981	SvTEMP_off(src);
982	DEFSV = src;
983
984	RETURNOP(cLOGOP->op_other);
985	}
986	}
987
988	/* Range stuff. */
989
990	PP(pp_range)
991	{
992	if (GIMME == G_ARRAY)
993	return NORMAL;
994	if (SvTRUEx(PAD_SV(PL_op->op_targ)))
995	return cLOGOP->op_other;
996	else
997	return NORMAL;
998	}
999
1000	PP(pp_flip)
1001	{
1002	dSP;
1003
1004	if (GIMME == G_ARRAY) {
1005	RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1006	}
1007	else {
1008	dTOPss;
1009	SV * const targ = PAD_SV(PL_op->op_targ);
1010	int flip = 0;
1011
1012	if (PL_op->op_private & OPpFLIP_LINENUM) {
1013	if (GvIO(PL_last_in_gv)) {
1014	flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1015	}
1016	else {
1017	GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1018	if (gv && GvSV(gv))
1019	flip = SvIV(sv) == SvIV(GvSV(gv));
1020	}
1021	} else {
1022	flip = SvTRUE(sv);
1023	}
1024	if (flip) {
1025	sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1026	if (PL_op->op_flags & OPf_SPECIAL) {
1027	sv_setiv(targ, 1);
1028	SETs(targ);
1029	RETURN;
1030	}
1031	else {
1032	sv_setiv(targ, 0);
1033	SP--;
1034	RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1035	}
1036	}
1037	sv_setpvn(TARG, "", 0);
1038	SETs(targ);
1039	RETURN;
1040	}
1041	}
1042
1043	/* This code tries to decide if "$left .. $right" should use the
1044	magical string increment, or if the range is numeric (we make
1045	an exception for .."0" [#18165]). AMS 20021031. */
1046
1047	#define RANGE_IS_NUMERIC(left,right) ( \
1048	SvNIOKp(left) \|\| (SvOK(left) && !SvPOKp(left)) \|\| \
1049	SvNIOKp(right) \|\| (SvOK(right) && !SvPOKp(right)) \|\| \
1050	(((!SvOK(left) && SvOK(right)) \|\| ((!SvOK(left) \|\| \
1051	looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1052	&& (!SvOK(right) \|\| looks_like_number(right))))
1053
1054	PP(pp_flop)
1055	{
1056	dSP;
1057
1058	if (GIMME == G_ARRAY) {
1059	dPOPPOPssrl;
1060
1061	if (SvGMAGICAL(left))
1062	mg_get(left);
1063	if (SvGMAGICAL(right))
1064	mg_get(right);
1065
1066	if (RANGE_IS_NUMERIC(left,right)) {
1067	register IV i, j;
1068	IV max;
1069	if ((SvOK(left) && SvNV(left) < IV_MIN) \|\|
1070	(SvOK(right) && SvNV(right) > IV_MAX))
1071	DIE(aTHX_ "Range iterator outside integer range");
1072	i = SvIV(left);
1073	max = SvIV(right);
1074	if (max >= i) {
1075	j = max - i + 1;
1076	EXTEND_MORTAL(j);
1077	EXTEND(SP, j);
1078	}
1079	else
1080	j = 0;
1081	while (j--) {
1082	SV * const sv = sv_2mortal(newSViv(i++));
1083	PUSHs(sv);
1084	}
1085	}
1086	else {
1087	SV * const final = sv_mortalcopy(right);
1088	STRLEN len;
1089	const char * const tmps = SvPV_const(final, len);
1090
1091	SV *sv = sv_mortalcopy(left);
1092	SvPV_force_nolen(sv);
1093	while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1094	XPUSHs(sv);
1095	if (strEQ(SvPVX_const(sv),tmps))
1096	break;
1097	sv = sv_2mortal(newSVsv(sv));
1098	sv_inc(sv);
1099	}
1100	}
1101	}
1102	else {
1103	dTOPss;
1104	SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1105	int flop = 0;
1106	sv_inc(targ);
1107
1108	if (PL_op->op_private & OPpFLIP_LINENUM) {
1109	if (GvIO(PL_last_in_gv)) {
1110	flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1111	}
1112	else {
1113	GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1114	if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1115	}
1116	}
1117	else {
1118	flop = SvTRUE(sv);
1119	}
1120
1121	if (flop) {
1122	sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1123	sv_catpvn(targ, "E0", 2);
1124	}
1125	SETs(targ);
1126	}
1127
1128	RETURN;
1129	}
1130
1131	/* Control. */
1132
1133	static const char * const context_name[] = {
1134	"pseudo-block",
1135	"subroutine",
1136	"eval",
1137	"loop",
1138	"substitution",
1139	"block",
1140	"format"
1141	};
1142
1143	STATIC I32
1144	S_dopoptolabel(pTHX_ const char *label)
1145	{
1146	register I32 i;
1147
1148	for (i = cxstack_ix; i >= 0; i--) {
1149	register const PERL_CONTEXT * const cx = &cxstack[i];
1150	switch (CxTYPE(cx)) {
1151	case CXt_SUBST:
1152	case CXt_SUB:
1153	case CXt_FORMAT:
1154	case CXt_EVAL:
1155	case CXt_NULL:
1156	if (ckWARN(WARN_EXITING))
1157	Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1158	context_name[CxTYPE(cx)], OP_NAME(PL_op));
1159	if (CxTYPE(cx) == CXt_NULL)
1160	return -1;
1161	break;
1162	case CXt_LOOP:
1163	if ( !cx->blk_loop.label \|\| strNE(label, cx->blk_loop.label) ) {
1164	DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1165	(long)i, cx->blk_loop.label));
1166	continue;
1167	}
1168	DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1169	return i;
1170	}
1171	}
1172	return i;
1173	}
1174
1175	I32
1176	Perl_dowantarray(pTHX)
1177	{
1178	const I32 gimme = block_gimme();
1179	return (gimme == G_VOID) ? G_SCALAR : gimme;
1180	}
1181
1182	I32
1183	Perl_block_gimme(pTHX)
1184	{
1185	const I32 cxix = dopoptosub(cxstack_ix);
1186	if (cxix < 0)
1187	return G_VOID;
1188
1189	switch (cxstack[cxix].blk_gimme) {
1190	case G_VOID:
1191	return G_VOID;
1192	case G_SCALAR:
1193	return G_SCALAR;
1194	case G_ARRAY:
1195	return G_ARRAY;
1196	default:
1197	Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1198	/* NOTREACHED */
1199	return 0;
1200	}
1201	}
1202
1203	I32
1204	Perl_is_lvalue_sub(pTHX)
1205	{
1206	const I32 cxix = dopoptosub(cxstack_ix);
1207	assert(cxix >= 0); /* We should only be called from inside subs */
1208
1209	if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1210	return cxstack[cxix].blk_sub.lval;
1211	else
1212	return 0;
1213	}
1214
1215	STATIC I32
1216	S_dopoptosub(pTHX_ I32 startingblock)
1217	{
1218	return dopoptosub_at(cxstack, startingblock);
1219	}
1220
1221	STATIC I32
1222	S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1223	{
1224	I32 i;
1225	for (i = startingblock; i >= 0; i--) {
1226	register const PERL_CONTEXT * const cx = &cxstk[i];
1227	switch (CxTYPE(cx)) {
1228	default:
1229	continue;
1230	case CXt_EVAL:
1231	case CXt_SUB:
1232	case CXt_FORMAT:
1233	DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1234	return i;
1235	}
1236	}
1237	return i;
1238	}
1239
1240	STATIC I32
1241	S_dopoptoeval(pTHX_ I32 startingblock)
1242	{
1243	I32 i;
1244	for (i = startingblock; i >= 0; i--) {
1245	register const PERL_CONTEXT *cx = &cxstack[i];
1246	switch (CxTYPE(cx)) {
1247	default:
1248	continue;
1249	case CXt_EVAL:
1250	DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1251	return i;
1252	}
1253	}
1254	return i;
1255	}
1256
1257	STATIC I32
1258	S_dopoptoloop(pTHX_ I32 startingblock)
1259	{
1260	I32 i;
1261	for (i = startingblock; i >= 0; i--) {
1262	register const PERL_CONTEXT * const cx = &cxstack[i];
1263	switch (CxTYPE(cx)) {
1264	case CXt_SUBST:
1265	case CXt_SUB:
1266	case CXt_FORMAT:
1267	case CXt_EVAL:
1268	case CXt_NULL:
1269	if (ckWARN(WARN_EXITING))
1270	Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1271	context_name[CxTYPE(cx)], OP_NAME(PL_op));
1272	if ((CxTYPE(cx)) == CXt_NULL)
1273	return -1;
1274	break;
1275	case CXt_LOOP:
1276	DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1277	return i;
1278	}
1279	}
1280	return i;
1281	}
1282
1283	void
1284	Perl_dounwind(pTHX_ I32 cxix)
1285	{
1286	I32 optype;
1287
1288	while (cxstack_ix > cxix) {
1289	SV *sv;
1290	register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1291	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1292	(long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1293	/* Note: we don't need to restore the base context info till the end. */
1294	switch (CxTYPE(cx)) {
1295	case CXt_SUBST:
1296	POPSUBST(cx);
1297	continue; /* not break */
1298	case CXt_SUB:
1299	POPSUB(cx,sv);
1300	LEAVESUB(sv);
1301	break;
1302	case CXt_EVAL:
1303	POPEVAL(cx);
1304	break;
1305	case CXt_LOOP:
1306	POPLOOP(cx);
1307	break;
1308	case CXt_NULL:
1309	break;
1310	case CXt_FORMAT:
1311	POPFORMAT(cx);
1312	break;
1313	}
1314	cxstack_ix--;
1315	}
1316	PERL_UNUSED_VAR(optype);
1317	}
1318
1319	void
1320	Perl_qerror(pTHX_ SV *err)
1321	{
1322	if (PL_in_eval)
1323	sv_catsv(ERRSV, err);
1324	else if (PL_errors)
1325	sv_catsv(PL_errors, err);
1326	else
1327	Perl_warn(aTHX_ "%"SVf, err);
1328	++PL_error_count;
1329	}
1330
1331	OP *
1332	Perl_die_where(pTHX_ char *message, STRLEN msglen)
1333	{
1334	if (PL_in_eval) {
1335	I32 cxix;
1336	I32 gimme;
1337
1338	if (message) {
1339	if (PL_in_eval & EVAL_KEEPERR) {
1340	static const char prefix[] = "\t(in cleanup) ";
1341	SV * const err = ERRSV;
1342	const char *e = Nullch;
1343	if (!SvPOK(err))
1344	sv_setpvn(err,"",0);
1345	else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1346	STRLEN len;
1347	e = SvPV_const(err, len);
1348	e += len - msglen;
1349	if (e != message \|\| strNE(e,message))
1350	e = Nullch;
1351	}
1352	if (!e) {
1353	SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1354	sv_catpvn(err, prefix, sizeof(prefix)-1);
1355	sv_catpvn(err, message, msglen);
1356	if (ckWARN(WARN_MISC)) {
1357	const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1358	Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1359	}
1360	}
1361	}
1362	else {
1363	sv_setpvn(ERRSV, message, msglen);
1364	}
1365	}
1366
1367	while ((cxix = dopoptoeval(cxstack_ix)) < 0
1368	&& PL_curstackinfo->si_prev)
1369	{
1370	dounwind(-1);
1371	POPSTACK;
1372	}
1373
1374	if (cxix >= 0) {
1375	I32 optype;
1376	register PERL_CONTEXT *cx;
1377	SV **newsp;
1378
1379	if (cxix < cxstack_ix)
1380	dounwind(cxix);
1381
1382	POPBLOCK(cx,PL_curpm);
1383	if (CxTYPE(cx) != CXt_EVAL) {
1384	if (!message)
1385	message = (char *)SvPVx_const(ERRSV, msglen);
1386	PerlIO_write(Perl_error_log, "panic: die ", 11);
1387	PerlIO_write(Perl_error_log, message, msglen);
1388	my_exit(1);
1389	}
1390	POPEVAL(cx);
1391
1392	if (gimme == G_SCALAR)
1393	*++newsp = &PL_sv_undef;
1394	PL_stack_sp = newsp;
1395
1396	LEAVE;
1397
1398	/* LEAVE could clobber PL_curcop (see save_re_context())
1399	* XXX it might be better to find a way to avoid messing with
1400	* PL_curcop in save_re_context() instead, but this is a more
1401	* minimal fix --GSAR */
1402	PL_curcop = cx->blk_oldcop;
1403
1404	if (optype == OP_REQUIRE) {
1405	const char* msg = SvPVx_nolen_const(ERRSV);
1406	DIE(aTHX_ "%sCompilation failed in require",
1407	*msg ? msg : "Unknown error\n");
1408	}
1409	return pop_return();
1410	}
1411	}
1412	if (!message)
1413	message = (char *)SvPVx_const(ERRSV, msglen);
1414
1415	write_to_stderr(message, msglen);
1416	my_failure_exit();
1417	/* NOTREACHED */
1418	return 0;
1419	}
1420
1421	PP(pp_xor)
1422	{
1423	dSP; dPOPTOPssrl;
1424	if (SvTRUE(left) != SvTRUE(right))
1425	RETSETYES;
1426	else
1427	RETSETNO;
1428	}
1429
1430	PP(pp_andassign)
1431	{
1432	dSP;
1433	if (!SvTRUE(TOPs))
1434	RETURN;
1435	else
1436	RETURNOP(cLOGOP->op_other);
1437	}
1438
1439	PP(pp_orassign)
1440	{
1441	dSP;
1442	if (SvTRUE(TOPs))
1443	RETURN;
1444	else
1445	RETURNOP(cLOGOP->op_other);
1446	}
1447
1448	PP(pp_caller)
1449	{
1450	dSP;
1451	register I32 cxix = dopoptosub(cxstack_ix);
1452	register const PERL_CONTEXT *cx;
1453	register const PERL_CONTEXT *ccstack = cxstack;
1454	const PERL_SI *top_si = PL_curstackinfo;
1455	I32 gimme;
1456	const char *stashname;
1457	I32 count = 0;
1458
1459	if (MAXARG)
1460	count = POPi;
1461
1462	for (;;) {
1463	/* we may be in a higher stacklevel, so dig down deeper */
1464	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1465	top_si = top_si->si_prev;
1466	ccstack = top_si->si_cxstack;
1467	cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1468	}
1469	if (cxix < 0) {
1470	if (GIMME != G_ARRAY) {
1471	EXTEND(SP, 1);
1472	RETPUSHUNDEF;
1473	}
1474	RETURN;
1475	}
1476	/* caller() should not report the automatic calls to &DB::sub */
1477	if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1478	ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1479	count++;
1480	if (!count--)
1481	break;
1482	cxix = dopoptosub_at(ccstack, cxix - 1);
1483	}
1484
1485	cx = &ccstack[cxix];
1486	if (CxTYPE(cx) == CXt_SUB \|\| CxTYPE(cx) == CXt_FORMAT) {
1487	const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1488	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1489	field below is defined for any cx. */
1490	/* caller() should not report the automatic calls to &DB::sub */
1491	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1492	cx = &ccstack[dbcxix];
1493	}
1494
1495	stashname = CopSTASHPV(cx->blk_oldcop);
1496	if (GIMME != G_ARRAY) {
1497	EXTEND(SP, 1);
1498	if (!stashname)
1499	PUSHs(&PL_sv_undef);
1500	else {
1501	dTARGET;
1502	sv_setpv(TARG, stashname);
1503	PUSHs(TARG);
1504	}
1505	RETURN;
1506	}
1507
1508	EXTEND(SP, 10);
1509
1510	if (!stashname)
1511	PUSHs(&PL_sv_undef);
1512	else
1513	PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1514	PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1515	PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));