Context Navigation

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

Visit:

Revision 14545, 177.7 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	/* sv.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	* "I wonder what the Entish is for 'yes' and 'no'," he thought.
12	*/
13
14	#include "EXTERN.h"
15	#define PERL_IN_SV_C
16	#include "perl.h"
17
18	#define FCALL *f
19	#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
20
21	static void do_report_used(pTHXo_ SV *sv);
22	static void do_clean_objs(pTHXo_ SV *sv);
23	#ifndef DISABLE_DESTRUCTOR_KLUDGE
24	static void do_clean_named_objs(pTHXo_ SV *sv);
25	#endif
26	static void do_clean_all(pTHXo_ SV *sv);
27
28	/*
29	* "A time to plant, and a time to uproot what was planted..."
30	*/
31
32	#define plant_SV(p) \
33	STMT_START { \
34	SvANY(p) = (void *)PL_sv_root; \
35	SvFLAGS(p) = SVTYPEMASK; \
36	PL_sv_root = (p); \
37	--PL_sv_count; \
38	} STMT_END
39
40	/* sv_mutex must be held while calling uproot_SV() */
41	#define uproot_SV(p) \
42	STMT_START { \
43	(p) = PL_sv_root; \
44	PL_sv_root = (SV*)SvANY(p); \
45	++PL_sv_count; \
46	} STMT_END
47
48	#define new_SV(p) \
49	STMT_START { \
50	LOCK_SV_MUTEX; \
51	if (PL_sv_root) \
52	uproot_SV(p); \
53	else \
54	(p) = more_sv(); \
55	UNLOCK_SV_MUTEX; \
56	SvANY(p) = 0; \
57	SvREFCNT(p) = 1; \
58	SvFLAGS(p) = 0; \
59	} STMT_END
60
61	#ifdef DEBUGGING
62
63	#define del_SV(p) \
64	STMT_START { \
65	LOCK_SV_MUTEX; \
66	if (PL_debug & 32768) \
67	del_sv(p); \
68	else \
69	plant_SV(p); \
70	UNLOCK_SV_MUTEX; \
71	} STMT_END
72
73	STATIC void
74	S_del_sv(pTHX_ SV *p)
75	{
76	if (PL_debug & 32768) {
77	SV* sva;
78	SV* sv;
79	SV* svend;
80	int ok = 0;
81	for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
82	sv = sva + 1;
83	svend = &sva[SvREFCNT(sva)];
84	if (p >= sv && p < svend)
85	ok = 1;
86	}
87	if (!ok) {
88	if (ckWARN_d(WARN_INTERNAL))
89	Perl_warner(aTHX_ WARN_INTERNAL,
90	"Attempt to free non-arena SV: 0x%"UVxf,
91	PTR2UV(p));
92	return;
93	}
94	}
95	plant_SV(p);
96	}
97
98	#else /* ! DEBUGGING */
99
100	#define del_SV(p) plant_SV(p)
101
102	#endif /* DEBUGGING */
103
104	void
105	Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
106	{
107	SV* sva = (SV*)ptr;
108	register SV* sv;
109	register SV* svend;
110	Zero(ptr, size, char);
111
112	/* The first SV in an arena isn't an SV. */
113	SvANY(sva) = (void ) PL_sv_arenaroot; / ptr to next arena */
114	SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115	SvFLAGS(sva) = flags; /* FAKE if not to be freed */
116
117	PL_sv_arenaroot = sva;
118	PL_sv_root = sva + 1;
119
120	svend = &sva[SvREFCNT(sva) - 1];
121	sv = sva + 1;
122	while (sv < svend) {
123	SvANY(sv) = (void )(SV)(sv + 1);
124	SvFLAGS(sv) = SVTYPEMASK;
125	sv++;
126	}
127	SvANY(sv) = 0;
128	SvFLAGS(sv) = SVTYPEMASK;
129	}
130
131	/* sv_mutex must be held while calling more_sv() */
132	STATIC SV*
133	S_more_sv(pTHX)
134	{
135	register SV* sv;
136
137	if (PL_nice_chunk) {
138	sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139	PL_nice_chunk = Nullch;
140	}
141	else {
142	char chunk; / must use New here to match call to */
143	New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144	sv_add_arena(chunk, 1008, 0);
145	}
146	uproot_SV(sv);
147	return sv;
148	}
149
150	STATIC void
151	S_visit(pTHX_ SVFUNC_t f)
152	{
153	SV* sva;
154	SV* sv;
155	register SV* svend;
156
157	for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158	svend = &sva[SvREFCNT(sva)];
159	for (sv = sva + 1; sv < svend; ++sv) {
160	if (SvTYPE(sv) != SVTYPEMASK)
161	(FCALL)(aTHXo_ sv);
162	}
163	}
164	}
165
166	void
167	Perl_sv_report_used(pTHX)
168	{
169	visit(do_report_used);
170	}
171
172	void
173	Perl_sv_clean_objs(pTHX)
174	{
175	PL_in_clean_objs = TRUE;
176	visit(do_clean_objs);
177	#ifndef DISABLE_DESTRUCTOR_KLUDGE
178	/* some barnacles may yet remain, clinging to typeglobs */
179	visit(do_clean_named_objs);
180	#endif
181	PL_in_clean_objs = FALSE;
182	}
183
184	void
185	Perl_sv_clean_all(pTHX)
186	{
187	PL_in_clean_all = TRUE;
188	visit(do_clean_all);
189	PL_in_clean_all = FALSE;
190	}
191
192	void
193	Perl_sv_free_arenas(pTHX)
194	{
195	SV* sva;
196	SV* svanext;
197
198	/* Free arenas here, but be careful about fake ones. (We assume
199	contiguity of the fake ones with the corresponding real ones.) */
200
201	for (sva = PL_sv_arenaroot; sva; sva = svanext) {
202	svanext = (SV*) SvANY(sva);
203	while (svanext && SvFAKE(svanext))
204	svanext = (SV*) SvANY(svanext);
205
206	if (!SvFAKE(sva))
207	Safefree((void *)sva);
208	}
209
210	if (PL_nice_chunk)
211	Safefree(PL_nice_chunk);
212	PL_nice_chunk = Nullch;
213	PL_nice_chunk_size = 0;
214	PL_sv_arenaroot = 0;
215	PL_sv_root = 0;
216	}
217
218	void
219	Perl_report_uninit(pTHX)
220	{
221	if (PL_op)
222	Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223	" in ", PL_op_desc[PL_op->op_type]);
224	else
225	Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
226	}
227
228	STATIC XPVIV*
229	S_new_xiv(pTHX)
230	{
231	IV* xiv;
232	LOCK_SV_MUTEX;
233	if (!PL_xiv_root)
234	more_xiv();
235	xiv = PL_xiv_root;
236	/*
237	* See comment in more_xiv() -- RAM.
238	*/
239	PL_xiv_root = (IV*)xiv;
240	UNLOCK_SV_MUTEX;
241	return (XPVIV)((char)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
242	}
243
244	STATIC void
245	S_del_xiv(pTHX_ XPVIV *p)
246	{
247	IV* xiv = (IV)((char)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
248	LOCK_SV_MUTEX;
249	(IV*)xiv = PL_xiv_root;
250	PL_xiv_root = xiv;
251	UNLOCK_SV_MUTEX;
252	}
253
254	STATIC void
255	S_more_xiv(pTHX)
256	{
257	register IV* xiv;
258	register IV* xivend;
259	XPV* ptr;
260	New(705, ptr, 1008/sizeof(XPV), XPV);
261	ptr->xpv_pv = (char)PL_xiv_arenaroot; / linked list of xiv arenas */
262	PL_xiv_arenaroot = ptr; /* to keep Purify happy */
263
264	xiv = (IV*) ptr;
265	xivend = &xiv[1008 / sizeof(IV) - 1];
266	xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
267	PL_xiv_root = xiv;
268	while (xiv < xivend) {
269	(IV)xiv = (IV )(xiv + 1);
270	xiv++;
271	}
272	(IV*)xiv = 0;
273	}
274
275	STATIC XPVNV*
276	S_new_xnv(pTHX)
277	{
278	NV* xnv;
279	LOCK_SV_MUTEX;
280	if (!PL_xnv_root)
281	more_xnv();
282	xnv = PL_xnv_root;
283	PL_xnv_root = (NV*)xnv;
284	UNLOCK_SV_MUTEX;
285	return (XPVNV)((char)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
286	}
287
288	STATIC void
289	S_del_xnv(pTHX_ XPVNV *p)
290	{
291	NV* xnv = (NV)((char)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
292	LOCK_SV_MUTEX;
293	(NV*)xnv = PL_xnv_root;
294	PL_xnv_root = xnv;
295	UNLOCK_SV_MUTEX;
296	}
297
298	STATIC void
299	S_more_xnv(pTHX)
300	{
301	register NV* xnv;
302	register NV* xnvend;
303	New(711, xnv, 1008/sizeof(NV), NV);
304	xnvend = &xnv[1008 / sizeof(NV) - 1];
305	xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
306	PL_xnv_root = xnv;
307	while (xnv < xnvend) {
308	(NV)xnv = (NV)(xnv + 1);
309	xnv++;
310	}
311	(NV*)xnv = 0;
312	}
313
314	STATIC XRV*
315	S_new_xrv(pTHX)
316	{
317	XRV* xrv;
318	LOCK_SV_MUTEX;
319	if (!PL_xrv_root)
320	more_xrv();
321	xrv = PL_xrv_root;
322	PL_xrv_root = (XRV*)xrv->xrv_rv;
323	UNLOCK_SV_MUTEX;
324	return xrv;
325	}
326
327	STATIC void
328	S_del_xrv(pTHX_ XRV *p)
329	{
330	LOCK_SV_MUTEX;
331	p->xrv_rv = (SV*)PL_xrv_root;
332	PL_xrv_root = p;
333	UNLOCK_SV_MUTEX;
334	}
335
336	STATIC void
337	S_more_xrv(pTHX)
338	{
339	register XRV* xrv;
340	register XRV* xrvend;
341	New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
342	xrv = PL_xrv_root;
343	xrvend = &xrv[1008 / sizeof(XRV) - 1];
344	while (xrv < xrvend) {
345	xrv->xrv_rv = (SV*)(xrv + 1);
346	xrv++;
347	}
348	xrv->xrv_rv = 0;
349	}
350
351	STATIC XPV*
352	S_new_xpv(pTHX)
353	{
354	XPV* xpv;
355	LOCK_SV_MUTEX;
356	if (!PL_xpv_root)
357	more_xpv();
358	xpv = PL_xpv_root;
359	PL_xpv_root = (XPV*)xpv->xpv_pv;
360	UNLOCK_SV_MUTEX;
361	return xpv;
362	}
363
364	STATIC void
365	S_del_xpv(pTHX_ XPV *p)
366	{
367	LOCK_SV_MUTEX;
368	p->xpv_pv = (char*)PL_xpv_root;
369	PL_xpv_root = p;
370	UNLOCK_SV_MUTEX;
371	}
372
373	STATIC void
374	S_more_xpv(pTHX)
375	{
376	register XPV* xpv;
377	register XPV* xpvend;
378	New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
379	xpv = PL_xpv_root;
380	xpvend = &xpv[1008 / sizeof(XPV) - 1];
381	while (xpv < xpvend) {
382	xpv->xpv_pv = (char*)(xpv + 1);
383	xpv++;
384	}
385	xpv->xpv_pv = 0;
386	}
387
388	STATIC XPVIV*
389	S_new_xpviv(pTHX)
390	{
391	XPVIV* xpviv;
392	LOCK_SV_MUTEX;
393	if (!PL_xpviv_root)
394	more_xpviv();
395	xpviv = PL_xpviv_root;
396	PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
397	UNLOCK_SV_MUTEX;
398	return xpviv;
399	}
400
401	STATIC void
402	S_del_xpviv(pTHX_ XPVIV *p)
403	{
404	LOCK_SV_MUTEX;
405	p->xpv_pv = (char*)PL_xpviv_root;
406	PL_xpviv_root = p;
407	UNLOCK_SV_MUTEX;
408	}
409
410
411	STATIC void
412	S_more_xpviv(pTHX)
413	{
414	register XPVIV* xpviv;
415	register XPVIV* xpvivend;
416	New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
417	xpviv = PL_xpviv_root;
418	xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
419	while (xpviv < xpvivend) {
420	xpviv->xpv_pv = (char*)(xpviv + 1);
421	xpviv++;
422	}
423	xpviv->xpv_pv = 0;
424	}
425
426
427	STATIC XPVNV*
428	S_new_xpvnv(pTHX)
429	{
430	XPVNV* xpvnv;
431	LOCK_SV_MUTEX;
432	if (!PL_xpvnv_root)
433	more_xpvnv();
434	xpvnv = PL_xpvnv_root;
435	PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
436	UNLOCK_SV_MUTEX;
437	return xpvnv;
438	}
439
440	STATIC void
441	S_del_xpvnv(pTHX_ XPVNV *p)
442	{
443	LOCK_SV_MUTEX;
444	p->xpv_pv = (char*)PL_xpvnv_root;
445	PL_xpvnv_root = p;
446	UNLOCK_SV_MUTEX;
447	}
448
449
450	STATIC void
451	S_more_xpvnv(pTHX)
452	{
453	register XPVNV* xpvnv;
454	register XPVNV* xpvnvend;
455	New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
456	xpvnv = PL_xpvnv_root;
457	xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
458	while (xpvnv < xpvnvend) {
459	xpvnv->xpv_pv = (char*)(xpvnv + 1);
460	xpvnv++;
461	}
462	xpvnv->xpv_pv = 0;
463	}
464
465
466
467	STATIC XPVCV*
468	S_new_xpvcv(pTHX)
469	{
470	XPVCV* xpvcv;
471	LOCK_SV_MUTEX;
472	if (!PL_xpvcv_root)
473	more_xpvcv();
474	xpvcv = PL_xpvcv_root;
475	PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
476	UNLOCK_SV_MUTEX;
477	return xpvcv;
478	}
479
480	STATIC void
481	S_del_xpvcv(pTHX_ XPVCV *p)
482	{
483	LOCK_SV_MUTEX;
484	p->xpv_pv = (char*)PL_xpvcv_root;
485	PL_xpvcv_root = p;
486	UNLOCK_SV_MUTEX;
487	}
488
489
490	STATIC void
491	S_more_xpvcv(pTHX)
492	{
493	register XPVCV* xpvcv;
494	register XPVCV* xpvcvend;
495	New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
496	xpvcv = PL_xpvcv_root;
497	xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
498	while (xpvcv < xpvcvend) {
499	xpvcv->xpv_pv = (char*)(xpvcv + 1);
500	xpvcv++;
501	}
502	xpvcv->xpv_pv = 0;
503	}
504
505
506
507	STATIC XPVAV*
508	S_new_xpvav(pTHX)
509	{
510	XPVAV* xpvav;
511	LOCK_SV_MUTEX;
512	if (!PL_xpvav_root)
513	more_xpvav();
514	xpvav = PL_xpvav_root;
515	PL_xpvav_root = (XPVAV*)xpvav->xav_array;
516	UNLOCK_SV_MUTEX;
517	return xpvav;
518	}
519
520	STATIC void
521	S_del_xpvav(pTHX_ XPVAV *p)
522	{
523	LOCK_SV_MUTEX;
524	p->xav_array = (char*)PL_xpvav_root;
525	PL_xpvav_root = p;
526	UNLOCK_SV_MUTEX;
527	}
528
529
530	STATIC void
531	S_more_xpvav(pTHX)
532	{
533	register XPVAV* xpvav;
534	register XPVAV* xpvavend;
535	New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
536	xpvav = PL_xpvav_root;
537	xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
538	while (xpvav < xpvavend) {
539	xpvav->xav_array = (char*)(xpvav + 1);
540	xpvav++;
541	}
542	xpvav->xav_array = 0;
543	}
544
545
546
547	STATIC XPVHV*
548	S_new_xpvhv(pTHX)
549	{
550	XPVHV* xpvhv;
551	LOCK_SV_MUTEX;
552	if (!PL_xpvhv_root)
553	more_xpvhv();
554	xpvhv = PL_xpvhv_root;
555	PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
556	UNLOCK_SV_MUTEX;
557	return xpvhv;
558	}
559
560	STATIC void
561	S_del_xpvhv(pTHX_ XPVHV *p)
562	{
563	LOCK_SV_MUTEX;
564	p->xhv_array = (char*)PL_xpvhv_root;
565	PL_xpvhv_root = p;
566	UNLOCK_SV_MUTEX;
567	}
568
569
570	STATIC void
571	S_more_xpvhv(pTHX)
572	{
573	register XPVHV* xpvhv;
574	register XPVHV* xpvhvend;
575	New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
576	xpvhv = PL_xpvhv_root;
577	xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
578	while (xpvhv < xpvhvend) {
579	xpvhv->xhv_array = (char*)(xpvhv + 1);
580	xpvhv++;
581	}
582	xpvhv->xhv_array = 0;
583	}
584
585
586	STATIC XPVMG*
587	S_new_xpvmg(pTHX)
588	{
589	XPVMG* xpvmg;
590	LOCK_SV_MUTEX;
591	if (!PL_xpvmg_root)
592	more_xpvmg();
593	xpvmg = PL_xpvmg_root;
594	PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
595	UNLOCK_SV_MUTEX;
596	return xpvmg;
597	}
598
599	STATIC void
600	S_del_xpvmg(pTHX_ XPVMG *p)
601	{
602	LOCK_SV_MUTEX;
603	p->xpv_pv = (char*)PL_xpvmg_root;
604	PL_xpvmg_root = p;
605	UNLOCK_SV_MUTEX;
606	}
607
608
609	STATIC void
610	S_more_xpvmg(pTHX)
611	{
612	register XPVMG* xpvmg;
613	register XPVMG* xpvmgend;
614	New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
615	xpvmg = PL_xpvmg_root;
616	xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
617	while (xpvmg < xpvmgend) {
618	xpvmg->xpv_pv = (char*)(xpvmg + 1);
619	xpvmg++;
620	}
621	xpvmg->xpv_pv = 0;
622	}
623
624
625
626	STATIC XPVLV*
627	S_new_xpvlv(pTHX)
628	{
629	XPVLV* xpvlv;
630	LOCK_SV_MUTEX;
631	if (!PL_xpvlv_root)
632	more_xpvlv();
633	xpvlv = PL_xpvlv_root;
634	PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
635	UNLOCK_SV_MUTEX;
636	return xpvlv;
637	}
638
639	STATIC void
640	S_del_xpvlv(pTHX_ XPVLV *p)
641	{
642	LOCK_SV_MUTEX;
643	p->xpv_pv = (char*)PL_xpvlv_root;
644	PL_xpvlv_root = p;
645	UNLOCK_SV_MUTEX;
646	}
647
648
649	STATIC void
650	S_more_xpvlv(pTHX)
651	{
652	register XPVLV* xpvlv;
653	register XPVLV* xpvlvend;
654	New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
655	xpvlv = PL_xpvlv_root;
656	xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
657	while (xpvlv < xpvlvend) {
658	xpvlv->xpv_pv = (char*)(xpvlv + 1);
659	xpvlv++;
660	}
661	xpvlv->xpv_pv = 0;
662	}
663
664
665	STATIC XPVBM*
666	S_new_xpvbm(pTHX)
667	{
668	XPVBM* xpvbm;
669	LOCK_SV_MUTEX;
670	if (!PL_xpvbm_root)
671	more_xpvbm();
672	xpvbm = PL_xpvbm_root;
673	PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
674	UNLOCK_SV_MUTEX;
675	return xpvbm;
676	}
677
678	STATIC void
679	S_del_xpvbm(pTHX_ XPVBM *p)
680	{
681	LOCK_SV_MUTEX;
682	p->xpv_pv = (char*)PL_xpvbm_root;
683	PL_xpvbm_root = p;
684	UNLOCK_SV_MUTEX;
685	}
686
687
688	STATIC void
689	S_more_xpvbm(pTHX)
690	{
691	register XPVBM* xpvbm;
692	register XPVBM* xpvbmend;
693	New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
694	xpvbm = PL_xpvbm_root;
695	xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
696	while (xpvbm < xpvbmend) {
697	xpvbm->xpv_pv = (char*)(xpvbm + 1);
698	xpvbm++;
699	}
700	xpvbm->xpv_pv = 0;
701	}
702
703	#ifdef LEAKTEST
704	# define my_safemalloc(s) (void*)safexmalloc(717,s)
705	# define my_safefree(p) safexfree((char*)p)
706	#else
707	# define my_safemalloc(s) (void*)safemalloc(s)
708	# define my_safefree(p) safefree((char*)p)
709	#endif
710
711	#ifdef PURIFY
712
713	#define new_XIV() my_safemalloc(sizeof(XPVIV))
714	#define del_XIV(p) my_safefree(p)
715
716	#define new_XNV() my_safemalloc(sizeof(XPVNV))
717	#define del_XNV(p) my_safefree(p)
718
719	#define new_XRV() my_safemalloc(sizeof(XRV))
720	#define del_XRV(p) my_safefree(p)
721
722	#define new_XPV() my_safemalloc(sizeof(XPV))
723	#define del_XPV(p) my_safefree(p)
724
725	#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
726	#define del_XPVIV(p) my_safefree(p)
727
728	#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
729	#define del_XPVNV(p) my_safefree(p)
730
731	#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
732	#define del_XPVCV(p) my_safefree(p)
733
734	#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
735	#define del_XPVAV(p) my_safefree(p)
736
737	#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
738	#define del_XPVHV(p) my_safefree(p)
739
740	#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
741	#define del_XPVMG(p) my_safefree(p)
742
743	#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
744	#define del_XPVLV(p) my_safefree(p)
745
746	#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
747	#define del_XPVBM(p) my_safefree(p)
748
749	#else /* !PURIFY */
750
751	#define new_XIV() (void*)new_xiv()
752	#define del_XIV(p) del_xiv((XPVIV*) p)
753
754	#define new_XNV() (void*)new_xnv()
755	#define del_XNV(p) del_xnv((XPVNV*) p)
756
757	#define new_XRV() (void*)new_xrv()
758	#define del_XRV(p) del_xrv((XRV*) p)
759
760	#define new_XPV() (void*)new_xpv()
761	#define del_XPV(p) del_xpv((XPV *)p)
762
763	#define new_XPVIV() (void*)new_xpviv()
764	#define del_XPVIV(p) del_xpviv((XPVIV *)p)
765
766	#define new_XPVNV() (void*)new_xpvnv()
767	#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
768
769	#define new_XPVCV() (void*)new_xpvcv()
770	#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
771
772	#define new_XPVAV() (void*)new_xpvav()
773	#define del_XPVAV(p) del_xpvav((XPVAV *)p)
774
775	#define new_XPVHV() (void*)new_xpvhv()
776	#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
777
778	#define new_XPVMG() (void*)new_xpvmg()
779	#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
780
781	#define new_XPVLV() (void*)new_xpvlv()
782	#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
783
784	#define new_XPVBM() (void*)new_xpvbm()
785	#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
786
787	#endif /* PURIFY */
788
789	#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
790	#define del_XPVGV(p) my_safefree(p)
791
792	#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
793	#define del_XPVFM(p) my_safefree(p)
794
795	#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
796	#define del_XPVIO(p) my_safefree(p)
797
798	/*
799	=for apidoc sv_upgrade
800
801	Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
802	C<svtype>.
803
804	=cut
805	*/
806
807	bool
808	Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
809	{
810	char* pv;
811	U32 cur;
812	U32 len;
813	IV iv;
814	NV nv;
815	MAGIC* magic;
816	HV* stash;
817
818	if (SvTYPE(sv) == mt)
819	return TRUE;
820
821	if (mt < SVt_PVIV)
822	(void)SvOOK_off(sv);
823
824	switch (SvTYPE(sv)) {
825	case SVt_NULL:
826	pv = 0;
827	cur = 0;
828	len = 0;
829	iv = 0;
830	nv = 0.0;
831	magic = 0;
832	stash = 0;
833	break;
834	case SVt_IV:
835	pv = 0;
836	cur = 0;
837	len = 0;
838	iv = SvIVX(sv);
839	nv = (NV)SvIVX(sv);
840	del_XIV(SvANY(sv));
841	magic = 0;
842	stash = 0;
843	if (mt == SVt_NV)
844	mt = SVt_PVNV;
845	else if (mt < SVt_PVIV)
846	mt = SVt_PVIV;
847	break;
848	case SVt_NV:
849	pv = 0;
850	cur = 0;
851	len = 0;
852	nv = SvNVX(sv);
853	iv = I_V(nv);
854	magic = 0;
855	stash = 0;
856	del_XNV(SvANY(sv));
857	SvANY(sv) = 0;
858	if (mt < SVt_PVNV)
859	mt = SVt_PVNV;
860	break;
861	case SVt_RV:
862	pv = (char*)SvRV(sv);
863	cur = 0;
864	len = 0;
865	iv = PTR2IV(pv);
866	nv = PTR2NV(pv);
867	del_XRV(SvANY(sv));
868	magic = 0;
869	stash = 0;
870	break;
871	case SVt_PV:
872	pv = SvPVX(sv);
873	cur = SvCUR(sv);
874	len = SvLEN(sv);
875	iv = 0;
876	nv = 0.0;
877	magic = 0;
878	stash = 0;
879	del_XPV(SvANY(sv));
880	if (mt <= SVt_IV)
881	mt = SVt_PVIV;
882	else if (mt == SVt_NV)
883	mt = SVt_PVNV;
884	break;
885	case SVt_PVIV:
886	pv = SvPVX(sv);
887	cur = SvCUR(sv);
888	len = SvLEN(sv);
889	iv = SvIVX(sv);
890	nv = 0.0;
891	magic = 0;
892	stash = 0;
893	del_XPVIV(SvANY(sv));
894	break;
895	case SVt_PVNV:
896	pv = SvPVX(sv);
897	cur = SvCUR(sv);
898	len = SvLEN(sv);
899	iv = SvIVX(sv);
900	nv = SvNVX(sv);
901	magic = 0;
902	stash = 0;
903	del_XPVNV(SvANY(sv));
904	break;
905	case SVt_PVMG:
906	pv = SvPVX(sv);
907	cur = SvCUR(sv);
908	len = SvLEN(sv);
909	iv = SvIVX(sv);
910	nv = SvNVX(sv);
911	magic = SvMAGIC(sv);
912	stash = SvSTASH(sv);
913	del_XPVMG(SvANY(sv));
914	break;
915	default:
916	Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
917	}
918
919	switch (mt) {
920	case SVt_NULL:
921	Perl_croak(aTHX_ "Can't upgrade to undef");
922	case SVt_IV:
923	SvANY(sv) = new_XIV();
924	SvIVX(sv) = iv;
925	break;
926	case SVt_NV:
927	SvANY(sv) = new_XNV();
928	SvNVX(sv) = nv;
929	break;
930	case SVt_RV:
931	SvANY(sv) = new_XRV();
932	SvRV(sv) = (SV*)pv;
933	break;
934	case SVt_PV:
935	SvANY(sv) = new_XPV();
936	SvPVX(sv) = pv;
937	SvCUR(sv) = cur;
938	SvLEN(sv) = len;
939	break;
940	case SVt_PVIV:
941	SvANY(sv) = new_XPVIV();
942	SvPVX(sv) = pv;
943	SvCUR(sv) = cur;
944	SvLEN(sv) = len;
945	SvIVX(sv) = iv;
946	if (SvNIOK(sv))
947	(void)SvIOK_on(sv);
948	SvNOK_off(sv);
949	break;
950	case SVt_PVNV:
951	SvANY(sv) = new_XPVNV();
952	SvPVX(sv) = pv;
953	SvCUR(sv) = cur;
954	SvLEN(sv) = len;
955	SvIVX(sv) = iv;
956	SvNVX(sv) = nv;
957	break;
958	case SVt_PVMG:
959	SvANY(sv) = new_XPVMG();
960	SvPVX(sv) = pv;
961	SvCUR(sv) = cur;
962	SvLEN(sv) = len;
963	SvIVX(sv) = iv;
964	SvNVX(sv) = nv;
965	SvMAGIC(sv) = magic;
966	SvSTASH(sv) = stash;
967	break;
968	case SVt_PVLV:
969	SvANY(sv) = new_XPVLV();
970	SvPVX(sv) = pv;
971	SvCUR(sv) = cur;
972	SvLEN(sv) = len;
973	SvIVX(sv) = iv;
974	SvNVX(sv) = nv;
975	SvMAGIC(sv) = magic;
976	SvSTASH(sv) = stash;
977	LvTARGOFF(sv) = 0;
978	LvTARGLEN(sv) = 0;
979	LvTARG(sv) = 0;
980	LvTYPE(sv) = 0;
981	break;
982	case SVt_PVAV:
983	SvANY(sv) = new_XPVAV();
984	if (pv)
985	Safefree(pv);
986	SvPVX(sv) = 0;
987	AvMAX(sv) = -1;
988	AvFILLp(sv) = -1;
989	SvIVX(sv) = 0;
990	SvNVX(sv) = 0.0;
991	SvMAGIC(sv) = magic;
992	SvSTASH(sv) = stash;
993	AvALLOC(sv) = 0;
994	AvARYLEN(sv) = 0;
995	AvFLAGS(sv) = 0;
996	break;
997	case SVt_PVHV:
998	SvANY(sv) = new_XPVHV();
999	if (pv)
1000	Safefree(pv);
1001	SvPVX(sv) = 0;
1002	HvFILL(sv) = 0;
1003	HvMAX(sv) = 0;
1004	HvKEYS(sv) = 0;
1005	SvNVX(sv) = 0.0;
1006	SvMAGIC(sv) = magic;
1007	SvSTASH(sv) = stash;
1008	HvRITER(sv) = 0;
1009	HvEITER(sv) = 0;
1010	HvPMROOT(sv) = 0;
1011	HvNAME(sv) = 0;
1012	break;
1013	case SVt_PVCV:
1014	SvANY(sv) = new_XPVCV();
1015	Zero(SvANY(sv), 1, XPVCV);
1016	SvPVX(sv) = pv;
1017	SvCUR(sv) = cur;
1018	SvLEN(sv) = len;
1019	SvIVX(sv) = iv;
1020	SvNVX(sv) = nv;
1021	SvMAGIC(sv) = magic;
1022	SvSTASH(sv) = stash;
1023	break;
1024	case SVt_PVGV:
1025	SvANY(sv) = new_XPVGV();
1026	SvPVX(sv) = pv;
1027	SvCUR(sv) = cur;
1028	SvLEN(sv) = len;
1029	SvIVX(sv) = iv;
1030	SvNVX(sv) = nv;
1031	SvMAGIC(sv) = magic;
1032	SvSTASH(sv) = stash;
1033	GvGP(sv) = 0;
1034	GvNAME(sv) = 0;
1035	GvNAMELEN(sv) = 0;
1036	GvSTASH(sv) = 0;
1037	GvFLAGS(sv) = 0;
1038	break;
1039	case SVt_PVBM:
1040	SvANY(sv) = new_XPVBM();
1041	SvPVX(sv) = pv;
1042	SvCUR(sv) = cur;
1043	SvLEN(sv) = len;
1044	SvIVX(sv) = iv;
1045	SvNVX(sv) = nv;
1046	SvMAGIC(sv) = magic;
1047	SvSTASH(sv) = stash;
1048	BmRARE(sv) = 0;
1049	BmUSEFUL(sv) = 0;
1050	BmPREVIOUS(sv) = 0;
1051	break;
1052	case SVt_PVFM:
1053	SvANY(sv) = new_XPVFM();
1054	Zero(SvANY(sv), 1, XPVFM);
1055	SvPVX(sv) = pv;
1056	SvCUR(sv) = cur;
1057	SvLEN(sv) = len;
1058	SvIVX(sv) = iv;
1059	SvNVX(sv) = nv;
1060	SvMAGIC(sv) = magic;
1061	SvSTASH(sv) = stash;
1062	break;
1063	case SVt_PVIO:
1064	SvANY(sv) = new_XPVIO();
1065	Zero(SvANY(sv), 1, XPVIO);
1066	SvPVX(sv) = pv;
1067	SvCUR(sv) = cur;
1068	SvLEN(sv) = len;
1069	SvIVX(sv) = iv;
1070	SvNVX(sv) = nv;
1071	SvMAGIC(sv) = magic;
1072	SvSTASH(sv) = stash;
1073	IoPAGE_LEN(sv) = 60;
1074	break;
1075	}
1076	SvFLAGS(sv) &= ~SVTYPEMASK;
1077	SvFLAGS(sv) \|= mt;
1078	return TRUE;
1079	}
1080
1081	int
1082	Perl_sv_backoff(pTHX_ register SV *sv)
1083	{
1084	assert(SvOOK(sv));
1085	if (SvIVX(sv)) {
1086	char *s = SvPVX(sv);
1087	SvLEN(sv) += SvIVX(sv);
1088	SvPVX(sv) -= SvIVX(sv);
1089	SvIV_set(sv, 0);
1090	Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1091	}
1092	SvFLAGS(sv) &= ~SVf_OOK;
1093	return 0;
1094	}
1095
1096	/*
1097	=for apidoc sv_grow
1098
1099	Expands the character buffer in the SV. This will use C<sv_unref> and will
1100	upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1101	Use C<SvGROW>.
1102
1103	=cut
1104	*/
1105
1106	char *
1107	Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1108	{
1109	register char *s;
1110
1111	#ifdef HAS_64K_LIMIT
1112	if (newlen >= 0x10000) {
1113	PerlIO_printf(Perl_debug_log,
1114	"Allocation too large: %"UVxf"\n", (UV)newlen);
1115	my_exit(1);
1116	}
1117	#endif /* HAS_64K_LIMIT */
1118	if (SvROK(sv))
1119	sv_unref(sv);
1120	if (SvTYPE(sv) < SVt_PV) {
1121	sv_upgrade(sv, SVt_PV);
1122	s = SvPVX(sv);
1123	}
1124	else if (SvOOK(sv)) { /* pv is offset? */
1125	sv_backoff(sv);
1126	s = SvPVX(sv);
1127	if (newlen > SvLEN(sv))
1128	newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1129	#ifdef HAS_64K_LIMIT
1130	if (newlen >= 0x10000)
1131	newlen = 0xFFFF;
1132	#endif
1133	}
1134	else
1135	s = SvPVX(sv);
1136	if (newlen > SvLEN(sv)) { /* need more room? */
1137	if (SvLEN(sv) && s) {
1138	#if defined(MYMALLOC) && !defined(LEAKTEST)
1139	STRLEN l = malloced_size((void*)SvPVX(sv));
1140	if (newlen <= l) {
1141	SvLEN_set(sv, l);
1142	return s;
1143	} else
1144	#endif
1145	Renew(s,newlen,char);
1146	}
1147	else
1148	New(703,s,newlen,char);
1149	SvPV_set(sv, s);
1150	SvLEN_set(sv, newlen);
1151	}
1152	return s;
1153	}
1154
1155	/*
1156	=for apidoc sv_setiv
1157
1158	Copies an integer into the given SV. Does not handle 'set' magic. See
1159	C<sv_setiv_mg>.
1160
1161	=cut
1162	*/
1163
1164	void
1165	Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1166	{
1167	SV_CHECK_THINKFIRST(sv);
1168	switch (SvTYPE(sv)) {
1169	case SVt_NULL:
1170	sv_upgrade(sv, SVt_IV);
1171	break;
1172	case SVt_NV:
1173	sv_upgrade(sv, SVt_PVNV);
1174	break;
1175	case SVt_RV:
1176	case SVt_PV:
1177	sv_upgrade(sv, SVt_PVIV);
1178	break;
1179
1180	case SVt_PVGV:
1181	case SVt_PVAV:
1182	case SVt_PVHV:
1183	case SVt_PVCV:
1184	case SVt_PVFM:
1185	case SVt_PVIO:
1186	{
1187	dTHR;
1188	Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1189	PL_op_desc[PL_op->op_type]);
1190	}
1191	}
1192	(void)SvIOK_only(sv); /* validate number */
1193	SvIVX(sv) = i;
1194	SvTAINT(sv);
1195	}
1196
1197	/*
1198	=for apidoc sv_setiv_mg
1199
1200	Like C<sv_setiv>, but also handles 'set' magic.
1201
1202	=cut
1203	*/
1204
1205	void
1206	Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1207	{
1208	sv_setiv(sv,i);
1209	SvSETMAGIC(sv);
1210	}
1211
1212	/*
1213	=for apidoc sv_setuv
1214
1215	Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1216	See C<sv_setuv_mg>.
1217
1218	=cut
1219	*/
1220
1221	void
1222	Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1223	{
1224	sv_setiv(sv, 0);
1225	SvIsUV_on(sv);
1226	SvUVX(sv) = u;
1227	}
1228
1229	/*
1230	=for apidoc sv_setuv_mg
1231
1232	Like C<sv_setuv>, but also handles 'set' magic.
1233
1234	=cut
1235	*/
1236
1237	void
1238	Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1239	{
1240	sv_setuv(sv,u);
1241	SvSETMAGIC(sv);
1242	}
1243
1244	/*
1245	=for apidoc sv_setnv
1246
1247	Copies a double into the given SV. Does not handle 'set' magic. See
1248	C<sv_setnv_mg>.
1249
1250	=cut
1251	*/
1252
1253	void
1254	Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1255	{
1256	SV_CHECK_THINKFIRST(sv);
1257	switch (SvTYPE(sv)) {
1258	case SVt_NULL:
1259	case SVt_IV:
1260	sv_upgrade(sv, SVt_NV);
1261	break;
1262	case SVt_RV:
1263	case SVt_PV:
1264	case SVt_PVIV:
1265	sv_upgrade(sv, SVt_PVNV);
1266	break;
1267
1268	case SVt_PVGV:
1269	case SVt_PVAV:
1270	case SVt_PVHV:
1271	case SVt_PVCV:
1272	case SVt_PVFM:
1273	case SVt_PVIO:
1274	{
1275	dTHR;
1276	Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1277	PL_op_name[PL_op->op_type]);
1278	}
1279	}
1280	SvNVX(sv) = num;
1281	(void)SvNOK_only(sv); /* validate number */
1282	SvTAINT(sv);
1283	}
1284
1285	/*
1286	=for apidoc sv_setnv_mg
1287
1288	Like C<sv_setnv>, but also handles 'set' magic.
1289
1290	=cut
1291	*/
1292
1293	void
1294	Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1295	{
1296	sv_setnv(sv,num);
1297	SvSETMAGIC(sv);
1298	}
1299
1300	STATIC void
1301	S_not_a_number(pTHX_ SV *sv)
1302	{
1303	dTHR;
1304	char tmpbuf[64];
1305	char *d = tmpbuf;
1306	char *s;
1307	char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308	/* each *s can expand to 4 chars + "...\0",
1309	i.e. need room for 8 chars */
1310
1311	for (s = SvPVX(sv); *s && d < limit; s++) {
1312	int ch = *s & 0xFF;
1313	if (ch & 128 && !isPRINT_LC(ch)) {
1314	*d++ = 'M';
1315	*d++ = '-';
1316	ch &= 127;
1317	}
1318	if (ch == '\n') {
1319	*d++ = '\\';
1320	*d++ = 'n';
1321	}
1322	else if (ch == '\r') {
1323	*d++ = '\\';
1324	*d++ = 'r';
1325	}
1326	else if (ch == '\f') {
1327	*d++ = '\\';
1328	*d++ = 'f';
1329	}
1330	else if (ch == '\\') {
1331	*d++ = '\\';
1332	*d++ = '\\';
1333	}
1334	else if (isPRINT_LC(ch))
1335	*d++ = ch;
1336	else {
1337	*d++ = '^';
1338	*d++ = toCTRL(ch);
1339	}
1340	}
1341	if (*s) {
1342	*d++ = '.';
1343	*d++ = '.';
1344	*d++ = '.';
1345	}
1346	*d = '\0';
1347
1348	if (PL_op)
1349	Perl_warner(aTHX_ WARN_NUMERIC,
1350	"Argument \"%s\" isn't numeric in %s", tmpbuf,
1351	PL_op_desc[PL_op->op_type]);
1352	else
1353	Perl_warner(aTHX_ WARN_NUMERIC,
1354	"Argument \"%s\" isn't numeric", tmpbuf);
1355	}
1356
1357	/* the number can be converted to integer with atol() or atoll() */
1358	#define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359	#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360	#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1361	#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1362
1363	/* Actually, ISO C leaves conversion of UV to IV undefined, but
1364	until proven guilty, assume that things are not that bad... */
1365
1366	IV
1367	Perl_sv_2iv(pTHX_ register SV *sv)
1368	{
1369	if (!sv)
1370	return 0;
1371	if (SvGMAGICAL(sv)) {
1372	mg_get(sv);
1373	if (SvIOKp(sv))
1374	return SvIVX(sv);
1375	if (SvNOKp(sv)) {
1376	return I_V(SvNVX(sv));
1377	}
1378	if (SvPOKp(sv) && SvLEN(sv))
1379	return asIV(sv);
1380	if (!SvROK(sv)) {
1381	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1382	dTHR;
1383	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1384	report_uninit();
1385	}
1386	return 0;
1387	}
1388	}
1389	if (SvTHINKFIRST(sv)) {
1390	if (SvROK(sv)) {
1391	SV* tmpstr;
1392	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1393	return SvIV(tmpstr);
1394	return PTR2IV(SvRV(sv));
1395	}
1396	if (SvREADONLY(sv) && !SvOK(sv)) {
1397	dTHR;
1398	if (ckWARN(WARN_UNINITIALIZED))
1399	report_uninit();
1400	return 0;
1401	}
1402	}
1403	if (SvIOKp(sv)) {
1404	if (SvIsUV(sv)) {
1405	return (IV)(SvUVX(sv));
1406	}
1407	else {
1408	return SvIVX(sv);
1409	}
1410	}
1411	if (SvNOKp(sv)) {
1412	/* We can cache the IV/UV value even if it not good enough
1413	* to reconstruct NV, since the conversion to PV will prefer
1414	* NV over IV/UV.
1415	*/
1416
1417	if (SvTYPE(sv) == SVt_NV)
1418	sv_upgrade(sv, SVt_PVNV);
1419
1420	(void)SvIOK_on(sv);
1421	if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1422	SvIVX(sv) = I_V(SvNVX(sv));
1423	else {
1424	SvUVX(sv) = U_V(SvNVX(sv));
1425	SvIsUV_on(sv);
1426	ret_iv_max:
1427	DEBUG_c(PerlIO_printf(Perl_debug_log,
1428	"0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1429	PTR2UV(sv),
1430	SvUVX(sv),
1431	SvUVX(sv)));
1432	return (IV)SvUVX(sv);
1433	}
1434	}
1435	else if (SvPOKp(sv) && SvLEN(sv)) {
1436	I32 numtype = looks_like_number(sv);
1437
1438	/* We want to avoid a possible problem when we cache an IV which
1439	may be later translated to an NV, and the resulting NV is not
1440	the translation of the initial data.
1441
1442	This means that if we cache such an IV, we need to cache the
1443	NV as well. Moreover, we trade speed for space, and do not
1444	cache the NV if not needed.
1445	*/
1446	if (numtype & IS_NUMBER_NOT_IV) {
1447	/* May be not an integer. Need to cache NV if we cache IV
1448	* - otherwise future conversion to NV will be wrong. */
1449	NV d;
1450
1451	d = Atof(SvPVX(sv));
1452
1453	if (SvTYPE(sv) < SVt_PVNV)
1454	sv_upgrade(sv, SVt_PVNV);
1455	SvNVX(sv) = d;
1456	(void)SvNOK_on(sv);
1457	(void)SvIOK_on(sv);
1458	#if defined(USE_LONG_DOUBLE)
1459	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1460	PTR2UV(sv), SvNVX(sv)));
1461	#else
1462	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1463	PTR2UV(sv), SvNVX(sv)));
1464	#endif
1465	if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1466	SvIVX(sv) = I_V(SvNVX(sv));
1467	else {
1468	SvUVX(sv) = U_V(SvNVX(sv));
1469	SvIsUV_on(sv);
1470	goto ret_iv_max;
1471	}
1472	}
1473	else if (numtype) {
1474	/* The NV may be reconstructed from IV - safe to cache IV,
1475	which may be calculated by atol(). */
1476	if (SvTYPE(sv) == SVt_PV)
1477	sv_upgrade(sv, SVt_PVIV);
1478	(void)SvIOK_on(sv);
1479	SvIVX(sv) = Atol(SvPVX(sv));
1480	}
1481	else { /* Not a number. Cache 0. */
1482	dTHR;
1483
1484	if (SvTYPE(sv) < SVt_PVIV)
1485	sv_upgrade(sv, SVt_PVIV);
1486	SvIVX(sv) = 0;
1487	(void)SvIOK_on(sv);
1488	if (ckWARN(WARN_NUMERIC))
1489	not_a_number(sv);
1490	}
1491	}
1492	else {
1493	dTHR;
1494	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1495	report_uninit();
1496	if (SvTYPE(sv) < SVt_IV)
1497	/* Typically the caller expects that sv_any is not NULL now. */
1498	sv_upgrade(sv, SVt_IV);
1499	return 0;
1500	}
1501	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1502	PTR2UV(sv),SvIVX(sv)));
1503	return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1504	}
1505
1506	UV
1507	Perl_sv_2uv(pTHX_ register SV *sv)
1508	{
1509	if (!sv)
1510	return 0;
1511	if (SvGMAGICAL(sv)) {
1512	mg_get(sv);
1513	if (SvIOKp(sv))
1514	return SvUVX(sv);
1515	if (SvNOKp(sv))
1516	return U_V(SvNVX(sv));
1517	if (SvPOKp(sv) && SvLEN(sv))
1518	return asUV(sv);
1519	if (!SvROK(sv)) {
1520	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1521	dTHR;
1522	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1523	report_uninit();
1524	}
1525	return 0;
1526	}
1527	}
1528	if (SvTHINKFIRST(sv)) {
1529	if (SvROK(sv)) {
1530	SV* tmpstr;
1531	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1532	return SvUV(tmpstr);
1533	return PTR2UV(SvRV(sv));
1534	}
1535	if (SvREADONLY(sv) && !SvOK(sv)) {
1536	dTHR;
1537	if (ckWARN(WARN_UNINITIALIZED))
1538	report_uninit();
1539	return 0;
1540	}
1541	}
1542	if (SvIOKp(sv)) {
1543	if (SvIsUV(sv)) {
1544	return SvUVX(sv);
1545	}
1546	else {
1547	return (UV)SvIVX(sv);
1548	}
1549	}
1550	if (SvNOKp(sv)) {
1551	/* We can cache the IV/UV value even if it not good enough
1552	* to reconstruct NV, since the conversion to PV will prefer
1553	* NV over IV/UV.
1554	*/
1555	if (SvTYPE(sv) == SVt_NV)
1556	sv_upgrade(sv, SVt_PVNV);
1557	(void)SvIOK_on(sv);
1558	if (SvNVX(sv) >= -0.5) {
1559	SvIsUV_on(sv);
1560	SvUVX(sv) = U_V(SvNVX(sv));
1561	}
1562	else {
1563	SvIVX(sv) = I_V(SvNVX(sv));
1564	ret_zero:
1565	DEBUG_c(PerlIO_printf(Perl_debug_log,
1566	"0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1567	PTR2UV(sv),
1568	SvIVX(sv),
1569	(IV)(UV)SvIVX(sv)));
1570	return (UV)SvIVX(sv);
1571	}
1572	}
1573	else if (SvPOKp(sv) && SvLEN(sv)) {
1574	I32 numtype = looks_like_number(sv);
1575
1576	/* We want to avoid a possible problem when we cache a UV which
1577	may be later translated to an NV, and the resulting NV is not
1578	the translation of the initial data.
1579
1580	This means that if we cache such a UV, we need to cache the
1581	NV as well. Moreover, we trade speed for space, and do not
1582	cache the NV if not needed.
1583	*/
1584	if (numtype & IS_NUMBER_NOT_IV) {
1585	/* May be not an integer. Need to cache NV if we cache IV
1586	* - otherwise future conversion to NV will be wrong. */
1587	NV d;
1588
1589	d = Atof(SvPVX(sv));
1590
1591	if (SvTYPE(sv) < SVt_PVNV)
1592	sv_upgrade(sv, SVt_PVNV);
1593	SvNVX(sv) = d;
1594	(void)SvNOK_on(sv);
1595	(void)SvIOK_on(sv);
1596	#if defined(USE_LONG_DOUBLE)
1597	DEBUG_c(PerlIO_printf(Perl_debug_log,
1598	"0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1599	PTR2UV(sv), SvNVX(sv)));
1600	#else
1601	DEBUG_c(PerlIO_printf(Perl_debug_log,
1602	"0x%"UVxf" 2nv(%g)\n",
1603	PTR2UV(sv), SvNVX(sv)));
1604	#endif
1605	if (SvNVX(sv) < -0.5) {
1606	SvIVX(sv) = I_V(SvNVX(sv));
1607	goto ret_zero;
1608	} else {
1609	SvUVX(sv) = U_V(SvNVX(sv));
1610	SvIsUV_on(sv);
1611	}
1612	}
1613	else if (numtype & IS_NUMBER_NEG) {
1614	/* The NV may be reconstructed from IV - safe to cache IV,
1615	which may be calculated by atol(). */
1616	if (SvTYPE(sv) == SVt_PV)
1617	sv_upgrade(sv, SVt_PVIV);
1618	(void)SvIOK_on(sv);
1619	SvIVX(sv) = (IV)Atol(SvPVX(sv));
1620	}
1621	else if (numtype) { /* Non-negative */
1622	/* The NV may be reconstructed from UV - safe to cache UV,
1623	which may be calculated by strtoul()/atol. */
1624	if (SvTYPE(sv) == SVt_PV)
1625	sv_upgrade(sv, SVt_PVIV);
1626	(void)SvIOK_on(sv);
1627	(void)SvIsUV_on(sv);
1628	#ifdef HAS_STRTOUL
1629	SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1630	#else /* no atou(), but we know the number fits into IV... */
1631	/* The only problem may be if it is negative... */
1632	SvUVX(sv) = (UV)Atol(SvPVX(sv));
1633	#endif
1634	}
1635	else { /* Not a number. Cache 0. */
1636	dTHR;
1637
1638	if (SvTYPE(sv) < SVt_PVIV)
1639	sv_upgrade(sv, SVt_PVIV);
1640	SvUVX(sv) = 0; /* We assume that 0s have the
1641	same bitmap in IV and UV. */
1642	(void)SvIOK_on(sv);
1643	(void)SvIsUV_on(sv);
1644	if (ckWARN(WARN_NUMERIC))
1645	not_a_number(sv);
1646	}
1647	}
1648	else {
1649	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1650	dTHR;
1651	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1652	report_uninit();
1653	}
1654	if (SvTYPE(sv) < SVt_IV)
1655	/* Typically the caller expects that sv_any is not NULL now. */
1656	sv_upgrade(sv, SVt_IV);
1657	return 0;
1658	}
1659
1660	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1661	PTR2UV(sv),SvUVX(sv)));
1662	return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1663	}
1664
1665	NV
1666	Perl_sv_2nv(pTHX_ register SV *sv)
1667	{
1668	if (!sv)
1669	return 0.0;
1670	if (SvGMAGICAL(sv)) {
1671	mg_get(sv);
1672	if (SvNOKp(sv))
1673	return SvNVX(sv);
1674	if (SvPOKp(sv) && SvLEN(sv)) {
1675	dTHR;
1676	if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1677	not_a_number(sv);
1678	return Atof(SvPVX(sv));
1679	}
1680	if (SvIOKp(sv)) {
1681	if (SvIsUV(sv))
1682	return (NV)SvUVX(sv);
1683	else
1684	return (NV)SvIVX(sv);
1685	}
1686	if (!SvROK(sv)) {
1687	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1688	dTHR;
1689	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1690	report_uninit();
1691	}
1692	return 0;
1693	}
1694	}
1695	if (SvTHINKFIRST(sv)) {
1696	if (SvROK(sv)) {
1697	SV* tmpstr;
1698	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1699	return SvNV(tmpstr);
1700	return PTR2NV(SvRV(sv));
1701	}
1702	if (SvREADONLY(sv) && !SvOK(sv)) {
1703	dTHR;
1704	if (ckWARN(WARN_UNINITIALIZED))
1705	report_uninit();
1706	return 0.0;
1707	}
1708	}
1709	if (SvTYPE(sv) < SVt_NV) {
1710	if (SvTYPE(sv) == SVt_IV)
1711	sv_upgrade(sv, SVt_PVNV);
1712	else
1713	sv_upgrade(sv, SVt_NV);
1714	#if defined(USE_LONG_DOUBLE)
1715	DEBUG_c({
1716	RESTORE_NUMERIC_STANDARD();
1717	PerlIO_printf(Perl_debug_log,
1718	"0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1719	PTR2UV(sv), SvNVX(sv));
1720	RESTORE_NUMERIC_LOCAL();
1721	});
1722	#else
1723	DEBUG_c({
1724	RESTORE_NUMERIC_STANDARD();
1725	PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1726	PTR2UV(sv), SvNVX(sv));
1727	RESTORE_NUMERIC_LOCAL();
1728	});
1729	#endif
1730	}
1731	else if (SvTYPE(sv) < SVt_PVNV)
1732	sv_upgrade(sv, SVt_PVNV);
1733	if (SvIOKp(sv) &&
1734	(!SvPOKp(sv) \|\| !strchr(SvPVX(sv),'.') \|\| !looks_like_number(sv)))
1735	{
1736	SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1737	}
1738	else if (SvPOKp(sv) && SvLEN(sv)) {
1739	dTHR;
1740	if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1741	not_a_number(sv);
1742	SvNVX(sv) = Atof(SvPVX(sv));
1743	}
1744	else {
1745	dTHR;
1746	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1747	report_uninit();
1748	if (SvTYPE(sv) < SVt_NV)
1749	/* Typically the caller expects that sv_any is not NULL now. */
1750	sv_upgrade(sv, SVt_NV);
1751	return 0.0;
1752	}
1753	SvNOK_on(sv);
1754	#if defined(USE_LONG_DOUBLE)
1755	DEBUG_c({
1756	RESTORE_NUMERIC_STANDARD();
1757	PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1758	PTR2UV(sv), SvNVX(sv));
1759	RESTORE_NUMERIC_LOCAL();
1760	});
1761	#else
1762	DEBUG_c({
1763	RESTORE_NUMERIC_STANDARD();
1764	PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1765	PTR2UV(sv), SvNVX(sv));
1766	RESTORE_NUMERIC_LOCAL();
1767	});
1768	#endif
1769	return SvNVX(sv);
1770	}
1771
1772	STATIC IV
1773	S_asIV(pTHX_ SV *sv)
1774	{
1775	I32 numtype = looks_like_number(sv);
1776	NV d;
1777
1778	if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1779	return Atol(SvPVX(sv));
1780	if (!numtype) {
1781	dTHR;
1782	if (ckWARN(WARN_NUMERIC))
1783	not_a_number(sv);
1784	}
1785	d = Atof(SvPVX(sv));
1786	return I_V(d);
1787	}
1788
1789	STATIC UV
1790	S_asUV(pTHX_ SV *sv)
1791	{
1792	I32 numtype = looks_like_number(sv);
1793
1794	#ifdef HAS_STRTOUL
1795	if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1796	return Strtoul(SvPVX(sv), Null(char**), 10);
1797	#endif
1798	if (!numtype) {
1799	dTHR;
1800	if (ckWARN(WARN_NUMERIC))
1801	not_a_number(sv);
1802	}
1803	return U_V(Atof(SvPVX(sv)));
1804	}
1805
1806	/*
1807	* Returns a combination of (advisory only - can get false negatives)
1808	* IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1809	* IS_NUMBER_NEG
1810	* 0 if does not look like number.
1811	*
1812	* In fact possible values are 0 and
1813	* IS_NUMBER_TO_INT_BY_ATOL 123
1814	* IS_NUMBER_TO_INT_BY_ATOL \| IS_NUMBER_NOT_IV 123.1
1815	* IS_NUMBER_TO_INT_BY_ATOF \| IS_NUMBER_NOT_IV 123e0
1816	* with a possible addition of IS_NUMBER_NEG.
1817	*/
1818
1819	/*
1820	=for apidoc looks_like_number
1821
1822	Test if an the content of an SV looks like a number (or is a
1823	number).
1824
1825	=cut
1826	*/
1827
1828	I32
1829	Perl_looks_like_number(pTHX_ SV *sv)
1830	{
1831	register char *s;
1832	register char *send;
1833	register char *sbegin;
1834	register char *nbegin;
1835	I32 numtype = 0;
1836	STRLEN len;
1837
1838	if (SvPOK(sv)) {
1839	sbegin = SvPVX(sv);
1840	len = SvCUR(sv);
1841	}
1842	else if (SvPOKp(sv))
1843	sbegin = SvPV(sv, len);
1844	else
1845	return 1;
1846	send = sbegin + len;
1847
1848	s = sbegin;
1849	while (isSPACE(*s))
1850	s++;
1851	if (*s == '-') {
1852	s++;
1853	numtype = IS_NUMBER_NEG;
1854	}
1855	else if (*s == '+')
1856	s++;
1857
1858	nbegin = s;
1859	/*
1860	* we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1861	* to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1862	* (int)atof().
1863	*/
1864
1865	/* next must be digit or the radix separator */
1866	if (isDIGIT(*s)) {
1867	do {
1868	s++;
1869	} while (isDIGIT(*s));
1870
1871	if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1872	numtype \|= IS_NUMBER_TO_INT_BY_ATOF \| IS_NUMBER_NOT_IV;
1873	else
1874	numtype \|= IS_NUMBER_TO_INT_BY_ATOL;
1875
1876	if (*s == '.'
1877	#ifdef USE_LOCALE_NUMERIC
1878	\|\| IS_NUMERIC_RADIX(*s)
1879	#endif
1880	) {
1881	s++;
1882	numtype \|= IS_NUMBER_NOT_IV;
1883	while (isDIGIT(s)) / optional digits after the radix */
1884	s++;
1885	}
1886	}
1887	else if (*s == '.'
1888	#ifdef USE_LOCALE_NUMERIC
1889	\|\| IS_NUMERIC_RADIX(*s)
1890	#endif
1891	) {
1892	s++;
1893	numtype \|= IS_NUMBER_TO_INT_BY_ATOL \| IS_NUMBER_NOT_IV;
1894	/* no digits before the radix means we need digits after it */
1895	if (isDIGIT(*s)) {
1896	do {
1897	s++;
1898	} while (isDIGIT(*s));
1899	}
1900	else
1901	return 0;
1902	}
1903	else
1904	return 0;
1905
1906	/* we can have an optional exponent part */
1907	if (s == 'e' \|\| s == 'E') {
1908	numtype &= ~IS_NUMBER_NEG;
1909	numtype \|= IS_NUMBER_TO_INT_BY_ATOF \| IS_NUMBER_NOT_IV;
1910	s++;
1911	if (s == '+' \|\| s == '-')
1912	s++;
1913	if (isDIGIT(*s)) {
1914	do {
1915	s++;
1916	} while (isDIGIT(*s));
1917	}
1918	else
1919	return 0;
1920	}
1921	while (isSPACE(*s))
1922	s++;
1923	if (s >= send)
1924	return numtype;
1925	if (len == 10 && memEQ(sbegin, "0 but true", 10))
1926	return IS_NUMBER_TO_INT_BY_ATOL;
1927	return 0;
1928	}
1929
1930	char *
1931	Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1932	{
1933	STRLEN n_a;
1934	return sv_2pv(sv, &n_a);
1935	}
1936
1937	/* We assume that buf is at least TYPE_CHARS(UV) long. */
1938	static char *
1939	uiv_2buf(char buf, IV iv, UV uv, int is_uv, char *peob)
1940	{
1941	char *ptr = buf + TYPE_CHARS(UV);
1942	char *ebuf = ptr;
1943	int sign;
1944
1945	if (is_uv)
1946	sign = 0;
1947	else if (iv >= 0) {
1948	uv = iv;
1949	sign = 0;
1950	} else {
1951	uv = -iv;
1952	sign = 1;
1953	}
1954	do {
1955	*--ptr = '0' + (uv % 10);
1956	} while (uv /= 10);
1957	if (sign)
1958	*--ptr = '-';
1959	*peob = ebuf;
1960	return ptr;
1961	}
1962
1963	char *
1964	Perl_sv_2pv(pTHX_ register SV sv, STRLEN lp)
1965	{
1966	register char *s;
1967	int olderrno;
1968	SV *tsv;
1969	char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1970	char *tmpbuf = tbuf;
1971
1972	if (!sv) {
1973	*lp = 0;
1974	return "";
1975	}
1976	if (SvGMAGICAL(sv)) {
1977	mg_get(sv);
1978	if (SvPOKp(sv)) {
1979	*lp = SvCUR(sv);
1980	return SvPVX(sv);
1981	}
1982	if (SvIOKp(sv)) {
1983	if (SvIsUV(sv))
1984	(void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
1985	else
1986	(void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
1987	tsv = Nullsv;
1988	goto tokensave;
1989	}
1990	if (SvNOKp(sv)) {
1991	Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1992	tsv = Nullsv;
1993	goto tokensave;
1994	}
1995	if (!SvROK(sv)) {
1996	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1997	dTHR;
1998	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1999	report_uninit();
2000	}
2001	*lp = 0;
2002	return "";
2003	}
2004	}
2005	if (SvTHINKFIRST(sv)) {
2006	if (SvROK(sv)) {
2007	SV* tmpstr;
2008	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2009	return SvPV(tmpstr,*lp);
2010	sv = (SV*)SvRV(sv);
2011	if (!sv)
2012	s = "NULLREF";
2013	else {
2014	MAGIC *mg;
2015
2016	switch (SvTYPE(sv)) {
2017	case SVt_PVMG:
2018	if ( ((SvFLAGS(sv) &
2019	(SVs_OBJECT\|SVf_OK\|SVs_GMG\|SVs_SMG\|SVs_RMG))
2020	== (SVs_OBJECT\|SVs_RMG))
2021	&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2022	&& (mg = mg_find(sv, 'r'))) {
2023	dTHR;
2024	regexp re = (regexp )mg->mg_obj;
2025
2026	if (!mg->mg_ptr) {
2027	char *fptr = "msix";
2028	char reflags[6];
2029	char ch;
2030	int left = 0;
2031	int right = 4;
2032	U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2033
2034	while((ch = *fptr++)) {
2035	if(reganch & 1) {
2036	reflags[left++] = ch;
2037	}
2038	else {
2039	reflags[right--] = ch;
2040	}
2041	reganch >>= 1;
2042	}
2043	if(left != 4) {
2044	reflags[left] = '-';
2045	left = 5;
2046	}
2047
2048	mg->mg_len = re->prelen + 4 + left;
2049	New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2050	Copy("(?", mg->mg_ptr, 2, char);
2051	Copy(reflags, mg->mg_ptr+2, left, char);
2052	Copy(":", mg->mg_ptr+left+2, 1, char);
2053	Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2054	mg->mg_ptr[mg->mg_len - 1] = ')';
2055	mg->mg_ptr[mg->mg_len] = 0;
2056	}
2057	PL_reginterp_cnt += re->program[0].next_off;
2058	*lp = mg->mg_len;
2059	return mg->mg_ptr;
2060	}
2061	/* Fall through */
2062	case SVt_NULL:
2063	case SVt_IV:
2064	case SVt_NV:
2065	case SVt_RV:
2066	case SVt_PV:
2067	case SVt_PVIV:
2068	case SVt_PVNV:
2069	case SVt_PVBM: s = "SCALAR"; break;
2070	case SVt_PVLV: s = "LVALUE"; break;
2071	case SVt_PVAV: s = "ARRAY"; break;
2072	case SVt_PVHV: s = "HASH"; break;
2073	case SVt_PVCV: s = "CODE"; break;
2074	case SVt_PVGV: s = "GLOB"; break;
2075	case SVt_PVFM: s = "FORMAT"; break;
2076	case SVt_PVIO: s = "IO"; break;
2077	default: s = "UNKNOWN"; break;
2078	}
2079	tsv = NEWSV(0,0);
2080	if (SvOBJECT(sv))
2081	Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2082	else
2083	sv_setpv(tsv, s);
2084	Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2085	goto tokensaveref;
2086	}
2087	*lp = strlen(s);
2088	return s;
2089	}
2090	if (SvREADONLY(sv) && !SvOK(sv)) {
2091	dTHR;
2092	if (ckWARN(WARN_UNINITIALIZED))
2093	report_uninit();
2094	*lp = 0;
2095	return "";
2096	}
2097	}
2098	if (SvNOKp(sv)) { /* See note in sv_2uv() */
2099	/* XXXX 64-bit? IV may have better precision... */
2100	/* I tried changing this for to be 64-bit-aware and
2101	* the t/op/numconvert.t became very, very, angry.
2102	* --jhi Sep 1999 */
2103	if (SvTYPE(sv) < SVt_PVNV)
2104	sv_upgrade(sv, SVt_PVNV);
2105	SvGROW(sv, 28);
2106	s = SvPVX(sv);
2107	olderrno = errno; /* some Xenix systems wipe out errno here */
2108	#ifdef apollo
2109	if (SvNVX(sv) == 0.0)
2110	(void)strcpy(s,"0");
2111	else
2112	#endif /apollo/
2113	{
2114	Gconvert(SvNVX(sv), NV_DIG, 0, s);
2115	}
2116	errno = olderrno;
2117	#ifdef FIXNEGATIVEZERO
2118	if (*s == '-' && s[1] == '0' && !s[2])
2119	strcpy(s,"0");
2120	#endif
2121	while (*s) s++;
2122	#ifdef hcx
2123	if (s[-1] == '.')
2124	*--s = '\0';
2125	#endif
2126	}
2127	else if (SvIOKp(sv)) {
2128	U32 isIOK = SvIOK(sv);
2129	U32 isUIOK = SvIsUV(sv);
2130	char buf[TYPE_CHARS(UV)];
2131	char ebuf, ptr;
2132
2133	if (SvTYPE(sv) < SVt_PVIV)
2134	sv_upgrade(sv, SVt_PVIV);
2135	if (isUIOK)
2136	ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2137	else
2138	ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2139	SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2140	Move(ptr,SvPVX(sv),ebuf - ptr,char);
2141	SvCUR_set(sv, ebuf - ptr);
2142	s = SvEND(sv);
2143	*s = '\0';
2144	if (isIOK)
2145	SvIOK_on(sv);
2146	else
2147	SvIOKp_on(sv);
2148	if (isUIOK)
2149	SvIsUV_on(sv);
2150	SvPOK_on(sv);
2151	}
2152	else {
2153	dTHR;
2154	if (ckWARN(WARN_UNINITIALIZED)
2155	&& !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2156	{
2157	report_uninit();
2158	}
2159	*lp = 0;
2160	if (SvTYPE(sv) < SVt_PV)
2161	/* Typically the caller expects that sv_any is not NULL now. */
2162	sv_upgrade(sv, SVt_PV);
2163	return "";
2164	}
2165	*lp = s - SvPVX(sv);
2166	SvCUR_set(sv, *lp);
2167	SvPOK_on(sv);
2168	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2169	PTR2UV(sv),SvPVX(sv)));
2170	return SvPVX(sv);
2171
2172	tokensave:
2173	if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2174	/* Sneaky stuff here */
2175
2176	tokensaveref:
2177	if (!tsv)
2178	tsv = newSVpv(tmpbuf, 0);
2179	sv_2mortal(tsv);
2180	*lp = SvCUR(tsv);
2181	return SvPVX(tsv);
2182	}
2183	else {
2184	STRLEN len;
2185	char *t;
2186
2187	if (tsv) {
2188	sv_2mortal(tsv);
2189	t = SvPVX(tsv);
2190	len = SvCUR(tsv);
2191	}
2192	else {
2193	t = tmpbuf;
2194	len = strlen(tmpbuf);
2195	}
2196	#ifdef FIXNEGATIVEZERO
2197	if (len == 2 && t[0] == '-' && t[1] == '0') {
2198	t = "0";
2199	len = 1;
2200	}
2201	#endif
2202	(void)SvUPGRADE(sv, SVt_PV);
2203	*lp = len;
2204	s = SvGROW(sv, len + 1);
2205	SvCUR_set(sv, len);
2206	(void)strcpy(s, t);
2207	SvPOKp_on(sv);
2208	return s;
2209	}
2210	}
2211
2212	char *
2213	Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2214	{
2215	STRLEN n_a;
2216	return sv_2pvbyte(sv, &n_a);
2217	}
2218
2219	char *
2220	Perl_sv_2pvbyte(pTHX_ register SV sv, STRLEN lp)
2221	{
2222	return sv_2pv(sv,lp);
2223	}
2224
2225	char *
2226	Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2227	{
2228	STRLEN n_a;
2229	return sv_2pvutf8(sv, &n_a);
2230	}
2231
2232	char *
2233	Perl_sv_2pvutf8(pTHX_ register SV sv, STRLEN lp)
2234	{
2235	sv_utf8_upgrade(sv);
2236	return sv_2pv(sv,lp);
2237	}
2238
2239	/* This function is only called on magical items */
2240	bool
2241	Perl_sv_2bool(pTHX_ register SV *sv)
2242	{
2243	if (SvGMAGICAL(sv))
2244	mg_get(sv);
2245
2246	if (!SvOK(sv))
2247	return 0;
2248	if (SvROK(sv)) {
2249	dTHR;
2250	SV* tmpsv;
2251	if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2252	return SvTRUE(tmpsv);
2253	return SvRV(sv) != 0;
2254	}
2255	if (SvPOKp(sv)) {
2256	register XPV* Xpvtmp;
2257	if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2258	(*Xpvtmp->xpv_pv > '0' \|\|
2259	Xpvtmp->xpv_cur > 1 \|\|
2260	(Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2261	return 1;
2262	else
2263	return 0;
2264	}
2265	else {
2266	if (SvIOKp(sv))
2267	return SvIVX(sv) != 0;
2268	else {
2269	if (SvNOKp(sv))
2270	return SvNVX(sv) != 0.0;
2271	else
2272	return FALSE;
2273	}
2274	}
2275	}
2276
2277	void
2278	Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2279	{
2280	int hicount;
2281	char *c;
2282
2283	if (!sv \|\| !SvPOK(sv) \|\| SvUTF8(sv))
2284	return;
2285
2286	/* This function could be much more efficient if we had a FLAG
2287	* to signal if there are any hibit chars in the string
2288	*/
2289	hicount = 0;
2290	for (c = SvPVX(sv); c < SvEND(sv); c++) {
2291	if (*c & 0x80)
2292	hicount++;
2293	}
2294
2295	if (hicount) {
2296	char src, dst;
2297	SvGROW(sv, SvCUR(sv) + hicount + 1);
2298
2299	src = SvEND(sv) - 1;
2300	SvCUR_set(sv, SvCUR(sv) + hicount);
2301	dst = SvEND(sv) - 1;
2302
2303	while (src < dst) {
2304	if (*src & 0x80) {
2305	dst--;
2306	uv_to_utf8((U8)dst, (U8)src--);
2307	dst--;
2308	}
2309	else {
2310	dst-- = src--;
2311	}
2312	}
2313
2314	SvUTF8_on(sv);
2315	}
2316	}
2317
2318	bool
2319	Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2320	{
2321	if (SvPOK(sv) && SvUTF8(sv)) {
2322	char *c = SvPVX(sv);
2323	char *first_hi = 0;
2324	/* need to figure out if this is possible at all first */
2325	while (c < SvEND(sv)) {
2326	if (*c & 0x80) {
2327	I32 len;
2328	UV uv = utf8_to_uv((U8*)c, &len);
2329	if (uv >= 256) {
2330	if (fail_ok)
2331	return FALSE;
2332	else {
2333	/* XXX might want to make a callback here instead */
2334	Perl_croak(aTHX_ "Big byte");
2335	}
2336	}
2337	if (!first_hi)
2338	first_hi = c;
2339	c += len;
2340	}
2341	else {
2342	c++;
2343	}
2344	}
2345
2346	if (first_hi) {
2347	char *src = first_hi;
2348	char *dst = first_hi;
2349	while (src < SvEND(sv)) {
2350	if (*src & 0x80) {
2351	I32 len;
2352	U8 u = (U8)utf8_to_uv((U8*)src, &len);
2353	*dst++ = u;
2354	src += len;
2355	}
2356	else {
2357	dst++ = src++;
2358	}
2359	}
2360	SvCUR_set(sv, dst - SvPVX(sv));
2361	}
2362	SvUTF8_off(sv);
2363	}
2364	return TRUE;
2365	}
2366
2367	void
2368	Perl_sv_utf8_encode(pTHX_ register SV *sv)
2369	{
2370	sv_utf8_upgrade(sv);
2371	SvUTF8_off(sv);
2372	}
2373
2374	bool
2375	Perl_sv_utf8_decode(pTHX_ register SV *sv)
2376	{
2377	if (SvPOK(sv)) {
2378	char *c;
2379	bool has_utf = FALSE;
2380	if (!sv_utf8_downgrade(sv, TRUE))
2381	return FALSE;
2382
2383	/* it is actually just a matter of turning the utf8 flag on, but
2384	* we want to make sure everything inside is valid utf8 first.
2385	*/
2386	c = SvPVX(sv);
2387	while (c < SvEND(sv)) {
2388	if (*c & 0x80) {
2389	I32 len;
2390	(void)utf8_to_uv((U8*)c, &len);
2391	if (len == 1) {
2392	/* bad utf8 */
2393	return FALSE;
2394	}
2395	c += len;
2396	has_utf = TRUE;
2397	}
2398	else {
2399	c++;
2400	}
2401	}
2402
2403	if (has_utf)
2404	SvUTF8_on(sv);
2405	}
2406	return TRUE;
2407	}
2408
2409
2410	/* Note: sv_setsv() should not be called with a source string that needs
2411	* to be reused, since it may destroy the source string if it is marked
2412	* as temporary.
2413	*/
2414
2415	/*
2416	=for apidoc sv_setsv
2417
2418	Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2419	The source SV may be destroyed if it is mortal. Does not handle 'set'
2420	magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2421	C<sv_setsv_mg>.
2422
2423	=cut
2424	*/
2425
2426	void
2427	Perl_sv_setsv(pTHX_ SV dstr, register SV sstr)
2428	{
2429	dTHR;
2430	register U32 sflags;
2431	register int dtype;
2432	register int stype;
2433
2434	if (sstr == dstr)
2435	return;
2436	SV_CHECK_THINKFIRST(dstr);
2437	if (!sstr)
2438	sstr = &PL_sv_undef;
2439	stype = SvTYPE(sstr);
2440	dtype = SvTYPE(dstr);
2441
2442	SvAMAGIC_off(dstr);
2443
2444	/* There's a lot of redundancy below but we're going for speed here */
2445
2446	switch (stype) {
2447	case SVt_NULL:
2448	undef_sstr:
2449	if (dtype != SVt_PVGV) {
2450	(void)SvOK_off(dstr);
2451	return;
2452	}
2453	break;
2454	case SVt_IV:
2455	if (SvIOK(sstr)) {
2456	switch (dtype) {
2457	case SVt_NULL:
2458	sv_upgrade(dstr, SVt_IV);
2459	break;
2460	case SVt_NV:
2461	sv_upgrade(dstr, SVt_PVNV);
2462	break;
2463	case SVt_RV:
2464	case SVt_PV:
2465	sv_upgrade(dstr, SVt_PVIV);
2466	break;
2467	}
2468	(void)SvIOK_only(dstr);
2469	SvIVX(dstr) = SvIVX(sstr);
2470	if (SvIsUV(sstr))
2471	SvIsUV_on(dstr);
2472	SvTAINT(dstr);
2473	return;
2474	}
2475	goto undef_sstr;
2476
2477	case SVt_NV:
2478	if (SvNOK(sstr)) {
2479	switch (dtype) {
2480	case SVt_NULL:
2481	case SVt_IV:
2482	sv_upgrade(dstr, SVt_NV);
2483	break;
2484	case SVt_RV:
2485	case SVt_PV:
2486	case SVt_PVIV:
2487	sv_upgrade(dstr, SVt_PVNV);
2488	break;
2489	}
2490	SvNVX(dstr) = SvNVX(sstr);
2491	(void)SvNOK_only(dstr);
2492	SvTAINT(dstr);
2493	return;
2494	}
2495	goto undef_sstr;
2496
2497	case SVt_RV:
2498	if (dtype < SVt_RV)
2499	sv_upgrade(dstr, SVt_RV);
2500	else if (dtype == SVt_PVGV &&
2501	SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2502	sstr = SvRV(sstr);
2503	if (sstr == dstr) {
2504	if (GvIMPORTED(dstr) != GVf_IMPORTED
2505	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2506	{
2507	GvIMPORTED_on(dstr);
2508	}
2509	GvMULTI_on(dstr);
2510	return;
2511	}
2512	goto glob_assign;
2513	}
2514	break;
2515	case SVt_PV:
2516	case SVt_PVFM:
2517	if (dtype < SVt_PV)
2518	sv_upgrade(dstr, SVt_PV);
2519	break;
2520	case SVt_PVIV:
2521	if (dtype < SVt_PVIV)
2522	sv_upgrade(dstr, SVt_PVIV);
2523	break;
2524	case SVt_PVNV:
2525	if (dtype < SVt_PVNV)
2526	sv_upgrade(dstr, SVt_PVNV);
2527	break;
2528	case SVt_PVAV:
2529	case SVt_PVHV:
2530	case SVt_PVCV:
2531	case SVt_PVIO:
2532	if (PL_op)
2533	Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2534	PL_op_name[PL_op->op_type]);
2535	else
2536	Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2537	break;
2538
2539	case SVt_PVGV:
2540	if (dtype <= SVt_PVGV) {
2541	glob_assign:
2542	if (dtype != SVt_PVGV) {
2543	char *name = GvNAME(sstr);
2544	STRLEN len = GvNAMELEN(sstr);
2545	sv_upgrade(dstr, SVt_PVGV);
2546	sv_magic(dstr, dstr, '*', name, len);
2547	GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2548	GvNAME(dstr) = savepvn(name, len);
2549	GvNAMELEN(dstr) = len;
2550	SvFAKE_on(dstr); /* can coerce to non-glob */
2551	}
2552	/* ahem, death to those who redefine active sort subs */
2553	else if (PL_curstackinfo->si_type == PERLSI_SORT
2554	&& GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2555	Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2556	GvNAME(dstr));
2557	(void)SvOK_off(dstr);
2558	GvINTRO_off(dstr); /* one-shot flag */
2559	gp_free((GV*)dstr);
2560	GvGP(dstr) = gp_ref(GvGP(sstr));
2561	SvTAINT(dstr);
2562	if (GvIMPORTED(dstr) != GVf_IMPORTED
2563	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2564	{
2565	GvIMPORTED_on(dstr);
2566	}
2567	GvMULTI_on(dstr);
2568	return;
2569	}
2570	/* FALL THROUGH */
2571
2572	default:
2573	if (SvGMAGICAL(sstr)) {
2574	mg_get(sstr);
2575	if (SvTYPE(sstr) != stype) {
2576	stype = SvTYPE(sstr);
2577	if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2578	goto glob_assign;
2579	}
2580	}
2581	if (stype == SVt_PVLV)
2582	(void)SvUPGRADE(dstr, SVt_PVNV);
2583	else
2584	(void)SvUPGRADE(dstr, stype);
2585	}
2586
2587	sflags = SvFLAGS(sstr);
2588
2589	if (sflags & SVf_ROK) {
2590	if (dtype >= SVt_PV) {
2591	if (dtype == SVt_PVGV) {
2592	SV *sref = SvREFCNT_inc(SvRV(sstr));
2593	SV *dref = 0;
2594	int intro = GvINTRO(dstr);
2595
2596	if (intro) {
2597	GP *gp;
2598	gp_free((GV*)dstr);
2599	GvINTRO_off(dstr); /* one-shot flag */
2600	Newz(602,gp, 1, GP);
2601	GvGP(dstr) = gp_ref(gp);
2602	GvSV(dstr) = NEWSV(72,0);
2603	GvLINE(dstr) = CopLINE(PL_curcop);
2604	GvEGV(dstr) = (GV*)dstr;
2605	}
2606	GvMULTI_on(dstr);
2607	switch (SvTYPE(sref)) {
2608	case SVt_PVAV:
2609	if (intro)
2610	SAVESPTR(GvAV(dstr));
2611	else
2612	dref = (SV*)GvAV(dstr);
2613	GvAV(dstr) = (AV*)sref;
2614	if (!GvIMPORTED_AV(dstr)
2615	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2616	{
2617	GvIMPORTED_AV_on(dstr);
2618	}
2619	break;
2620	case SVt_PVHV:
2621	if (intro)
2622	SAVESPTR(GvHV(dstr));
2623	else
2624	dref = (SV*)GvHV(dstr);
2625	GvHV(dstr) = (HV*)sref;
2626	if (!GvIMPORTED_HV(dstr)
2627	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2628	{
2629	GvIMPORTED_HV_on(dstr);
2630	}
2631	break;
2632	case SVt_PVCV:
2633	if (intro) {
2634	if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2635	SvREFCNT_dec(GvCV(dstr));
2636	GvCV(dstr) = Nullcv;
2637	GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2638	PL_sub_generation++;
2639	}
2640	SAVESPTR(GvCV(dstr));
2641	}
2642	else
2643	dref = (SV*)GvCV(dstr);
2644	if (GvCV(dstr) != (CV*)sref) {
2645	CV* cv = GvCV(dstr);
2646	if (cv) {
2647	if (!GvCVGEN((GV*)dstr) &&
2648	(CvROOT(cv) \|\| CvXSUB(cv)))
2649	{
2650	SV *const_sv = cv_const_sv(cv);
2651	bool const_changed = TRUE;
2652	if(const_sv)
2653	const_changed = sv_cmp(const_sv,
2654	op_const_sv(CvSTART((CV*)sref),
2655	Nullcv));
2656	/* ahem, death to those who redefine
2657	* active sort subs */
2658	if (PL_curstackinfo->si_type == PERLSI_SORT &&
2659	PL_sortcop == CvSTART(cv))
2660	Perl_croak(aTHX_
2661	"Can't redefine active sort subroutine %s",
2662	GvENAME((GV*)dstr));
2663	if ((const_changed \|\| const_sv) && ckWARN(WARN_REDEFINE))
2664	Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2665	"Constant subroutine %s redefined"
2666	: "Subroutine %s redefined",
2667	GvENAME((GV*)dstr));
2668	}
2669	cv_ckproto(cv, (GV*)dstr,
2670	SvPOK(sref) ? SvPVX(sref) : Nullch);
2671	}
2672	GvCV(dstr) = (CV*)sref;
2673	GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2674	GvASSUMECV_on(dstr);
2675	PL_sub_generation++;
2676	}
2677	if (!GvIMPORTED_CV(dstr)
2678	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2679	{
2680	GvIMPORTED_CV_on(dstr);
2681	}
2682	break;
2683	case SVt_PVIO:
2684	if (intro)
2685	SAVESPTR(GvIOp(dstr));
2686	else
2687	dref = (SV*)GvIOp(dstr);
2688	GvIOp(dstr) = (IO*)sref;
2689	break;
2690	default:
2691	if (intro)
2692	SAVESPTR(GvSV(dstr));
2693	else
2694	dref = (SV*)GvSV(dstr);
2695	GvSV(dstr) = sref;
2696	if (!GvIMPORTED_SV(dstr)
2697	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2698	{
2699	GvIMPORTED_SV_on(dstr);
2700	}
2701	break;
2702	}
2703	if (dref)
2704	SvREFCNT_dec(dref);
2705	if (intro)
2706	SAVEFREESV(sref);
2707	SvTAINT(dstr);
2708	return;
2709	}
2710	if (SvPVX(dstr)) {
2711	(void)SvOOK_off(dstr); /* backoff */
2712	if (SvLEN(dstr))
2713	Safefree(SvPVX(dstr));
2714	SvLEN(dstr)=SvCUR(dstr)=0;
2715	}
2716	}
2717	(void)SvOK_off(dstr);
2718	SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2719	SvROK_on(dstr);
2720	if (sflags & SVp_NOK) {
2721	SvNOK_on(dstr);
2722	SvNVX(dstr) = SvNVX(sstr);
2723	}
2724	if (sflags & SVp_IOK) {
2725	(void)SvIOK_on(dstr);
2726	SvIVX(dstr) = SvIVX(sstr);
2727	if (SvIsUV(sstr))
2728	SvIsUV_on(dstr);
2729	}
2730	if (SvAMAGIC(sstr)) {
2731	SvAMAGIC_on(dstr);
2732	}
2733	}
2734	else if (sflags & SVp_POK) {
2735
2736	/*
2737	* Check to see if we can just swipe the string. If so, it's a
2738	* possible small lose on short strings, but a big win on long ones.
2739	* It might even be a win on short strings if SvPVX(dstr)
2740	* has to be allocated and SvPVX(sstr) has to be freed.
2741	*/
2742
2743	if (SvTEMP(sstr) && /* slated for free anyway? */
2744	SvREFCNT(sstr) == 1 && /* and no other references to it? */
2745	!(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2746	{
2747	if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2748	if (SvOOK(dstr)) {
2749	SvFLAGS(dstr) &= ~SVf_OOK;
2750	Safefree(SvPVX(dstr) - SvIVX(dstr));
2751	}
2752	else if (SvLEN(dstr))
2753	Safefree(SvPVX(dstr));
2754	}
2755	(void)SvPOK_only(dstr);
2756	SvPV_set(dstr, SvPVX(sstr));
2757	SvLEN_set(dstr, SvLEN(sstr));
2758	SvCUR_set(dstr, SvCUR(sstr));
2759	if (SvUTF8(sstr))
2760	SvUTF8_on(dstr);
2761	else
2762	SvUTF8_off(dstr);
2763
2764	SvTEMP_off(dstr);
2765	(void)SvOK_off(sstr);
2766	SvPV_set(sstr, Nullch);
2767	SvLEN_set(sstr, 0);
2768	SvCUR_set(sstr, 0);
2769	SvTEMP_off(sstr);
2770	}
2771	else { /* have to copy actual string */
2772	STRLEN len = SvCUR(sstr);
2773
2774	SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2775	Move(SvPVX(sstr),SvPVX(dstr),len,char);
2776	SvCUR_set(dstr, len);
2777	*SvEND(dstr) = '\0';
2778	(void)SvPOK_only(dstr);
2779	}
2780	if (DO_UTF8(sstr))
2781	SvUTF8_on(dstr);
2782	/SUPPRESS 560/
2783	if (sflags & SVp_NOK) {
2784	SvNOK_on(dstr);
2785	SvNVX(dstr) = SvNVX(sstr);
2786	}
2787	if (sflags & SVp_IOK) {
2788	(void)SvIOK_on(dstr);
2789	SvIVX(dstr) = SvIVX(sstr);
2790	if (SvIsUV(sstr))
2791	SvIsUV_on(dstr);
2792	}
2793	}
2794	else if (sflags & SVp_NOK) {
2795	SvNVX(dstr) = SvNVX(sstr);
2796	(void)SvNOK_only(dstr);
2797	if (SvIOK(sstr)) {
2798	(void)SvIOK_on(dstr);
2799	SvIVX(dstr) = SvIVX(sstr);
2800	/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2801	if (SvIsUV(sstr))
2802	SvIsUV_on(dstr);
2803	}
2804	}
2805	else if (sflags & SVp_IOK) {
2806	(void)SvIOK_only(dstr);
2807	SvIVX(dstr) = SvIVX(sstr);
2808	if (SvIsUV(sstr))
2809	SvIsUV_on(dstr);
2810	}
2811	else {
2812	if (dtype == SVt_PVGV) {
2813	if (ckWARN(WARN_MISC))
2814	Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2815	}
2816	else
2817	(void)SvOK_off(dstr);
2818	}
2819	SvTAINT(dstr);
2820	}
2821
2822	/*
2823	=for apidoc sv_setsv_mg
2824
2825	Like C<sv_setsv>, but also handles 'set' magic.
2826
2827	=cut
2828	*/
2829
2830	void
2831	Perl_sv_setsv_mg(pTHX_ SV dstr, register SV sstr)
2832	{
2833	sv_setsv(dstr,sstr);
2834	SvSETMAGIC(dstr);
2835	}
2836
2837	/*
2838	=for apidoc sv_setpvn
2839
2840	Copies a string into an SV. The C<len> parameter indicates the number of
2841	bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2842
2843	=cut
2844	*/
2845
2846	void
2847	Perl_sv_setpvn(pTHX_ register SV sv, register const char ptr, register STRLEN len)
2848	{
2849	register char *dptr;
2850	assert(len >= 0); /* STRLEN is probably unsigned, so this may
2851	elicit a warning, but it won't hurt. */
2852	SV_CHECK_THINKFIRST(sv);
2853	if (!ptr) {
2854	(void)SvOK_off(sv);
2855	return;
2856	}
2857	(void)SvUPGRADE(sv, SVt_PV);
2858
2859	SvGROW(sv, len + 1);
2860	dptr = SvPVX(sv);
2861	Move(ptr,dptr,len,char);
2862	dptr[len] = '\0';
2863	SvCUR_set(sv, len);
2864	(void)SvPOK_only(sv); /* validate pointer */
2865	SvTAINT(sv);
2866	}
2867
2868	/*
2869	=for apidoc sv_setpvn_mg
2870
2871	Like C<sv_setpvn>, but also handles 'set' magic.
2872
2873	=cut
2874	*/
2875
2876	void
2877	Perl_sv_setpvn_mg(pTHX_ register SV sv, register const char ptr, register STRLEN len)
2878	{
2879	sv_setpvn(sv,ptr,len);
2880	SvSETMAGIC(sv);
2881	}
2882
2883	/*
2884	=for apidoc sv_setpv
2885
2886	Copies a string into an SV. The string must be null-terminated. Does not
2887	handle 'set' magic. See C<sv_setpv_mg>.
2888
2889	=cut
2890	*/
2891
2892	void
2893	Perl_sv_setpv(pTHX_ register SV sv, register const char ptr)
2894	{
2895	register STRLEN len;
2896
2897	SV_CHECK_THINKFIRST(sv);
2898	if (!ptr) {
2899	(void)SvOK_off(sv);
2900	return;
2901	}
2902	len = strlen(ptr);
2903	(void)SvUPGRADE(sv, SVt_PV);
2904
2905	SvGROW(sv, len + 1);
2906	Move(ptr,SvPVX(sv),len+1,char);
2907	SvCUR_set(sv, len);
2908	(void)SvPOK_only(sv); /* validate pointer */
2909	SvTAINT(sv);
2910	}
2911
2912	/*
2913	=for apidoc sv_setpv_mg
2914
2915	Like C<sv_setpv>, but also handles 'set' magic.
2916
2917	=cut
2918	*/
2919
2920	void
2921	Perl_sv_setpv_mg(pTHX_ register SV sv, register const char ptr)
2922	{
2923	sv_setpv(sv,ptr);
2924	SvSETMAGIC(sv);
2925	}
2926
2927	/*
2928	=for apidoc sv_usepvn
2929
2930	Tells an SV to use C<ptr> to find its string value. Normally the string is
2931	stored inside the SV but sv_usepvn allows the SV to use an outside string.
2932	The C<ptr> should point to memory that was allocated by C<malloc>. The
2933	string length, C<len>, must be supplied. This function will realloc the
2934	memory pointed to by C<ptr>, so that pointer should not be freed or used by
2935	the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2936	See C<sv_usepvn_mg>.
2937
2938	=cut
2939	*/
2940
2941	void
2942	Perl_sv_usepvn(pTHX_ register SV sv, register char ptr, register STRLEN len)
2943	{
2944	SV_CHECK_THINKFIRST(sv);
2945	(void)SvUPGRADE(sv, SVt_PV);
2946	if (!ptr) {
2947	(void)SvOK_off(sv);
2948	return;
2949	}
2950	(void)SvOOK_off(sv);
2951	if (SvPVX(sv) && SvLEN(sv))
2952	Safefree(SvPVX(sv));
2953	Renew(ptr, len+1, char);
2954	SvPVX(sv) = ptr;
2955	SvCUR_set(sv, len);
2956	SvLEN_set(sv, len+1);
2957	*SvEND(sv) = '\0';
2958	(void)SvPOK_only(sv); /* validate pointer */
2959	SvTAINT(sv);
2960	}
2961
2962	/*
2963	=for apidoc sv_usepvn_mg
2964
2965	Like C<sv_usepvn>, but also handles 'set' magic.
2966
2967	=cut
2968	*/
2969
2970	void
2971	Perl_sv_usepvn_mg(pTHX_ register SV sv, register char ptr, register STRLEN len)
2972	{
2973	sv_usepvn(sv,ptr,len);
2974	SvSETMAGIC(sv);
2975	}
2976
2977	void
2978	Perl_sv_force_normal(pTHX_ register SV *sv)
2979	{
2980	if (SvREADONLY(sv)) {
2981	dTHR;
2982	if (PL_curcop != &PL_compiling)
2983	Perl_croak(aTHX_ PL_no_modify);
2984	}
2985	if (SvROK(sv))
2986	sv_unref(sv);
2987	else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2988	sv_unglob(sv);
2989	}
2990
2991	/*
2992	=for apidoc sv_chop
2993
2994	Efficient removal of characters from the beginning of the string buffer.
2995	SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2996	the string buffer. The C<ptr> becomes the first character of the adjusted
2997	string.
2998
2999	=cut
3000	*/
3001
3002	void
3003	Perl_sv_chop(pTHX_ register SV sv, register char ptr) /* like set but assuming ptr is in sv */
3004
3005
3006	{
3007	register STRLEN delta;
3008
3009	if (!ptr \|\| !SvPOKp(sv))
3010	return;
3011	SV_CHECK_THINKFIRST(sv);
3012	if (SvTYPE(sv) < SVt_PVIV)
3013	sv_upgrade(sv,SVt_PVIV);
3014
3015	if (!SvOOK(sv)) {
3016	if (!SvLEN(sv)) { /* make copy of shared string */
3017	char *pvx = SvPVX(sv);
3018	STRLEN len = SvCUR(sv);
3019	SvGROW(sv, len + 1);
3020	Move(pvx,SvPVX(sv),len,char);
3021	*SvEND(sv) = '\0';
3022	}
3023	SvIVX(sv) = 0;
3024	SvFLAGS(sv) \|= SVf_OOK;
3025	}
3026	SvFLAGS(sv) &= ~(SVf_IOK\|SVf_NOK\|SVp_IOK\|SVp_NOK\|SVf_IVisUV);
3027	delta = ptr - SvPVX(sv);
3028	SvLEN(sv) -= delta;
3029	SvCUR(sv) -= delta;
3030	SvPVX(sv) += delta;
3031	SvIVX(sv) += delta;
3032	}
3033
3034	/*
3035	=for apidoc sv_catpvn
3036
3037	Concatenates the string onto the end of the string which is in the SV. The
3038	C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3039	'set' magic. See C<sv_catpvn_mg>.
3040
3041	=cut
3042	*/
3043
3044	void
3045	Perl_sv_catpvn(pTHX_ register SV sv, register const char ptr, register STRLEN len)
3046	{
3047	STRLEN tlen;
3048	char *junk;
3049
3050	junk = SvPV_force(sv, tlen);
3051	SvGROW(sv, tlen + len + 1);
3052	if (ptr == junk)
3053	ptr = SvPVX(sv);
3054	Move(ptr,SvPVX(sv)+tlen,len,char);
3055	SvCUR(sv) += len;
3056	*SvEND(sv) = '\0';
3057	(void)SvPOK_only_UTF8(sv); /* validate pointer */
3058	SvTAINT(sv);
3059	}
3060
3061	/*
3062	=for apidoc sv_catpvn_mg
3063
3064	Like C<sv_catpvn>, but also handles 'set' magic.
3065
3066	=cut
3067	*/
3068
3069	void
3070	Perl_sv_catpvn_mg(pTHX_ register SV sv, register const char ptr, register STRLEN len)
3071	{
3072	sv_catpvn(sv,ptr,len);
3073	SvSETMAGIC(sv);
3074	}
3075
3076	/*
3077	=for apidoc sv_catsv
3078
3079	Concatenates the string from SV C<ssv> onto the end of the string in SV
3080	C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3081
3082	=cut
3083	*/
3084
3085	void
3086	Perl_sv_catsv(pTHX_ SV dstr, register SV sstr)
3087	{
3088	char *s;
3089	STRLEN len;
3090	if (!sstr)
3091	return;
3092	if ((s = SvPV(sstr, len))) {
3093	if (SvUTF8(sstr))
3094	sv_utf8_upgrade(dstr);
3095	sv_catpvn(dstr,s,len);
3096	if (SvUTF8(sstr))
3097	SvUTF8_on(dstr);
3098	}
3099	}
3100
3101	/*
3102	=for apidoc sv_catsv_mg
3103
3104	Like C<sv_catsv>, but also handles 'set' magic.
3105
3106	=cut
3107	*/
3108
3109	void
3110	Perl_sv_catsv_mg(pTHX_ SV dstr, register SV sstr)
3111	{
3112	sv_catsv(dstr,sstr);
3113	SvSETMAGIC(dstr);
3114	}
3115
3116	/*
3117	=for apidoc sv_catpv
3118
3119	Concatenates the string onto the end of the string which is in the SV.
3120	Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3121
3122	=cut
3123	*/
3124
3125	void
3126	Perl_sv_catpv(pTHX_ register SV sv, register const char ptr)
3127	{
3128	register STRLEN len;
3129	STRLEN tlen;
3130	char *junk;
3131
3132	if (!ptr)
3133	return;
3134	junk = SvPV_force(sv, tlen);
3135	len = strlen(ptr);
3136	SvGROW(sv, tlen + len + 1);
3137	if (ptr == junk)
3138	ptr = SvPVX(sv);
3139	Move(ptr,SvPVX(sv)+tlen,len+1,char);
3140	SvCUR(sv) += len;
3141	(void)SvPOK_only_UTF8(sv); /* validate pointer */
3142	SvTAINT(sv);
3143	}
3144
3145	/*
3146	=for apidoc sv_catpv_mg
3147
3148	Like C<sv_catpv>, but also handles 'set' magic.
3149
3150	=cut
3151	*/
3152
3153	void
3154	Perl_sv_catpv_mg(pTHX_ register SV sv, register const char ptr)
3155	{
3156	sv_catpv(sv,ptr);
3157	SvSETMAGIC(sv);
3158	}
3159
3160	SV *
3161	Perl_newSV(pTHX_ STRLEN len)
3162	{
3163	register SV *sv;
3164
3165	new_SV(sv);
3166	if (len) {
3167	sv_upgrade(sv, SVt_PV);
3168	SvGROW(sv, len + 1);
3169	}
3170	return sv;
3171	}
3172
3173	/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3174
3175	/*
3176	=for apidoc sv_magic
3177
3178	Adds magic to an SV.
3179
3180	=cut
3181	*/
3182
3183	void
3184	Perl_sv_magic(pTHX_ register SV sv, SV obj, int how, const char *name, I32 namlen)
3185	{
3186	MAGIC* mg;
3187
3188	if (SvREADONLY(sv)) {
3189	dTHR;
3190	if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3191	Perl_croak(aTHX_ PL_no_modify);
3192	}
3193	if (SvMAGICAL(sv) \|\| (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3194	if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3195	if (how == 't')
3196	mg->mg_len \|= 1;
3197	return;
3198	}
3199	}
3200	else {
3201	(void)SvUPGRADE(sv, SVt_PVMG);
3202	}
3203	Newz(702,mg, 1, MAGIC);
3204	mg->mg_moremagic = SvMAGIC(sv);
3205
3206	SvMAGIC(sv) = mg;
3207	if (!obj \|\| obj == sv \|\| how == '#' \|\| how == 'r')
3208	mg->mg_obj = obj;
3209	else {
3210	dTHR;
3211	mg->mg_obj = SvREFCNT_inc(obj);
3212	mg->mg_flags \|= MGf_REFCOUNTED;
3213	}
3214	mg->mg_type = how;
3215	mg->mg_len = namlen;
3216	if (name)
3217	if (namlen >= 0)
3218	mg->mg_ptr = savepvn(name, namlen);
3219	else if (namlen == HEf_SVKEY)
3220	mg->mg_ptr = (char)SvREFCNT_inc((SV)name);
3221
3222	switch (how) {
3223	case 0:
3224	mg->mg_virtual = &PL_vtbl_sv;
3225	break;
3226	case 'A':
3227	mg->mg_virtual = &PL_vtbl_amagic;
3228	break;
3229	case 'a':
3230	mg->mg_virtual = &PL_vtbl_amagicelem;
3231	break;
3232	case 'c':
3233	mg->mg_virtual = 0;
3234	break;
3235	case 'B':
3236	mg->mg_virtual = &PL_vtbl_bm;
3237	break;
3238	case 'D':
3239	mg->mg_virtual = &PL_vtbl_regdata;
3240	break;
3241	case 'd':
3242	mg->mg_virtual = &PL_vtbl_regdatum;
3243	break;
3244	case 'E':
3245	mg->mg_virtual = &PL_vtbl_env;
3246	break;
3247	case 'f':
3248	mg->mg_virtual = &PL_vtbl_fm;
3249	break;
3250	case 'e':
3251	mg->mg_virtual = &PL_vtbl_envelem;
3252	break;
3253	case 'g':
3254	mg->mg_virtual = &PL_vtbl_mglob;
3255	break;
3256	case 'I':
3257	mg->mg_virtual = &PL_vtbl_isa;
3258	break;
3259	case 'i':
3260	mg->mg_virtual = &PL_vtbl_isaelem;
3261	break;
3262	case 'k':
3263	mg->mg_virtual = &PL_vtbl_nkeys;
3264	break;
3265	case 'L':
3266	SvRMAGICAL_on(sv);
3267	mg->mg_virtual = 0;
3268	break;
3269	case 'l':
3270	mg->mg_virtual = &PL_vtbl_dbline;
3271	break;
3272	#ifdef USE_THREADS
3273	case 'm':
3274	mg->mg_virtual = &PL_vtbl_mutex;
3275	break;
3276	#endif /* USE_THREADS */
3277	#ifdef USE_LOCALE_COLLATE
3278	case 'o':
3279	mg->mg_virtual = &PL_vtbl_collxfrm;
3280	break;
3281	#endif /* USE_LOCALE_COLLATE */
3282	case 'P':
3283	mg->mg_virtual = &PL_vtbl_pack;
3284	break;
3285	case 'p':
3286	case 'q':
3287	mg->mg_virtual = &PL_vtbl_packelem;
3288	break;
3289	case 'r':
3290	mg->mg_virtual = &PL_vtbl_regexp;
3291	break;
3292	case 'S':
3293	mg->mg_virtual = &PL_vtbl_sig;
3294	break;
3295	case 's':
3296	mg->mg_virtual = &PL_vtbl_sigelem;
3297	break;
3298	case 't':
3299	mg->mg_virtual = &PL_vtbl_taint;
3300	mg->mg_len = 1;
3301	break;
3302	case 'U':
3303	mg->mg_virtual = &PL_vtbl_uvar;
3304	break;
3305	case 'v':
3306	mg->mg_virtual = &PL_vtbl_vec;
3307	break;
3308	case 'x':
3309	mg->mg_virtual = &PL_vtbl_substr;
3310	break;
3311	case 'y':
3312	mg->mg_virtual = &PL_vtbl_defelem;
3313	break;
3314	case '*':
3315	mg->mg_virtual = &PL_vtbl_glob;
3316	break;
3317	case '#':
3318	mg->mg_virtual = &PL_vtbl_arylen;
3319	break;
3320	case '.':
3321	mg->mg_virtual = &PL_vtbl_pos;
3322	break;
3323	case '<':
3324	mg->mg_virtual = &PL_vtbl_backref;
3325	break;
3326	case '~': /* Reserved for use by extensions not perl internals. */
3327	/* Useful for attaching extension internal data to perl vars. */
3328	/* Note that multiple extensions may clash if magical scalars */
3329	/* etc holding private data from one are passed to another. */
3330	SvRMAGICAL_on(sv);
3331	break;
3332	default:
3333	Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3334	}
3335	mg_magical(sv);
3336	if (SvGMAGICAL(sv))
3337	SvFLAGS(sv) &= ~(SVf_IOK\|SVf_NOK\|SVf_POK);
3338	}
3339
3340	int
3341	Perl_sv_unmagic(pTHX_ SV *sv, int type)
3342	{
3343	MAGIC* mg;
3344	MAGIC** mgp;
3345	if (SvTYPE(sv) < SVt_PVMG \|\| !SvMAGIC(sv))
3346	return 0;
3347	mgp = &SvMAGIC(sv);
3348	for (mg = mgp; mg; mg = mgp) {
3349	if (mg->mg_type == type) {
3350	MGVTBL* vtbl = mg->mg_virtual;
3351	*mgp = mg->mg_moremagic;
3352	if (vtbl && vtbl->svt_free)
3353	CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3354	if (mg->mg_ptr && mg->mg_type != 'g')
3355	if (mg->mg_len >= 0)
3356	Safefree(mg->mg_ptr);
3357	else if (mg->mg_len == HEf_SVKEY)
3358	SvREFCNT_dec((SV*)mg->mg_ptr);
3359	if (mg->mg_flags & MGf_REFCOUNTED)
3360	SvREFCNT_dec(mg->mg_obj);
3361	Safefree(mg);
3362	}
3363	else
3364	mgp = &mg->mg_moremagic;
3365	}
3366	if (!SvMAGIC(sv)) {
3367	SvMAGICAL_off(sv);
3368	SvFLAGS(sv) \|= (SvFLAGS(sv) & (SVp_IOK\|SVp_NOK\|SVp_POK)) >> PRIVSHIFT;
3369	}
3370
3371	return 0;
3372	}
3373
3374	SV *
3375	Perl_sv_rvweaken(pTHX_ SV *sv)
3376	{
3377	SV *tsv;
3378	if (!SvOK(sv)) /* let undefs pass */
3379	return sv;
3380	if (!SvROK(sv))
3381	Perl_croak(aTHX_ "Can't weaken a nonreference");
3382	else if (SvWEAKREF(sv)) {
3383	dTHR;
3384	if (ckWARN(WARN_MISC))
3385	Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3386	return sv;
3387	}
3388	tsv = SvRV(sv);
3389	sv_add_backref(tsv, sv);
3390	SvWEAKREF_on(sv);
3391	SvREFCNT_dec(tsv);
3392	return sv;
3393	}
3394
3395	STATIC void
3396	S_sv_add_backref(pTHX_ SV tsv, SV sv)
3397	{
3398	AV *av;
3399	MAGIC *mg;
3400	if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3401	av = (AV*)mg->mg_obj;
3402	else {
3403	av = newAV();
3404	sv_magic(tsv, (SV*)av, '<', NULL, 0);
3405	SvREFCNT_dec(av); /* for sv_magic */
3406	}
3407	av_push(av,sv);
3408	}
3409
3410	STATIC void
3411	S_sv_del_backref(pTHX_ SV *sv)
3412	{
3413	AV *av;
3414	SV **svp;
3415	I32 i;
3416	SV *tsv = SvRV(sv);
3417	MAGIC *mg;
3418	if (!SvMAGICAL(tsv) \|\| !(mg = mg_find(tsv, '<')))
3419	Perl_croak(aTHX_ "panic: del_backref");
3420	av = (AV *)mg->mg_obj;
3421	svp = AvARRAY(av);
3422	i = AvFILLp(av);
3423	while (i >= 0) {
3424	if (svp[i] == sv) {
3425	svp[i] = &PL_sv_undef; /* XXX */
3426	}
3427	i--;
3428	}
3429	}
3430
3431	/*
3432	=for apidoc sv_insert
3433
3434	Inserts a string at the specified offset/length within the SV. Similar to
3435	the Perl substr() function.
3436
3437	=cut
3438	*/
3439
3440	void
3441	Perl_sv_insert(pTHX_ SV bigstr, STRLEN offset, STRLEN len, char little, STRLEN littlelen)
3442	{
3443	register char *big;
3444	register char *mid;
3445	register char *midend;
3446	register char *bigend;
3447	register I32 i;
3448	STRLEN curlen;
3449
3450
3451	if (!bigstr)
3452	Perl_croak(aTHX_ "Can't modify non-existent substring");
3453	SvPV_force(bigstr, curlen);
3454	if (offset + len > curlen) {
3455	SvGROW(bigstr, offset+len+1);
3456	Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3457	SvCUR_set(bigstr, offset+len);
3458	}
3459
3460	SvTAINT(bigstr);
3461	i = littlelen - len;
3462	if (i > 0) { /* string might grow */
3463	big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3464	mid = big + offset + len;
3465	midend = bigend = big + SvCUR(bigstr);
3466	bigend += i;
3467	*bigend = '\0';
3468	while (midend > mid) /* shove everything down */
3469	--bigend = --midend;
3470	Move(little,big+offset,littlelen,char);
3471	SvCUR(bigstr) += i;
3472	SvSETMAGIC(bigstr);
3473	return;
3474	}
3475	else if (i == 0) {
3476	Move(little,SvPVX(bigstr)+offset,len,char);
3477	SvSETMAGIC(bigstr);
3478	return;
3479	}
3480
3481	big = SvPVX(bigstr);
3482	mid = big + offset;
3483	midend = mid + len;
3484	bigend = big + SvCUR(bigstr);
3485
3486	if (midend > bigend)
3487	Perl_croak(aTHX_ "panic: sv_insert");
3488
3489	if (mid - big > bigend - midend) { /* faster to shorten from end */
3490	if (littlelen) {
3491	Move(little, mid, littlelen,char);
3492	mid += littlelen;
3493	}
3494	i = bigend - midend;
3495	if (i > 0) {
3496	Move(midend, mid, i,char);
3497	mid += i;
3498	}
3499	*mid = '\0';
3500	SvCUR_set(bigstr, mid - big);
3501	}
3502	/SUPPRESS 560/
3503	else if ((i = mid - big)) { /* faster from front */
3504	midend -= littlelen;
3505	mid = midend;
3506	sv_chop(bigstr,midend-i);
3507	big += i;
3508	while (i--)
3509	--midend = --big;
3510	if (littlelen)
3511	Move(little, mid, littlelen,char);
3512	}
3513	else if (littlelen) {
3514	midend -= littlelen;
3515	sv_chop(bigstr,midend);
3516	Move(little,midend,littlelen,char);
3517	}
3518	else {
3519	sv_chop(bigstr,midend);
3520	}
3521	SvSETMAGIC(bigstr);
3522	}
3523
3524	/* make sv point to what nstr did */
3525
3526	void
3527	Perl_sv_replace(pTHX_ register SV sv, register SV nsv)
3528	{
3529	dTHR;
3530	U32 refcnt = SvREFCNT(sv);
3531	SV_CHECK_THINKFIRST(sv);
3532	if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3533	Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3534	if (SvMAGICAL(sv)) {
3535	if (SvMAGICAL(nsv))
3536	mg_free(nsv);
3537	else
3538	sv_upgrade(nsv, SVt_PVMG);
3539	SvMAGIC(nsv) = SvMAGIC(sv);
3540	SvFLAGS(nsv) \|= SvMAGICAL(sv);
3541	SvMAGICAL_off(sv);
3542	SvMAGIC(sv) = 0;
3543	}
3544	SvREFCNT(sv) = 0;
3545	sv_clear(sv);
3546	assert(!SvREFCNT(sv));
3547	StructCopy(nsv,sv,SV);
3548	SvREFCNT(sv) = refcnt;
3549	SvFLAGS(nsv) \|= SVTYPEMASK; /* Mark as freed */
3550	del_SV(nsv);
3551	}
3552
3553	void
3554	Perl_sv_clear(pTHX_ register SV *sv)
3555	{
3556	HV* stash;
3557	assert(sv);
3558	assert(SvREFCNT(sv) == 0);
3559
3560	if (SvOBJECT(sv)) {
3561	dTHR;
3562	if (PL_defstash) { /* Still have a symbol table? */
3563	djSP;
3564	GV* destructor;
3565	SV tmpref;
3566
3567	Zero(&tmpref, 1, SV);
3568	sv_upgrade(&tmpref, SVt_RV);
3569	SvROK_on(&tmpref);
3570	SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3571	SvREFCNT(&tmpref) = 1;
3572
3573	do {
3574	stash = SvSTASH(sv);
3575	destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3576	if (destructor) {
3577	ENTER;
3578	PUSHSTACKi(PERLSI_DESTROY);
3579	SvRV(&tmpref) = SvREFCNT_inc(sv);
3580	EXTEND(SP, 2);
3581	PUSHMARK(SP);
3582	PUSHs(&tmpref);
3583	PUTBACK;
3584	call_sv((SV*)GvCV(destructor),
3585	G_DISCARD\|G_EVAL\|G_KEEPERR);
3586	SvREFCNT(sv)--;
3587	POPSTACK;
3588	SPAGAIN;
3589	LEAVE;
3590	}
3591	} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3592
3593	del_XRV(SvANY(&tmpref));
3594
3595	if (SvREFCNT(sv)) {
3596	if (PL_in_clean_objs)
3597	Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3598	HvNAME(stash));
3599	/* DESTROY gave object new lease on life */
3600	return;
3601	}
3602	}
3603
3604	if (SvOBJECT(sv)) {
3605	SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3606	SvOBJECT_off(sv); /* Curse the object. */
3607	if (SvTYPE(sv) != SVt_PVIO)
3608	--PL_sv_objcount; /* XXX Might want something more general */
3609	}
3610	}
3611	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3612	mg_free(sv);
3613	stash = NULL;
3614	switch (SvTYPE(sv)) {
3615	case SVt_PVIO:
3616	if (IoIFP(sv) &&
3617	IoIFP(sv) != PerlIO_stdin() &&
3618	IoIFP(sv) != PerlIO_stdout() &&
3619	IoIFP(sv) != PerlIO_stderr())
3620	{
3621	io_close((IO*)sv, FALSE);
3622	}
3623	if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3624	PerlDir_close(IoDIRP(sv));
3625	IoDIRP(sv) = (DIR*)NULL;
3626	Safefree(IoTOP_NAME(sv));
3627	Safefree(IoFMT_NAME(sv));
3628	Safefree(IoBOTTOM_NAME(sv));
3629	/* FALL THROUGH */
3630	case SVt_PVBM:
3631	goto freescalar;
3632	case SVt_PVCV:
3633	case SVt_PVFM:
3634	cv_undef((CV*)sv);
3635	goto freescalar;
3636	case SVt_PVHV:
3637	hv_undef((HV*)sv);
3638	break;
3639	case SVt_PVAV:
3640	av_undef((AV*)sv);
3641	break;
3642	case SVt_PVLV:
3643	SvREFCNT_dec(LvTARG(sv));
3644	goto freescalar;
3645	case SVt_PVGV:
3646	gp_free((GV*)sv);
3647	Safefree(GvNAME(sv));
3648	/* cannot decrease stash refcount yet, as we might recursively delete
3649	ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3650	of stash until current sv is completely gone.
3651	-- JohnPC, 27 Mar 1998 */
3652	stash = GvSTASH(sv);
3653	/* FALL THROUGH */
3654	case SVt_PVMG:
3655	case SVt_PVNV:
3656	case SVt_PVIV:
3657	freescalar:
3658	(void)SvOOK_off(sv);
3659	/* FALL THROUGH */
3660	case SVt_PV:
3661	case SVt_RV:
3662	if (SvROK(sv)) {
3663	if (SvWEAKREF(sv))
3664	sv_del_backref(sv);
3665	else
3666	SvREFCNT_dec(SvRV(sv));
3667	}
3668	else if (SvPVX(sv) && SvLEN(sv))
3669	Safefree(SvPVX(sv));
3670	break;
3671	/*
3672	case SVt_NV:
3673	case SVt_IV:
3674	case SVt_NULL:
3675	break;
3676	*/
3677	}
3678
3679	switch (SvTYPE(sv)) {
3680	case SVt_NULL:
3681	break;
3682	case SVt_IV:
3683	del_XIV(SvANY(sv));
3684	break;
3685	case SVt_NV:
3686	del_XNV(SvANY(sv));
3687	break;
3688	case SVt_RV:
3689	del_XRV(SvANY(sv));
3690	break;
3691	case SVt_PV:
3692	del_XPV(SvANY(sv));
3693	break;
3694	case SVt_PVIV:
3695	del_XPVIV(SvANY(sv));
3696	break;
3697	case SVt_PVNV:
3698	del_XPVNV(SvANY(sv));
3699	break;
3700	case SVt_PVMG:
3701	del_XPVMG(SvANY(sv));
3702	break;
3703	case SVt_PVLV:
3704	del_XPVLV(SvANY(sv));
3705	break;
3706	case SVt_PVAV:
3707	del_XPVAV(SvANY(sv));
3708	break;
3709	case SVt_PVHV:
3710	del_XPVHV(SvANY(sv));
3711	break;
3712	case SVt_PVCV:
3713	del_XPVCV(SvANY(sv));
3714	break;
3715	case SVt_PVGV:
3716	del_XPVGV(SvANY(sv));
3717	/* code duplication for increased performance. */
3718	SvFLAGS(sv) &= SVf_BREAK;
3719	SvFLAGS(sv) \|= SVTYPEMASK;
3720	/* decrease refcount of the stash that owns this GV, if any */
3721	if (stash)
3722	SvREFCNT_dec(stash);
3723	return; /* not break, SvFLAGS reset already happened */
3724	case SVt_PVBM:
3725	del_XPVBM(SvANY(sv));
3726	break;
3727	case SVt_PVFM:
3728	del_XPVFM(SvANY(sv));
3729	break;
3730	case SVt_PVIO:
3731	del_XPVIO(SvANY(sv));
3732	break;
3733	}
3734	SvFLAGS(sv) &= SVf_BREAK;
3735	SvFLAGS(sv) \|= SVTYPEMASK;
3736	}
3737
3738	SV *
3739	Perl_sv_newref(pTHX_ SV *sv)
3740	{
3741	if (sv)
3742	ATOMIC_INC(SvREFCNT(sv));
3743	return sv;
3744	}
3745
3746	void
3747	Perl_sv_free(pTHX_ SV *sv)
3748	{
3749	dTHR;
3750	int refcount_is_zero;
3751
3752	if (!sv)
3753	return;
3754	if (SvREFCNT(sv) == 0) {
3755	if (SvFLAGS(sv) & SVf_BREAK)
3756	return;
3757	if (PL_in_clean_all) /* All is fair */
3758	return;
3759	if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3760	/* make sure SvREFCNT(sv)==0 happens very seldom */
3761	SvREFCNT(sv) = (~(U32)0)/2;
3762	return;
3763	}
3764	if (ckWARN_d(WARN_INTERNAL))
3765	Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3766	return;
3767	}
3768	ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3769	if (!refcount_is_zero)
3770	return;
3771	#ifdef DEBUGGING
3772	if (SvTEMP(sv)) {
3773	if (ckWARN_d(WARN_DEBUGGING))
3774	Perl_warner(aTHX_ WARN_DEBUGGING,
3775	"Attempt to free temp prematurely: SV 0x%"UVxf,
3776	PTR2UV(sv));
3777	return;
3778	}
3779	#endif
3780	if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3781	/* make sure SvREFCNT(sv)==0 happens very seldom */
3782	SvREFCNT(sv) = (~(U32)0)/2;
3783	return;
3784	}
3785	sv_clear(sv);
3786	if (! SvREFCNT(sv))
3787	del_SV(sv);
3788	}
3789
3790	/*
3791	=for apidoc sv_len
3792
3793	Returns the length of the string in the SV. See also C<SvCUR>.
3794
3795	=cut
3796	*/
3797
3798	STRLEN
3799	Perl_sv_len(pTHX_ register SV *sv)
3800	{
3801	char *junk;
3802	STRLEN len;
3803
3804	if (!sv)
3805	return 0;
3806
3807	if (SvGMAGICAL(sv))
3808	len = mg_length(sv);
3809	else
3810	junk = SvPV(sv, len);
3811	return len;
3812	}
3813
3814	STRLEN
3815	Perl_sv_len_utf8(pTHX_ register SV *sv)
3816	{
3817	U8 *s;
3818	U8 *send;
3819	STRLEN len;
3820
3821	if (!sv)
3822	return 0;
3823
3824	#ifdef NOTYET
3825	if (SvGMAGICAL(sv))
3826	len = mg_length(sv);
3827	else
3828	#endif
3829	s = (U8*)SvPV(sv, len);
3830	send = s + len;
3831	len = 0;
3832	while (s < send) {
3833	s += UTF8SKIP(s);
3834	len++;
3835	}
3836	return len;
3837	}
3838
3839	void
3840	Perl_sv_pos_u2b(pTHX_ register SV sv, I32 offsetp, I32* lenp)
3841	{
3842	U8 *start;
3843	U8 *s;
3844	U8 *send;
3845	I32 uoffset = *offsetp;
3846	STRLEN len;
3847
3848	if (!sv)
3849	return;
3850
3851	start = s = (U8*)SvPV(sv, len);
3852	send = s + len;
3853	while (s < send && uoffset--)
3854	s += UTF8SKIP(s);
3855	if (s >= send)
3856	s = send;
3857	*offsetp = s - start;
3858	if (lenp) {
3859	I32 ulen = *lenp;
3860	start = s;
3861	while (s < send && ulen--)
3862	s += UTF8SKIP(s);
3863	if (s >= send)
3864	s = send;
3865	*lenp = s - start;
3866	}
3867	return;
3868	}
3869
3870	void
3871	Perl_sv_pos_b2u(pTHX_ register SV sv, I32 offsetp)
3872	{
3873	U8 *s;
3874	U8 *send;
3875	STRLEN len;
3876
3877	if (!sv)
3878	return;
3879
3880	s = (U8*)SvPV(sv, len);
3881	if (len < *offsetp)
3882	Perl_croak(aTHX_ "panic: bad byte offset");
3883	send = s + *offsetp;
3884	len = 0;
3885	while (s < send) {
3886	s += UTF8SKIP(s);
3887	++len;
3888	}
3889	if (s != send) {
3890	dTHR;
3891	if (ckWARN_d(WARN_UTF8))
3892	Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3893	--len;
3894	}
3895	*offsetp = len;
3896	return;
3897	}
3898
3899	/*
3900	=for apidoc sv_eq
3901
3902	Returns a boolean indicating whether the strings in the two SVs are
3903	identical.
3904
3905	=cut
3906	*/
3907
3908	I32
3909	Perl_sv_eq(pTHX_ register SV str1, register SV str2)
3910	{
3911	char *pv1;
3912	STRLEN cur1;
3913	char *pv2;
3914	STRLEN cur2;
3915
3916	if (!str1) {
3917	pv1 = "";
3918	cur1 = 0;
3919	}
3920	else
3921	pv1 = SvPV(str1, cur1);
3922
3923	if (!str2)
3924	return !cur1;
3925	else
3926	pv2 = SvPV(str2, cur2);
3927
3928	if (cur1 != cur2)
3929	return 0;
3930
3931	return memEQ(pv1, pv2, cur1);
3932	}
3933
3934	/*
3935	=for apidoc sv_cmp
3936
3937	Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3938	string in C<sv1> is less than, equal to, or greater than the string in
3939	C<sv2>.
3940
3941	=cut
3942	*/
3943
3944	I32
3945	Perl_sv_cmp(pTHX_ register SV str1, register SV str2)
3946	{
3947	STRLEN cur1, cur2;
3948	char pv1, pv2;
3949	I32 retval;
3950
3951	if (str1) {
3952	pv1 = SvPV(str1, cur1);
3953	}
3954	else {
3955	cur1 = 0;
3956	}
3957
3958	if (str2) {
3959	if (SvPOK(str2)) {
3960	if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3961	/* must upgrade other to UTF8 first */
3962	if (SvUTF8(str1)) {
3963	sv_utf8_upgrade(str2);
3964	}
3965	else {
3966	sv_utf8_upgrade(str1);
3967	/* refresh pointer and length */
3968	pv1 = SvPVX(str1);
3969	cur1 = SvCUR(str1);
3970	}
3971	}
3972	pv2 = SvPVX(str2);
3973	cur2 = SvCUR(str2);
3974	}
3975	else {
3976	pv2 = sv_2pv(str2, &cur2);
3977	}
3978	}
3979	else {
3980	cur2 = 0;
3981	}
3982
3983	if (!cur1)
3984	return cur2 ? -1 : 0;
3985
3986	if (!cur2)
3987	return 1;
3988
3989	retval = memcmp((void)pv1, (void)pv2, cur1 < cur2 ? cur1 : cur2);
3990
3991	if (retval)
3992	return retval < 0 ? -1 : 1;
3993
3994	if (cur1 == cur2)
3995	return 0;
3996	else
3997	return cur1 < cur2 ? -1 : 1;
3998	}
3999
4000	I32
4001	Perl_sv_cmp_locale(pTHX_ register SV sv1, register SV sv2)
4002	{
4003	#ifdef USE_LOCALE_COLLATE
4004
4005	char pv1, pv2;
4006	STRLEN len1, len2;
4007	I32 retval;
4008
4009	if (PL_collation_standard)
4010	goto raw_compare;
4011
4012	len1 = 0;
4013	pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4014	len2 = 0;
4015	pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4016
4017	if (!pv1 \|\| !len1) {
4018	if (pv2 && len2)
4019	return -1;
4020	else
4021	goto raw_compare;
4022	}
4023	else {
4024	if (!pv2 \|\| !len2)
4025	return 1;
4026	}
4027
4028	retval = memcmp((void)pv1, (void)pv2, len1 < len2 ? len1 : len2);
4029
4030	if (retval)
4031	return retval < 0 ? -1 : 1;
4032
4033	/*
4034	* When the result of collation is equality, that doesn't mean
4035	* that there are no differences -- some locales exclude some
4036	* characters from consideration. So to avoid false equalities,
4037	* we use the raw string as a tiebreaker.
4038	*/
4039
4040	raw_compare:
4041	/* FALL THROUGH */
4042
4043	#endif /* USE_LOCALE_COLLATE */
4044
4045	return sv_cmp(sv1, sv2);
4046	}
4047
4048	#ifdef USE_LOCALE_COLLATE
4049	/*
4050	* Any scalar variable may carry an 'o' magic that contains the
4051	* scalar data of the variable transformed to such a format that
4052	* a normal memory comparison can be used to compare the data
4053	* according to the locale settings.
4054	*/
4055	char *
4056	Perl_sv_collxfrm(pTHX_ SV sv, STRLEN nxp)
4057	{
4058	MAGIC *mg;
4059
4060	mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4061	if (!mg \|\| !mg->mg_ptr \|\| (U32)mg->mg_ptr != PL_collation_ix) {
4062	char s, xf;
4063	STRLEN len, xlen;
4064
4065	if (mg)
4066	Safefree(mg->mg_ptr);
4067	s = SvPV(sv, len);
4068	if ((xf = mem_collxfrm(s, len, &xlen))) {
4069	if (SvREADONLY(sv)) {
4070	SAVEFREEPV(xf);
4071	*nxp = xlen;
4072	return xf + sizeof(PL_collation_ix);
4073	}
4074	if (! mg) {
4075	sv_magic(sv, 0, 'o', 0, 0);
4076	mg = mg_find(sv, 'o');
4077	assert(mg);
4078	}
4079	mg->mg_ptr = xf;
4080	mg->mg_len = xlen;
4081	}
4082	else {
4083	if (mg) {
4084	mg->mg_ptr = NULL;
4085	mg->mg_len = -1;
4086	}
4087	}
4088	}
4089	if (mg && mg->mg_ptr) {
4090	*nxp = mg->mg_len;
4091	return mg->mg_ptr + sizeof(PL_collation_ix);
4092	}
4093	else {
4094	*nxp = 0;
4095	return NULL;
4096	}
4097	}
4098
4099	#endif /* USE_LOCALE_COLLATE */
4100
4101	char *
4102	Perl_sv_gets(pTHX_ register SV sv, register PerlIO fp, I32 append)
4103	{
4104	dTHR;
4105	char *rsptr;
4106	STRLEN rslen;
4107	register STDCHAR rslast;
4108	register STDCHAR *bp;
4109	register I32 cnt;
4110	I32 i;
4111
4112	SV_CHECK_THINKFIRST(sv);
4113	(void)SvUPGRADE(sv, SVt_PV);
4114
4115	SvSCREAM_off(sv);
4116
4117	if (RsSNARF(PL_rs)) {
4118	rsptr = NULL;
4119	rslen = 0;
4120	}
4121	else if (RsRECORD(PL_rs)) {
4122	I32 recsize, bytesread;
4123	char *buffer;
4124
4125	/* Grab the size of the record we're getting */
4126	recsize = SvIV(SvRV(PL_rs));
4127	(void)SvPOK_only(sv); /* Validate pointer */
4128	buffer = SvGROW(sv, recsize + 1);
4129	/* Go yank in */
4130	#ifdef VMS
4131	/* VMS wants read instead of fread, because fread doesn't respect */
4132	/* RMS record boundaries. This is not necessarily a good thing to be */
4133	/* doing, but we've got no other real choice */
4134	bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4135	#else
4136	bytesread = PerlIO_read(fp, buffer, recsize);
4137	#endif
4138	SvCUR_set(sv, bytesread);
4139	buffer[bytesread] = '\0';
4140	return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4141	}
4142	else if (RsPARA(PL_rs)) {
4143	rsptr = "\n\n";
4144	rslen = 2;
4145	}
4146	else
4147	rsptr = SvPV(PL_rs, rslen);
4148	rslast = rslen ? rsptr[rslen - 1] : '\0';
4149
4150	if (RsPARA(PL_rs)) { /* have to do this both before and after */
4151	do { /* to make sure file boundaries work right */
4152	if (PerlIO_eof(fp))
4153	return 0;
4154	i = PerlIO_getc(fp);
4155	if (i != '\n') {
4156	if (i == -1)
4157	return 0;
4158	PerlIO_ungetc(fp,i);
4159	break;
4160	}
4161	} while (i != EOF);
4162	}
4163
4164	/* See if we know enough about I/O mechanism to cheat it ! */
4165
4166	/* This used to be #ifdef test - it is made run-time test for ease
4167	of abstracting out stdio interface. One call should be cheap
4168	enough here - and may even be a macro allowing compile
4169	time optimization.
4170	*/
4171
4172	if (PerlIO_fast_gets(fp)) {
4173
4174	/*
4175	* We're going to steal some values from the stdio struct
4176	* and put EVERYTHING in the innermost loop into registers.
4177	*/
4178	register STDCHAR *ptr;
4179	STRLEN bpx;
4180	I32 shortbuffered;
4181
4182	#if defined(VMS) && defined(PERLIO_IS_STDIO)
4183	/* An ungetc()d char is handled separately from the regular
4184	* buffer, so we getc() it back out and stuff it in the buffer.
4185	*/
4186	i = PerlIO_getc(fp);
4187	if (i == EOF) return 0;
4188	(--((fp)->_ptr)) = (unsigned char) i;
4189	(*fp)->_cnt++;
4190	#endif
4191
4192	/* Here is some breathtakingly efficient cheating */
4193
4194	cnt = PerlIO_get_cnt(fp); /* get count into register */
4195	(void)SvPOK_only(sv); /* validate pointer */
4196	if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4197	if (cnt > 80 && SvLEN(sv) > append) {
4198	shortbuffered = cnt - SvLEN(sv) + append + 1;
4199	cnt -= shortbuffered;
4200	}
4201	else {
4202	shortbuffered = 0;
4203	/* remember that cnt can be negative */
4204	SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4205	}
4206	}
4207	else
4208	shortbuffered = 0;
4209	bp = (STDCHAR)SvPVX(sv) + append; / move these two too to registers */
4210	ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4211	DEBUG_P(PerlIO_printf(Perl_debug_log,
4212	"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4213	DEBUG_P(PerlIO_printf(Perl_debug_log,
4214	"Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4215	PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4216	PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4217	for (;;) {
4218	screamer:
4219	if (cnt > 0) {
4220	if (rslen) {
4221	while (cnt > 0) { /* this \| eat */
4222	cnt--;
4223	if ((bp++ = ptr++) == rslast) /* really \| dust */
4224	goto thats_all_folks; /* screams \| sed :-) */
4225	}
4226	}
4227	else {
4228	Copy(ptr, bp, cnt, char); /* this \| eat */
4229	bp += cnt; /* screams \| dust */
4230	ptr += cnt; /* louder \| sed :-) */
4231	cnt = 0;
4232	}
4233	}
4234
4235	if (shortbuffered) { /* oh well, must extend */
4236	cnt = shortbuffered;
4237	shortbuffered = 0;
4238	bpx = bp - (STDCHAR)SvPVX(sv); / box up before relocation */
4239	SvCUR_set(sv, bpx);
4240	SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4241	bp = (STDCHAR)SvPVX(sv) + bpx; / unbox after relocation */
4242	continue;
4243	}
4244
4245	DEBUG_P(PerlIO_printf(Perl_debug_log,
4246	"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4247	PTR2UV(ptr),(long)cnt));
4248	PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4249	DEBUG_P(PerlIO_printf(Perl_debug_log,
4250	"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4251	PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4252	PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4253	/* This used to call 'filbuf' in stdio form, but as that behaves like
4254	getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4255	another abstraction. */
4256	i = PerlIO_getc(fp); /* get more characters */
4257	DEBUG_P(PerlIO_printf(Perl_debug_log,
4258	"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4259	PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4260	PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4261	cnt = PerlIO_get_cnt(fp);
4262	ptr = (STDCHAR)PerlIO_get_ptr(fp); / reregisterize cnt and ptr */
4263	DEBUG_P(PerlIO_printf(Perl_debug_log,
4264	"Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4265
4266	if (i == EOF) /* all done for ever? */
4267	goto thats_really_all_folks;
4268
4269	bpx = bp - (STDCHAR)SvPVX(sv); / box up before relocation */
4270	SvCUR_set(sv, bpx);
4271	SvGROW(sv, bpx + cnt + 2);
4272	bp = (STDCHAR)SvPVX(sv) + bpx; / unbox after relocation */
4273
4274	bp++ = i; / store character from PerlIO_getc */
4275
4276	if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4277	goto thats_all_folks;
4278	}
4279
4280	thats_all_folks:
4281	if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) \|\|
4282	memNE((char*)bp - rslen, rsptr, rslen))
4283	goto screamer; /* go back to the fray */
4284	thats_really_all_folks:
4285	if (shortbuffered)
4286	cnt += shortbuffered;
4287	DEBUG_P(PerlIO_printf(Perl_debug_log,
4288	"Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4289	PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4290	DEBUG_P(PerlIO_printf(Perl_debug_log,
4291	"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4292	PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4293	PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4294	*bp = '\0';
4295	SvCUR_set(sv, bp - (STDCHAR)SvPVX(sv)); / set length */
4296	DEBUG_P(PerlIO_printf(Perl_debug_log,
4297	"Screamer: done, len=%ld, string=\|%.*s\|\n",
4298	(long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4299	}
4300	else
4301	{
4302	#ifndef EPOC
4303	/The big, slow, and stupid way /
4304	STDCHAR buf[8192];
4305	#else
4306	/* Need to work around EPOC SDK features */
4307	/* On WINS: MS VC5 generates calls to _chkstk, */
4308	/* if a `large' stack frame is allocated */
4309	/* gcc on MARM does not generate calls like these */
4310	STDCHAR buf[1024];
4311	#endif
4312
4313	screamer2:
4314	if (rslen) {
4315	register STDCHAR *bpe = buf + sizeof(buf);
4316	bp = buf;
4317	while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4318	; /* keep reading */
4319	cnt = bp - buf;
4320	}
4321	else {
4322	cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4323	/* Accomodate broken VAXC compiler, which applies U8 cast to
4324	* both args of ?: operator, causing EOF to change into 255
4325	*/
4326	if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4327	}
4328
4329	if (append)
4330	sv_catpvn(sv, (char *) buf, cnt);
4331	else
4332	sv_setpvn(sv, (char *) buf, cnt);
4333
4334	if (i != EOF && /* joy */
4335	(!rslen \|\|
4336	SvCUR(sv) < rslen \|\|
4337	memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4338	{
4339	append = -1;
4340	/*
4341	* If we're reading from a TTY and we get a short read,
4342	* indicating that the user hit his EOF character, we need
4343	* to notice it now, because if we try to read from the TTY
4344	* again, the EOF condition will disappear.
4345	*
4346	* The comparison of cnt to sizeof(buf) is an optimization
4347	* that prevents unnecessary calls to feof().
4348	*
4349	* - jik 9/25/96
4350	*/
4351	if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4352	goto screamer2;
4353	}
4354	}
4355
4356	if (RsPARA(PL_rs)) { /* have to do this both before and after */
4357	while (i != EOF) { /* to make sure file boundaries work right */
4358	i = PerlIO_getc(fp);
4359	if (i != '\n') {
4360	PerlIO_ungetc(fp,i);
4361	break;
4362	}
4363	}
4364	}
4365
4366	return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4367	}
4368
4369
4370	/*
4371	=for apidoc sv_inc
4372
4373	Auto-increment of the value in the SV.
4374
4375	=cut
4376	*/
4377
4378	void
4379	Perl_sv_inc(pTHX_ register SV *sv)
4380	{
4381	register char *d;
4382	int flags;
4383
4384	if (!sv)
4385	return;
4386	if (SvGMAGICAL(sv))
4387	mg_get(sv);
4388	if (SvTHINKFIRST(sv)) {
4389	if (SvREADONLY(sv)) {
4390	dTHR;
4391	if (PL_curcop != &PL_compiling)
4392	Perl_croak(aTHX_ PL_no_modify);
4393	}
4394	if (SvROK(sv)) {
4395	IV i;
4396	if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4397	return;
4398	i = PTR2IV(SvRV(sv));
4399	sv_unref(sv);
4400	sv_setiv(sv, i);
4401	}
4402	}
4403	flags = SvFLAGS(sv);
4404	if (flags & SVp_NOK) {
4405	(void)SvNOK_only(sv);
4406	SvNVX(sv) += 1.0;
4407	return;
4408	}
4409	if (flags & SVp_IOK) {
4410	if (SvIsUV(sv)) {
4411	if (SvUVX(sv) == UV_MAX)
4412	sv_setnv(sv, (NV)UV_MAX + 1.0);
4413	else
4414	(void)SvIOK_only_UV(sv);
4415	++SvUVX(sv);
4416	} else {
4417	if (SvIVX(sv) == IV_MAX)
4418	sv_setnv(sv, (NV)IV_MAX + 1.0);
4419	else {
4420	(void)SvIOK_only(sv);
4421	++SvIVX(sv);
4422	}
4423	}
4424	return;
4425	}
4426	if (!(flags & SVp_POK) \|\| !*SvPVX(sv)) {
4427	if ((flags & SVTYPEMASK) < SVt_PVNV)
4428	sv_upgrade(sv, SVt_NV);
4429	SvNVX(sv) = 1.0;
4430	(void)SvNOK_only(sv);
4431	return;
4432	}
4433	d = SvPVX(sv);
4434	while (isALPHA(*d)) d++;
4435	while (isDIGIT(*d)) d++;
4436	if (*d) {
4437	sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4438	return;
4439	}
4440	d--;
4441	while (d >= SvPVX(sv)) {
4442	if (isDIGIT(*d)) {
4443	if (++*d <= '9')
4444	return;
4445	*(d--) = '0';
4446	}
4447	else {
4448	#ifdef EBCDIC
4449	/* MKS: The original code here died if letters weren't consecutive.
4450	* at least it didn't have to worry about non-C locales. The
4451	* new code assumes that ('z'-'a')==('Z'-'A'), letters are
4452	* arranged in order (although not consecutively) and that only
4453	* [A-Za-z] are accepted by isALPHA in the C locale.
4454	*/
4455	if (d != 'z' && d != 'Z') {
4456	do { ++d; } while (!isALPHA(d));
4457	return;
4458	}
4459	*(d--) -= 'z' - 'a';
4460	#else
4461	++*d;
4462	if (isALPHA(*d))
4463	return;
4464	*(d--) -= 'z' - 'a' + 1;
4465	#endif
4466	}
4467	}
4468	/* oh,oh, the number grew */
4469	SvGROW(sv, SvCUR(sv) + 2);
4470	SvCUR(sv)++;
4471	for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4472	*d = d[-1];
4473	if (isDIGIT(d[1]))
4474	*d = '1';
4475	else
4476	*d = d[1];
4477	}
4478
4479	/*
4480	=for apidoc sv_dec
4481
4482	Auto-decrement of the value in the SV.
4483
4484	=cut
4485	*/
4486
4487	void
4488	Perl_sv_dec(pTHX_ register SV *sv)
4489	{
4490	int flags;
4491
4492	if (!sv)
4493	return;
4494	if (SvGMAGICAL(sv))
4495	mg_get(sv);
4496	if (SvTHINKFIRST(sv)) {
4497	if (SvREADONLY(sv)) {
4498	dTHR;
4499	if (PL_curcop != &PL_compiling)
4500	Perl_croak(aTHX_ PL_no_modify);
4501	}
4502	if (SvROK(sv)) {
4503	IV i;
4504	if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4505	return;
4506	i = PTR2IV(SvRV(sv));
4507	sv_unref(sv);
4508	sv_setiv(sv, i);
4509	}
4510	}
4511	flags = SvFLAGS(sv);
4512	if (flags & SVp_NOK) {
4513	SvNVX(sv) -= 1.0;
4514	(void)SvNOK_only(sv);
4515	return;
4516	}
4517	if (flags & SVp_IOK) {
4518	if (SvIsUV(sv)) {
4519	if (SvUVX(sv) == 0) {
4520	(void)SvIOK_only(sv);
4521	SvIVX(sv) = -1;
4522	}
4523	else {
4524	(void)SvIOK_only_UV(sv);
4525	--SvUVX(sv);
4526	}
4527	} else {
4528	if (SvIVX(sv) == IV_MIN)
4529	sv_setnv(sv, (NV)IV_MIN - 1.0);
4530	else {
4531	(void)SvIOK_only(sv);
4532	--SvIVX(sv);
4533	}
4534	}
4535	return;
4536	}
4537	if (!(flags & SVp_POK)) {
4538	if ((flags & SVTYPEMASK) < SVt_PVNV)
4539	sv_upgrade(sv, SVt_NV);
4540	SvNVX(sv) = -1.0;
4541	(void)SvNOK_only(sv);
4542	return;
4543	}
4544	sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4545	}
4546
4547	/*
4548	=for apidoc sv_mortalcopy
4549
4550	Creates a new SV which is a copy of the original SV. The new SV is marked
4551	as mortal.
4552
4553	=cut
4554	*/
4555
4556	/* Make a string that will exist for the duration of the expression
4557	* evaluation. Actually, it may have to last longer than that, but
4558	* hopefully we won't free it until it has been assigned to a
4559	* permanent location. */
4560
4561	SV *
4562	Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4563	{
4564	dTHR;
4565	register SV *sv;
4566
4567	new_SV(sv);
4568	sv_setsv(sv,oldstr);
4569	EXTEND_MORTAL(1);
4570	PL_tmps_stack[++PL_tmps_ix] = sv;
4571	SvTEMP_on(sv);
4572	return sv;
4573	}
4574
4575	/*
4576	=for apidoc sv_newmortal
4577
4578	Creates a new SV which is mortal. The reference count of the SV is set to 1.
4579
4580	=cut
4581	*/
4582
4583	SV *
4584	Perl_sv_newmortal(pTHX)
4585	{
4586	dTHR;
4587	register SV *sv;
4588
4589	new_SV(sv);
4590	SvFLAGS(sv) = SVs_TEMP;
4591	EXTEND_MORTAL(1);
4592	PL_tmps_stack[++PL_tmps_ix] = sv;
4593	return sv;
4594	}
4595
4596	/*
4597	=for apidoc sv_2mortal
4598
4599	Marks an SV as mortal. The SV will be destroyed when the current context
4600	ends.
4601
4602	=cut
4603	*/
4604
4605	/* same thing without the copying */
4606
4607	SV *
4608	Perl_sv_2mortal(pTHX_ register SV *sv)
4609	{
4610	dTHR;
4611	if (!sv)
4612	return sv;
4613	if (SvREADONLY(sv) && SvIMMORTAL(sv))
4614	return sv;
4615	EXTEND_MORTAL(1);
4616	PL_tmps_stack[++PL_tmps_ix] = sv;
4617	SvTEMP_on(sv);
4618	return sv;
4619	}
4620
4621	/*
4622	=for apidoc newSVpv
4623
4624	Creates a new SV and copies a string into it. The reference count for the
4625	SV is set to 1. If C<len> is zero, Perl will compute the length using
4626	strlen(). For efficiency, consider using C<newSVpvn> instead.
4627
4628	=cut
4629	*/
4630
4631	SV *
4632	Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4633	{
4634	register SV *sv;
4635
4636	new_SV(sv);
4637	if (!len)
4638	len = strlen(s);
4639	sv_setpvn(sv,s,len);
4640	return sv;
4641	}
4642
4643	/*
4644	=for apidoc newSVpvn
4645
4646	Creates a new SV and copies a string into it. The reference count for the
4647	SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4648	string. You are responsible for ensuring that the source string is at least
4649	C<len> bytes long.
4650
4651	=cut
4652	*/
4653
4654	SV *
4655	Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4656	{
4657	register SV *sv;
4658
4659	new_SV(sv);
4660	sv_setpvn(sv,s,len);
4661	return sv;
4662	}
4663
4664	#if defined(PERL_IMPLICIT_CONTEXT)
4665	SV *
4666	Perl_newSVpvf_nocontext(const char* pat, ...)
4667	{
4668	dTHX;
4669	register SV *sv;
4670	va_list args;
4671	va_start(args, pat);
4672	sv = vnewSVpvf(pat, &args);
4673	va_end(args);
4674	return sv;
4675	}
4676	#endif
4677
4678	/*
4679	=for apidoc newSVpvf
4680
4681	Creates a new SV an initialize it with the string formatted like
4682	C<sprintf>.
4683
4684	=cut
4685	*/
4686
4687	SV *
4688	Perl_newSVpvf(pTHX_ const char* pat, ...)
4689	{
4690	register SV *sv;
4691	va_list args;
4692	va_start(args, pat);
4693	sv = vnewSVpvf(pat, &args);
4694	va_end(args);
4695	return sv;
4696	}
4697
4698	SV *
4699	Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4700	{
4701	register SV *sv;
4702	new_SV(sv);
4703	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
4704	return sv;
4705	}
4706
4707	/*
4708	=for apidoc newSVnv
4709
4710	Creates a new SV and copies a floating point value into it.
4711	The reference count for the SV is set to 1.
4712
4713	=cut
4714	*/
4715
4716	SV *
4717	Perl_newSVnv(pTHX_ NV n)
4718	{
4719	register SV *sv;
4720
4721	new_SV(sv);
4722	sv_setnv(sv,n);
4723	return sv;
4724	}
4725
4726	/*
4727	=for apidoc newSViv
4728
4729	Creates a new SV and copies an integer into it. The reference count for the
4730	SV is set to 1.
4731
4732	=cut
4733	*/
4734
4735	SV *
4736	Perl_newSViv(pTHX_ IV i)
4737	{
4738	register SV *sv;
4739
4740	new_SV(sv);
4741	sv_setiv(sv,i);
4742	return sv;
4743	}
4744
4745	/*
4746	=for apidoc newSVuv
4747
4748	Creates a new SV and copies an unsigned integer into it.
4749	The reference count for the SV is set to 1.
4750
4751	=cut
4752	*/
4753
4754	SV *
4755	Perl_newSVuv(pTHX_ UV u)
4756	{
4757	register SV *sv;
4758
4759	new_SV(sv);
4760	sv_setuv(sv,u);
4761	return sv;
4762	}
4763
4764	/*
4765	=for apidoc newRV_noinc
4766
4767	Creates an RV wrapper for an SV. The reference count for the original
4768	SV is B<not> incremented.
4769
4770	=cut
4771	*/
4772
4773	SV *
4774	Perl_newRV_noinc(pTHX_ SV *tmpRef)
4775	{
4776	dTHR;
4777	register SV *sv;
4778
4779	new_SV(sv);
4780	sv_upgrade(sv, SVt_RV);
4781	SvTEMP_off(tmpRef);
4782	SvRV(sv) = tmpRef;
4783	SvROK_on(sv);
4784	return sv;
4785	}
4786
4787	/* newRV_inc is #defined to newRV in sv.h */
4788	SV *
4789	Perl_newRV(pTHX_ SV *tmpRef)
4790	{
4791	return newRV_noinc(SvREFCNT_inc(tmpRef));
4792	}
4793
4794	/*
4795	=for apidoc newSVsv
4796
4797	Creates a new SV which is an exact duplicate of the original SV.
4798
4799	=cut
4800	*/
4801
4802	/* make an exact duplicate of old */
4803
4804	SV *
4805	Perl_newSVsv(pTHX_ register SV *old)
4806	{
4807	dTHR;
4808	register SV *sv;
4809
4810	if (!old)
4811	return Nullsv;
4812	if (SvTYPE(old) == SVTYPEMASK) {
4813	if (ckWARN_d(WARN_INTERNAL))
4814	Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4815	return Nullsv;
4816	}
4817	new_SV(sv);
4818	if (SvTEMP(old)) {
4819	SvTEMP_off(old);
4820	sv_setsv(sv,old);
4821	SvTEMP_on(old);
4822	}
4823	else
4824	sv_setsv(sv,old);
4825	return sv;
4826	}
4827
4828	void
4829	Perl_sv_reset(pTHX_ register char s, HV stash)
4830	{
4831	register HE *entry;
4832	register GV *gv;
4833	register SV *sv;
4834	register I32 i;
4835	register PMOP *pm;
4836	register I32 max;
4837	char todo[PERL_UCHAR_MAX+1];
4838
4839	if (!stash)
4840	return;
4841
4842	if (!s) { / reset ?? searches */
4843	for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4844	pm->op_pmdynflags &= ~PMdf_USED;
4845	}
4846	return;
4847	}
4848
4849	/* reset variables */
4850
4851	if (!HvARRAY(stash))
4852	return;
4853
4854	Zero(todo, 256, char);
4855	while (*s) {
4856	i = (unsigned char)*s;
4857	if (s[1] == '-') {
4858	s += 2;
4859	}
4860	max = (unsigned char)*s++;
4861	for ( ; i <= max; i++) {
4862	todo[i] = 1;
4863	}
4864	for (i = 0; i <= (I32) HvMAX(stash); i++) {
4865	for (entry = HvARRAY(stash)[i];
4866	entry;
4867	entry = HeNEXT(entry))
4868	{
4869	if (!todo[(U8)*HeKEY(entry)])
4870	continue;
4871	gv = (GV*)HeVAL(entry);
4872	sv = GvSV(gv);
4873	if (SvTHINKFIRST(sv)) {
4874	if (!SvREADONLY(sv) && SvROK(sv))
4875	sv_unref(sv);
4876	continue;
4877	}
4878	(void)SvOK_off(sv);
4879	if (SvTYPE(sv) >= SVt_PV) {
4880	SvCUR_set(sv, 0);
4881	if (SvPVX(sv) != Nullch)
4882	*SvPVX(sv) = '\0';
4883	SvTAINT(sv);
4884	}
4885	if (GvAV(gv)) {
4886	av_clear(GvAV(gv));
4887	}
4888	if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4889	hv_clear(GvHV(gv));
4890	#ifndef VMS /* VMS has no environ array */
4891	if (gv == PL_envgv)
4892	environ[0] = Nullch;
4893	#endif
4894	}
4895	}
4896	}
4897	}
4898	}
4899
4900	IO*
4901	Perl_sv_2io(pTHX_ SV *sv)
4902	{
4903	IO* io;
4904	GV* gv;
4905	STRLEN n_a;
4906
4907	switch (SvTYPE(sv)) {
4908	case SVt_PVIO:
4909	io = (IO*)sv;
4910	break;
4911	case SVt_PVGV:
4912	gv = (GV*)sv;
4913	io = GvIO(gv);
4914	if (!io)
4915	Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4916	break;
4917	default:
4918	if (!SvOK(sv))
4919	Perl_croak(aTHX_ PL_no_usym, "filehandle");
4920	if (SvROK(sv))
4921	return sv_2io(SvRV(sv));
4922	gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4923	if (gv)
4924	io = GvIO(gv);
4925	else
4926	io = 0;
4927	if (!io)
4928	Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4929	break;
4930	}
4931	return io;
4932	}
4933
4934	CV *
4935	Perl_sv_2cv(pTHX_ SV sv, HV st, GV *gvp, I32 lref)
4936	{
4937	GV *gv;
4938	CV *cv;
4939	STRLEN n_a;
4940
4941	if (!sv)
4942	return *gvp = Nullgv, Nullcv;
4943	switch (SvTYPE(sv)) {
4944	case SVt_PVCV:
4945	*st = CvSTASH(sv);
4946	*gvp = Nullgv;
4947	return (CV*)sv;
4948	case SVt_PVHV:
4949	case SVt_PVAV:
4950	*gvp = Nullgv;
4951	return Nullcv;
4952	case SVt_PVGV:
4953	gv = (GV*)sv;
4954	*gvp = gv;
4955	*st = GvESTASH(gv);
4956	goto fix_gv;
4957
4958	default:
4959	if (SvGMAGICAL(sv))
4960	mg_get(sv);
4961	if (SvROK(sv)) {
4962	dTHR;
4963	SV *sp = &sv; / Used in tryAMAGICunDEREF macro. */
4964	tryAMAGICunDEREF(to_cv);
4965
4966	sv = SvRV(sv);
4967	if (SvTYPE(sv) == SVt_PVCV) {
4968	cv = (CV*)sv;
4969	*gvp = Nullgv;
4970	*st = CvSTASH(cv);
4971	return cv;
4972	}
4973	else if(isGV(sv))
4974	gv = (GV*)sv;
4975	else
4976	Perl_croak(aTHX_ "Not a subroutine reference");
4977	}
4978	else if (isGV(sv))
4979	gv = (GV*)sv;
4980	else
4981	gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4982	*gvp = gv;
4983	if (!gv)
4984	return Nullcv;
4985	*st = GvESTASH(gv);
4986	fix_gv:
4987	if (lref && !GvCVu(gv)) {
4988	SV *tmpsv;
4989	ENTER;
4990	tmpsv = NEWSV(704,0);
4991	gv_efullname3(tmpsv, gv, Nullch);
4992	/* XXX this is probably not what they think they're getting.
4993	* It has the same effect as "sub name;", i.e. just a forward
4994	* declaration! */
4995	newSUB(start_subparse(FALSE, 0),
4996	newSVOP(OP_CONST, 0, tmpsv),
4997	Nullop,
4998	Nullop);
4999	LEAVE;
5000	if (!GvCVu(gv))
5001	Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5002	}
5003	return GvCVu(gv);
5004	}
5005	}
5006
5007	I32
5008	Perl_sv_true(pTHX_ register SV *sv)
5009	{
5010	dTHR;
5011	if (!sv)
5012	return 0;
5013	if (SvPOK(sv)) {
5014	register XPV* tXpv;
5015	if ((tXpv = (XPV*)SvANY(sv)) &&
5016	(tXpv->xpv_cur > 1 \|\|
5017	(tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5018	return 1;
5019	else
5020	return 0;
5021	}
5022	else {
5023	if (SvIOK(sv))
5024	return SvIVX(sv) != 0;
5025	else {
5026	if (SvNOK(sv))
5027	return SvNVX(sv) != 0.0;
5028	else
5029	return sv_2bool(sv);
5030	}
5031	}
5032	}
5033
5034	IV
5035	Perl_sv_iv(pTHX_ register SV *sv)
5036	{
5037	if (SvIOK(sv)) {
5038	if (SvIsUV(sv))
5039	return (IV)SvUVX(sv);
5040	return SvIVX(sv);
5041	}
5042	return sv_2iv(sv);
5043	}
5044
5045	UV
5046	Perl_sv_uv(pTHX_ register SV *sv)
5047	{
5048	if (SvIOK(sv)) {
5049	if (SvIsUV(sv))
5050	return SvUVX(sv);
5051	return (UV)SvIVX(sv);
5052	}
5053	return sv_2uv(sv);
5054	}
5055
5056	NV
5057	Perl_sv_nv(pTHX_ register SV *sv)
5058	{
5059	if (SvNOK(sv))
5060	return SvNVX(sv);
5061	return sv_2nv(sv);
5062	}
5063
5064	char *
5065	Perl_sv_pv(pTHX_ SV *sv)
5066	{
5067	STRLEN n_a;
5068
5069	if (SvPOK(sv))
5070	return SvPVX(sv);
5071
5072	return sv_2pv(sv, &n_a);
5073	}
5074
5075	char *
5076	Perl_sv_pvn(pTHX_ SV sv, STRLEN lp)
5077	{
5078	if (SvPOK(sv)) {
5079	*lp = SvCUR(sv);
5080	return SvPVX(sv);
5081	}
5082	return sv_2pv(sv, lp);
5083	}
5084
5085	char *
5086	Perl_sv_pvn_force(pTHX_ SV sv, STRLEN lp)
5087	{
5088	char *s;
5089
5090	if (SvTHINKFIRST(sv) && !SvROK(sv))
5091	sv_force_normal(sv);
5092
5093	if (SvPOK(sv)) {
5094	*lp = SvCUR(sv);
5095	}
5096	else {
5097	if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5098	dTHR;
5099	Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5100	PL_op_name[PL_op->op_type]);
5101	}
5102	else
5103	s = sv_2pv(sv, lp);
5104	if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5105	STRLEN len = *lp;
5106
5107	if (SvROK(sv))
5108	sv_unref(sv);
5109	(void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5110	SvGROW(sv, len + 1);
5111	Move(s,SvPVX(sv),len,char);
5112	SvCUR_set(sv, len);
5113	*SvEND(sv) = '\0';
5114	}
5115	if (!SvPOK(sv)) {
5116	SvPOK_on(sv); /* validate pointer */
5117	SvTAINT(sv);
5118	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5119	PTR2UV(sv),SvPVX(sv)));
5120	}
5121	}
5122	return SvPVX(sv);
5123	}
5124
5125	char *
5126	Perl_sv_pvbyte(pTHX_ SV *sv)
5127	{
5128	return sv_pv(sv);
5129	}
5130
5131	char *
5132	Perl_sv_pvbyten(pTHX_ SV sv, STRLEN lp)
5133	{
5134	return sv_pvn(sv,lp);
5135	}
5136
5137	char *
5138	Perl_sv_pvbyten_force(pTHX_ SV sv, STRLEN lp)
5139	{
5140	return sv_pvn_force(sv,lp);
5141	}
5142
5143	char *
5144	Perl_sv_pvutf8(pTHX_ SV *sv)
5145	{
5146	sv_utf8_upgrade(sv);
5147	return sv_pv(sv);
5148	}
5149
5150	char *
5151	Perl_sv_pvutf8n(pTHX_ SV sv, STRLEN lp)
5152	{
5153	sv_utf8_upgrade(sv);
5154	return sv_pvn(sv,lp);
5155	}
5156
5157	char *
5158	Perl_sv_pvutf8n_force(pTHX_ SV sv, STRLEN lp)
5159	{
5160	sv_utf8_upgrade(sv);
5161	return sv_pvn_force(sv,lp);
5162	}
5163
5164	char *
5165	Perl_sv_reftype(pTHX_ SV *sv, int ob)
5166	{
5167	if (ob && SvOBJECT(sv))
5168	return HvNAME(SvSTASH(sv));
5169	else {
5170	switch (SvTYPE(sv)) {
5171	case SVt_NULL:
5172	case SVt_IV:
5173	case SVt_NV:
5174	case SVt_RV:
5175	case SVt_PV:
5176	case SVt_PVIV:
5177	case SVt_PVNV:
5178	case SVt_PVMG:
5179	case SVt_PVBM:
5180	if (SvROK(sv))
5181	return "REF";
5182	else
5183	return "SCALAR";
5184	case SVt_PVLV: return "LVALUE";
5185	case SVt_PVAV: return "ARRAY";
5186	case SVt_PVHV: return "HASH";
5187	case SVt_PVCV: return "CODE";
5188	case SVt_PVGV: return "GLOB";
5189	case SVt_PVFM: return "FORMAT";
5190	case SVt_PVIO: return "IO";
5191	default: return "UNKNOWN";
5192	}
5193	}
5194	}
5195
5196	/*
5197	=for apidoc sv_isobject
5198
5199	Returns a boolean indicating whether the SV is an RV pointing to a blessed
5200	object. If the SV is not an RV, or if the object is not blessed, then this
5201	will return false.
5202
5203	=cut
5204	*/
5205
5206	int
5207	Perl_sv_isobject(pTHX_ SV *sv)
5208	{
5209	if (!sv)
5210	return 0;
5211	if (SvGMAGICAL(sv))
5212	mg_get(sv);
5213	if (!SvROK(sv))
5214	return 0;
5215	sv = (SV*)SvRV(sv);
5216	if (!SvOBJECT(sv))
5217	return 0;
5218	return 1;
5219	}
5220
5221	/*
5222	=for apidoc sv_isa
5223
5224	Returns a boolean indicating whether the SV is blessed into the specified
5225	class. This does not check for subtypes; use C<sv_derived_from> to verify
5226	an inheritance relationship.
5227
5228	=cut
5229	*/
5230
5231	int
5232	Perl_sv_isa(pTHX_ SV sv, const char name)
5233	{
5234	if (!sv)
5235	return 0;
5236	if (SvGMAGICAL(sv))
5237	mg_get(sv);
5238	if (!SvROK(sv))
5239	return 0;
5240	sv = (SV*)SvRV(sv);
5241	if (!SvOBJECT(sv))
5242	return 0;
5243
5244	return strEQ(HvNAME(SvSTASH(sv)), name);
5245	}
5246
5247	/*
5248	=for apidoc newSVrv
5249
5250	Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5251	it will be upgraded to one. If C<classname> is non-null then the new SV will
5252	be blessed in the specified package. The new SV is returned and its
5253	reference count is 1.
5254
5255	=cut
5256	*/
5257
5258	SV*
5259	Perl_newSVrv(pTHX_ SV rv, const char classname)
5260	{
5261	dTHR;
5262	SV *sv;
5263
5264	new_SV(sv);
5265
5266	SV_CHECK_THINKFIRST(rv);
5267	SvAMAGIC_off(rv);
5268
5269	if (SvTYPE(rv) < SVt_RV)
5270	sv_upgrade(rv, SVt_RV);
5271
5272	(void)SvOK_off(rv);
5273	SvRV(rv) = sv;
5274	SvROK_on(rv);
5275
5276	if (classname) {
5277	HV* stash = gv_stashpv(classname, TRUE);
5278	(void)sv_bless(rv, stash);
5279	}
5280	return sv;
5281	}
5282
5283	/*
5284	=for apidoc sv_setref_pv
5285
5286	Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5287	argument will be upgraded to an RV. That RV will be modified to point to
5288	the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5289	into the SV. The C<classname> argument indicates the package for the
5290	blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5291	will be returned and will have a reference count of 1.
5292
5293	Do not use with other Perl types such as HV, AV, SV, CV, because those
5294	objects will become corrupted by the pointer copy process.
5295
5296	Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5297
5298	=cut
5299	*/
5300
5301	SV*
5302	Perl_sv_setref_pv(pTHX_ SV rv, const char classname, void *pv)
5303	{
5304	if (!pv) {
5305	sv_setsv(rv, &PL_sv_undef);
5306	SvSETMAGIC(rv);
5307	}
5308	else
5309	sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5310	return rv;
5311	}
5312
5313	/*
5314	=for apidoc sv_setref_iv
5315
5316	Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5317	argument will be upgraded to an RV. That RV will be modified to point to
5318	the new SV. The C<classname> argument indicates the package for the
5319	blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5320	will be returned and will have a reference count of 1.
5321
5322	=cut
5323	*/
5324
5325	SV*
5326	Perl_sv_setref_iv(pTHX_ SV rv, const char classname, IV iv)
5327	{
5328	sv_setiv(newSVrv(rv,classname), iv);
5329	return rv;
5330	}
5331
5332	/*
5333	=for apidoc sv_setref_nv
5334
5335	Copies a double into a new SV, optionally blessing the SV. The C<rv>
5336	argument will be upgraded to an RV. That RV will be modified to point to
5337	the new SV. The C<classname> argument indicates the package for the
5338	blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5339	will be returned and will have a reference count of 1.
5340
5341	=cut
5342	*/
5343
5344	SV*
5345	Perl_sv_setref_nv(pTHX_ SV rv, const char classname, NV nv)
5346	{
5347	sv_setnv(newSVrv(rv,classname), nv);
5348	return rv;
5349	}
5350
5351	/*
5352	=for apidoc sv_setref_pvn
5353
5354	Copies a string into a new SV, optionally blessing the SV. The length of the
5355	string must be specified with C<n>. The C<rv> argument will be upgraded to
5356	an RV. That RV will be modified to point to the new SV. The C<classname>
5357	argument indicates the package for the blessing. Set C<classname> to
5358	C<Nullch> to avoid the blessing. The new SV will be returned and will have
5359	a reference count of 1.
5360
5361	Note that C<sv_setref_pv> copies the pointer while this copies the string.
5362
5363	=cut
5364	*/
5365
5366	SV*
5367	Perl_sv_setref_pvn(pTHX_ SV rv, const char classname, char *pv, STRLEN n)
5368	{
5369	sv_setpvn(newSVrv(rv,classname), pv, n);
5370	return rv;
5371	}
5372
5373	/*
5374	=for apidoc sv_bless
5375
5376	Blesses an SV into a specified package. The SV must be an RV. The package
5377	must be designated by its stash (see C<gv_stashpv()>). The reference count
5378	of the SV is unaffected.
5379
5380	=cut
5381	*/
5382
5383	SV*
5384	Perl_sv_bless(pTHX_ SV sv, HV stash)
5385	{
5386	dTHR;
5387	SV *tmpRef;
5388	if (!SvROK(sv))
5389	Perl_croak(aTHX_ "Can't bless non-reference value");
5390	tmpRef = SvRV(sv);
5391	if (SvFLAGS(tmpRef) & (SVs_OBJECT\|SVf_READONLY)) {
5392	if (SvREADONLY(tmpRef))
5393	Perl_croak(aTHX_ PL_no_modify);
5394	if (SvOBJECT(tmpRef)) {
5395	if (SvTYPE(tmpRef) != SVt_PVIO)
5396	--PL_sv_objcount;
5397	SvREFCNT_dec(SvSTASH(tmpRef));
5398	}
5399	}
5400	SvOBJECT_on(tmpRef);
5401	if (SvTYPE(tmpRef) != SVt_PVIO)
5402	++PL_sv_objcount;
5403	(void)SvUPGRADE(tmpRef, SVt_PVMG);
5404	SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5405
5406	if (Gv_AMG(stash))
5407	SvAMAGIC_on(sv);
5408	else
5409	SvAMAGIC_off(sv);
5410
5411	return sv;
5412	}
5413
5414	STATIC void
5415	S_sv_unglob(pTHX_ SV *sv)
5416	{
5417	void *xpvmg;
5418
5419	assert(SvTYPE(sv) == SVt_PVGV);
5420	SvFAKE_off(sv);
5421	if (GvGP(sv))
5422	gp_free((GV*)sv);
5423	if (GvSTASH(sv)) {
5424	SvREFCNT_dec(GvSTASH(sv));
5425	GvSTASH(sv) = Nullhv;
5426	}
5427	sv_unmagic(sv, '*');
5428	Safefree(GvNAME(sv));
5429	GvMULTI_off(sv);
5430
5431	/* need to keep SvANY(sv) in the right arena */
5432	xpvmg = new_XPVMG();
5433	StructCopy(SvANY(sv), xpvmg, XPVMG);
5434	del_XPVGV(SvANY(sv));
5435	SvANY(sv) = xpvmg;
5436
5437	SvFLAGS(sv) &= ~SVTYPEMASK;
5438	SvFLAGS(sv) \|= SVt_PVMG;
5439	}
5440
5441	/*
5442	=for apidoc sv_unref
5443
5444	Unsets the RV status of the SV, and decrements the reference count of
5445	whatever was being referenced by the RV. This can almost be thought of
5446	as a reversal of C<newSVrv>. See C<SvROK_off>.
5447
5448	=cut
5449	*/
5450
5451	void
5452	Perl_sv_unref(pTHX_ SV *sv)
5453	{
5454	SV* rv = SvRV(sv);
5455
5456	if (SvWEAKREF(sv)) {
5457	sv_del_backref(sv);
5458	SvWEAKREF_off(sv);
5459	SvRV(sv) = 0;
5460	return;
5461	}
5462	SvRV(sv) = 0;
5463	SvROK_off(sv);
5464	if (SvREFCNT(rv) != 1 \|\| SvREADONLY(rv))
5465	SvREFCNT_dec(rv);
5466	else
5467	sv_2mortal(rv); /* Schedule for freeing later */
5468	}
5469
5470	void
5471	Perl_sv_taint(pTHX_ SV *sv)
5472	{
5473	sv_magic((sv), Nullsv, 't', Nullch, 0);
5474	}
5475
5476	void
5477	Perl_sv_untaint(pTHX_ SV *sv)
5478	{
5479	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5480	MAGIC *mg = mg_find(sv, 't');
5481	if (mg)
5482	mg->mg_len &= ~1;
5483	}
5484	}
5485
5486	bool
5487	Perl_sv_tainted(pTHX_ SV *sv)
5488	{
5489	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5490	MAGIC *mg = mg_find(sv, 't');
5491	if (mg && ((mg->mg_len & 1) \|\| ((mg->mg_len & 2) && mg->mg_obj == sv)))
5492	return TRUE;
5493	}
5494	return FALSE;
5495	}
5496
5497	/*
5498	=for apidoc sv_setpviv
5499
5500	Copies an integer into the given SV, also updating its string value.
5501	Does not handle 'set' magic. See C<sv_setpviv_mg>.
5502
5503	=cut
5504	*/
5505
5506	void
5507	Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5508	{
5509	char buf[TYPE_CHARS(UV)];
5510	char *ebuf;
5511	char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5512
5513	sv_setpvn(sv, ptr, ebuf - ptr);
5514	}
5515
5516
5517	/*
5518	=for apidoc sv_setpviv_mg
5519
5520	Like C<sv_setpviv>, but also handles 'set' magic.
5521
5522	=cut
5523	*/
5524
5525	void
5526	Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5527	{
5528	char buf[TYPE_CHARS(UV)];
5529	char *ebuf;
5530	char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5531
5532	sv_setpvn(sv, ptr, ebuf - ptr);
5533	SvSETMAGIC(sv);
5534	}
5535
5536	#if defined(PERL_IMPLICIT_CONTEXT)
5537	void
5538	Perl_sv_setpvf_nocontext(SV sv, const char pat, ...)
5539	{
5540	dTHX;
5541	va_list args;
5542	va_start(args, pat);
5543	sv_vsetpvf(sv, pat, &args);
5544	va_end(args);
5545	}
5546
5547
5548	void
5549	Perl_sv_setpvf_mg_nocontext(SV sv, const char pat, ...)
5550	{
5551	dTHX;
5552	va_list args;
5553	va_start(args, pat);
5554	sv_vsetpvf_mg(sv, pat, &args);
5555	va_end(args);
5556	}
5557	#endif
5558
5559	/*
5560	=for apidoc sv_setpvf
5561
5562	Processes its arguments like C<sprintf> and sets an SV to the formatted
5563	output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5564
5565	=cut
5566	*/
5567
5568	void
5569	Perl_sv_setpvf(pTHX_ SV sv, const char pat, ...)
5570	{
5571	va_list args;
5572	va_start(args, pat);
5573	sv_vsetpvf(sv, pat, &args);
5574	va_end(args);
5575	}
5576
5577	void
5578	Perl_sv_vsetpvf(pTHX_ SV sv, const char pat, va_list* args)
5579	{
5580	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
5581	}
5582
5583	/*
5584	=for apidoc sv_setpvf_mg
5585
5586	Like C<sv_setpvf>, but also handles 'set' magic.
5587
5588	=cut
5589	*/
5590
5591	void
5592	Perl_sv_setpvf_mg(pTHX_ SV sv, const char pat, ...)
5593	{
5594	va_list args;
5595	va_start(args, pat);
5596	sv_vsetpvf_mg(sv, pat, &args);
5597	va_end(args);
5598	}
5599
5600	void
5601	Perl_sv_vsetpvf_mg(pTHX_ SV sv, const char pat, va_list* args)
5602	{
5603	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
5604	SvSETMAGIC(sv);
5605	}
5606
5607	#if defined(PERL_IMPLICIT_CONTEXT)
5608	void
5609	Perl_sv_catpvf_nocontext(SV sv, const char pat, ...)
5610	{
5611	dTHX;
5612	va_list args;
5613	va_start(args, pat);
5614	sv_vcatpvf(sv, pat, &args);
5615	va_end(args);
5616	}
5617
5618	void
5619	Perl_sv_catpvf_mg_nocontext(SV sv, const char pat, ...)
5620	{
5621	dTHX;
5622	va_list args;
5623	va_start(args, pat);
5624	sv_vcatpvf_mg(sv, pat, &args);
5625	va_end(args);
5626	}
5627	#endif
5628
5629	/*
5630	=for apidoc sv_catpvf
5631
5632	Processes its arguments like C<sprintf> and appends the formatted output
5633	to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5634	typically be called after calling this function to handle 'set' magic.
5635
5636	=cut
5637	*/
5638
5639	void
5640	Perl_sv_catpvf(pTHX_ SV sv, const char pat, ...)
5641	{
5642	va_list args;
5643	va_start(args, pat);
5644	sv_vcatpvf(sv, pat, &args);
5645	va_end(args);
5646	}
5647
5648	void
5649	Perl_sv_vcatpvf(pTHX_ SV sv, const char pat, va_list* args)
5650	{
5651	sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
5652	}
5653
5654	/*
5655	=for apidoc sv_catpvf_mg
5656
5657	Like C<sv_catpvf>, but also handles 'set' magic.
5658
5659	=cut
5660	*/
5661
5662	void
5663	Perl_sv_catpvf_mg(pTHX_ SV sv, const char pat, ...)
5664	{
5665	va_list args;
5666	va_start(args, pat);
5667	sv_vcatpvf_mg(sv, pat, &args);
5668	va_end(args);
5669	}
5670
5671	void
5672	Perl_sv_vcatpvf_mg(pTHX_ SV sv, const char pat, va_list* args)
5673	{
5674	sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
5675	SvSETMAGIC(sv);
5676	}
5677
5678	/*
5679	=for apidoc sv_vsetpvfn
5680
5681	Works like C<vcatpvfn> but copies the text into the SV instead of
5682	appending it.
5683
5684	=cut
5685	*/
5686
5687	void
5688	Perl_sv_vsetpvfn(pTHX_ SV sv, const char pat, STRLEN patlen, va_list args, SV svargs, I32 svmax, bool maybe_tainted)
5689	{
5690	sv_setpvn(sv, "", 0);
5691	sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5692	}
5693
5694	/*
5695	=for apidoc sv_vcatpvfn
5696
5697	Processes its arguments like C<vsprintf> and appends the formatted output
5698	to an SV. Uses an array of SVs if the C style variable argument list is
5699	missing (NULL). When running with taint checks enabled, indicates via
5700	C<maybe_tainted> if results are untrustworthy (often due to the use of
5701	locales).
5702
5703	=cut
5704	*/
5705
5706	void
5707	Perl_sv_vcatpvfn(pTHX_ SV sv, const char pat, STRLEN patlen, va_list args, SV svargs, I32 svmax, bool maybe_tainted)
5708	{
5709	dTHR;
5710	char *p;
5711	char *q;
5712	char *patend;
5713	STRLEN origlen;
5714	I32 svix = 0;
5715	static char nullstr[] = "(null)";
5716	SV *argsv;
5717
5718	/* no matter what, this is a string now */
5719	(void)SvPV_force(sv, origlen);
5720
5721	/* special-case "", "%s", and "%_" */
5722	if (patlen == 0)
5723	return;
5724	if (patlen == 2 && pat[0] == '%') {
5725	switch (pat[1]) {
5726	case 's':
5727	if (args) {
5728	char s = va_arg(args, char*);
5729	sv_catpv(sv, s ? s : nullstr);
5730	}
5731	else if (svix < svmax) {
5732	sv_catsv(sv, *svargs);
5733	if (DO_UTF8(*svargs))
5734	SvUTF8_on(sv);
5735	}
5736	return;
5737	case '_':
5738	if (args) {
5739	argsv = va_arg(args, SV);
5740	sv_catsv(sv, argsv);
5741	if (DO_UTF8(argsv))
5742	SvUTF8_on(sv);
5743	return;
5744	}
5745	/* See comment on '_' below */
5746	break;
5747	}
5748	}
5749
5750	patend = (char*)pat + patlen;
5751	for (p = (char*)pat; p < patend; p = q) {
5752	bool alt = FALSE;
5753	bool left = FALSE;
5754	bool vectorize = FALSE;
5755	bool utf = FALSE;
5756	char fill = ' ';
5757	char plus = 0;
5758	char intsize = 0;
5759	STRLEN width = 0;
5760	STRLEN zeros = 0;
5761	bool has_precis = FALSE;
5762	STRLEN precis = 0;
5763	bool is_utf = FALSE;
5764
5765	char esignbuf[4];
5766	U8 utf8buf[UTF8_MAXLEN];
5767	STRLEN esignlen = 0;
5768
5769	char *eptr = Nullch;
5770	STRLEN elen = 0;
5771	/* Times 4: a decimal digit takes more than 3 binary digits.
5772	* NV_DIG: mantissa takes than many decimal digits.
5773	* Plus 32: Playing safe. */
5774	char ebuf[IV_DIG * 4 + NV_DIG + 32];
5775	/* large enough for "%#.#f" --chip */
5776	/* what about long double NVs? --jhi */
5777
5778	SV *vecsv;
5779	U8 vecstr = Null(U8);
5780	STRLEN veclen = 0;
5781	char c;
5782	int i;
5783	unsigned base;
5784	IV iv;
5785	UV uv;
5786	NV nv;
5787	STRLEN have;
5788	STRLEN need;
5789	STRLEN gap;
5790	char *dotstr = ".";
5791	STRLEN dotstrlen = 1;
5792
5793	for (q = p; q < patend && *q != '%'; ++q) ;
5794	if (q > p) {
5795	sv_catpvn(sv, p, q - p);
5796	p = q;
5797	}
5798	if (q++ >= patend)
5799	break;
5800
5801	/* FLAGS */
5802
5803	while (*q) {
5804	switch (*q) {
5805	case ' ':
5806	case '+':
5807	plus = *q++;
5808	continue;
5809
5810	case '-':
5811	left = TRUE;
5812	q++;
5813	continue;
5814
5815	case '0':
5816	fill = *q++;
5817	continue;
5818
5819	case '#':
5820	alt = TRUE;
5821	q++;
5822	continue;
5823
5824	case '': / printf("%vX",":",$ipv6addr) /
5825	if (q[1] != 'v')
5826	break;
5827	q++;
5828	if (args)
5829	vecsv = va_arg(args, SV);
5830	else if (svix < svmax)
5831	vecsv = svargs[svix++];
5832	else
5833	continue;
5834	dotstr = SvPVx(vecsv,dotstrlen);
5835	if (DO_UTF8(vecsv))
5836	is_utf = TRUE;
5837	/* FALL THROUGH */
5838
5839	case 'v':
5840	vectorize = TRUE;
5841	q++;
5842	if (args)
5843	vecsv = va_arg(args, SV);
5844	else if (svix < svmax)
5845	vecsv = svargs[svix++];
5846	else {
5847	vecstr = (U8*)"";
5848	veclen = 0;
5849	continue;
5850	}
5851	vecstr = (U8*)SvPVx(vecsv,veclen);
5852	utf = DO_UTF8(vecsv);
5853	continue;
5854
5855	default:
5856	break;
5857	}
5858	break;
5859	}
5860
5861	/* WIDTH */
5862
5863	switch (*q) {
5864	case '1': case '2': case '3':
5865	case '4': case '5': case '6':
5866	case '7': case '8': case '9':
5867	width = 0;
5868	while (isDIGIT(*q))
5869	width = width * 10 + (*q++ - '0');
5870	break;
5871
5872	case '*':
5873	if (args)
5874	i = va_arg(*args, int);
5875	else
5876	i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5877	left \|= (i < 0);
5878	width = (i < 0) ? -i : i;
5879	q++;
5880	break;
5881	}
5882
5883	/* PRECISION */
5884
5885	if (*q == '.') {
5886	q++;
5887	if (q == '') {
5888	if (args)
5889	i = va_arg(*args, int);
5890	else
5891	i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5892	precis = (i < 0) ? 0 : i;
5893	q++;
5894	}
5895	else {
5896	precis = 0;
5897	while (isDIGIT(*q))
5898	precis = precis * 10 + (*q++ - '0');
5899	}
5900	has_precis = TRUE;
5901	}
5902
5903	/* SIZE */
5904
5905	switch (*q) {
5906	#ifdef HAS_QUAD
5907	case 'L': /* Ld */
5908	case 'q': /* qd */
5909	intsize = 'q';
5910	q++;
5911	break;
5912	#endif
5913	case 'l':
5914	#ifdef HAS_QUAD
5915	if ((q + 1) == 'l') { / lld */
5916	intsize = 'q';
5917	q += 2;
5918	break;
5919	}
5920	#endif
5921	/* FALL THROUGH */
5922	case 'h':
5923	/* FALL THROUGH */
5924	case 'V':
5925	intsize = *q++;
5926	break;
5927	}
5928
5929	/* CONVERSION */
5930
5931	switch (c = *q++) {
5932
5933	/* STRINGS */
5934
5935	case '%':
5936	eptr = q - 1;
5937	elen = 1;
5938	goto string;
5939
5940	case 'c':
5941	if (args)
5942	uv = va_arg(*args, int);
5943	else
5944	uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5945	if ((uv > 255 \|\| (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5946	eptr = (char*)utf8buf;
5947	elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5948	is_utf = TRUE;
5949	}
5950	else {
5951	c = (char)uv;
5952	eptr = &c;
5953	elen = 1;
5954	}
5955	goto string;
5956
5957	case 's':
5958	if (args) {
5959	eptr = va_arg(args, char);
5960	if (eptr)
5961	#ifdef MACOS_TRADITIONAL
5962	/* On MacOS, %#s format is used for Pascal strings */
5963	if (alt)
5964	elen = *eptr++;
5965	else
5966	#endif
5967	elen = strlen(eptr);
5968	else {
5969	eptr = nullstr;
5970	elen = sizeof nullstr - 1;
5971	}
5972	}
5973	else if (svix < svmax) {
5974	argsv = svargs[svix++];
5975	eptr = SvPVx(argsv, elen);
5976	if (DO_UTF8(argsv)) {
5977	if (has_precis && precis < elen) {
5978	I32 p = precis;
5979	sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5980	precis = p;
5981	}
5982	if (width) { /* fudge width (can't fudge elen) */
5983	width += elen - sv_len_utf8(argsv);
5984	}
5985	is_utf = TRUE;
5986	}
5987	}
5988	goto string;
5989
5990	case '_':
5991	/*
5992	* The "%_" hack might have to be changed someday,
5993	* if ISO or ANSI decide to use '_' for something.
5994	* So we keep it hidden from users' code.
5995	*/
5996	if (!args)
5997	goto unknown;
5998	argsv = va_arg(args,SV);
5999	eptr = SvPVx(argsv, elen);
6000	if (DO_UTF8(argsv))
6001	is_utf = TRUE;
6002
6003	string:
6004	vectorize = FALSE;
6005	if (has_precis && elen > precis)
6006	elen = precis;
6007	break;
6008
6009	/* INTEGERS */
6010
6011	case 'p':
6012	if (args)
6013	uv = PTR2UV(va_arg(args, void));
6014	else
6015	uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6016	base = 16;
6017	goto integer;
6018
6019	case 'D':
6020	#ifdef IV_IS_QUAD
6021	intsize = 'q';
6022	#else
6023	intsize = 'l';
6024	#endif
6025	/* FALL THROUGH */
6026	case 'd':
6027	case 'i':
6028	if (vectorize) {
6029	I32 ulen;
6030	if (!veclen) {
6031	vectorize = FALSE;
6032	break;
6033	}
6034	if (utf)
6035	iv = (IV)utf8_to_uv(vecstr, &ulen);
6036	else {
6037	iv = *vecstr;
6038	ulen = 1;
6039	}
6040	vecstr += ulen;
6041	veclen -= ulen;
6042	}
6043	else if (args) {
6044	switch (intsize) {
6045	case 'h': iv = (short)va_arg(*args, int); break;
6046	default: iv = va_arg(*args, int); break;
6047	case 'l': iv = va_arg(*args, long); break;
6048	case 'V': iv = va_arg(*args, IV); break;
6049	#ifdef HAS_QUAD
6050	case 'q': iv = va_arg(*args, Quad_t); break;
6051	#endif
6052	}
6053	}
6054	else {
6055	iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6056	switch (intsize) {
6057	case 'h': iv = (short)iv; break;
6058	default: iv = (int)iv; break;
6059	case 'l': iv = (long)iv; break;
6060	case 'V': break;
6061	#ifdef HAS_QUAD
6062	case 'q': iv = (Quad_t)iv; break;
6063	#endif
6064	}
6065	}
6066	if (iv >= 0) {
6067	uv = iv;
6068	if (plus)
6069	esignbuf[esignlen++] = plus;
6070	}
6071	else {
6072	uv = -iv;
6073	esignbuf[esignlen++] = '-';
6074	}
6075	base = 10;
6076	goto integer;
6077
6078	case 'U':
6079	#ifdef IV_IS_QUAD
6080	intsize = 'q';
6081	#else
6082	intsize = 'l';
6083	#endif
6084	/* FALL THROUGH */
6085	case 'u':
6086	base = 10;
6087	goto uns_integer;
6088
6089	case 'b':
6090	base = 2;
6091	goto uns_integer;
6092
6093	case 'O':
6094	#ifdef IV_IS_QUAD
6095	intsize = 'q';
6096	#else
6097	intsize = 'l';
6098	#endif
6099	/* FALL THROUGH */
6100	case 'o':
6101	base = 8;
6102	goto uns_integer;
6103
6104	case 'X':
6105	case 'x':
6106	base = 16;
6107
6108	uns_integer:
6109	if (vectorize) {
6110	I32 ulen;
6111	vector:
6112	if (!veclen) {
6113	vectorize = FALSE;
6114	break;
6115	}
6116	if (utf)
6117	uv = utf8_to_uv(vecstr, &ulen);
6118	else {
6119	uv = *vecstr;
6120	ulen = 1;
6121	}
6122	vecstr += ulen;
6123	veclen -= ulen;
6124	}
6125	else if (args) {
6126	switch (intsize) {
6127	case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6128	default: uv = va_arg(*args, unsigned); break;
6129	case 'l': uv = va_arg(*args, unsigned long); break;
6130	case 'V': uv = va_arg(*args, UV); break;
6131	#ifdef HAS_QUAD
6132	case 'q': uv = va_arg(*args, Quad_t); break;
6133	#endif
6134	}
6135	}
6136	else {
6137	uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6138	switch (intsize) {
6139	case 'h': uv = (unsigned short)uv; break;
6140	default: uv = (unsigned)uv; break;
6141	case 'l': uv = (unsigned long)uv; break;
6142	case 'V': break;
6143	#ifdef HAS_QUAD
6144	case 'q': uv = (Quad_t)uv; break;
6145	#endif
6146	}
6147	}
6148
6149	integer:
6150	eptr = ebuf + sizeof ebuf;
6151	switch (base) {
6152	unsigned dig;
6153	case 16:
6154	if (!uv)
6155	alt = FALSE;
6156	p = (char*)((c == 'X')
6157	? "0123456789ABCDEF" : "0123456789abcdef");
6158	do {
6159	dig = uv & 15;
6160	*--eptr = p[dig];
6161	} while (uv >>= 4);
6162	if (alt) {
6163	esignbuf[esignlen++] = '0';
6164	esignbuf[esignlen++] = c; /* 'x' or 'X' */
6165	}
6166	break;
6167	case 8:
6168	do {
6169	dig = uv & 7;
6170	*--eptr = '0' + dig;
6171	} while (uv >>= 3);
6172	if (alt && *eptr != '0')
6173	*--eptr = '0';
6174	break;
6175	case 2:
6176	do {
6177	dig = uv & 1;
6178	*--eptr = '0' + dig;
6179	} while (uv >>= 1);
6180	if (alt) {
6181	esignbuf[esignlen++] = '0';
6182	esignbuf[esignlen++] = 'b';
6183	}
6184	break;
6185	default: /* it had better be ten or less */
6186	#if defined(PERL_Y2KWARN)
6187	if (ckWARN(WARN_Y2K)) {
6188	STRLEN n;
6189	char *s = SvPV(sv,n);
6190	if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6191	&& (n == 2 \|\| !isDIGIT(s[n-3])))
6192	{
6193	Perl_warner(aTHX_ WARN_Y2K,
6194	"Possible Y2K bug: %%%c %s",
6195	c, "format string following '19'");
6196	}
6197	}
6198	#endif
6199	do {
6200	dig = uv % base;
6201	*--eptr = '0' + dig;
6202	} while (uv /= base);
6203	break;
6204	}
6205	elen = (ebuf + sizeof ebuf) - eptr;
6206	if (has_precis) {
6207	if (precis > elen)
6208	zeros = precis - elen;
6209	else if (precis == 0 && elen == 1 && *eptr == '0')
6210	elen = 0;
6211	}
6212	break;
6213
6214	/* FLOATING POINT */
6215
6216	case 'F':
6217	c = 'f'; /* maybe %F isn't supported here */
6218	/* FALL THROUGH */
6219	case 'e': case 'E':
6220	case 'f':
6221	case 'g': case 'G':
6222
6223	/* This is evil, but floating point is even more evil */
6224
6225	vectorize = FALSE;
6226	if (args)
6227	nv = va_arg(*args, NV);
6228	else
6229	nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6230
6231	need = 0;
6232	if (c != 'e' && c != 'E') {
6233	i = PERL_INT_MIN;
6234	(void)Perl_frexp(nv, &i);
6235	if (i == PERL_INT_MIN)
6236	Perl_die(aTHX_ "panic: frexp");
6237	if (i > 0)
6238	need = BIT_DIGITS(i);
6239	}
6240	need += has_precis ? precis : 6; /* known default */
6241	if (need < width)
6242	need = width;
6243
6244	need += 20; /* fudge factor */
6245	if (PL_efloatsize < need) {
6246	Safefree(PL_efloatbuf);
6247	PL_efloatsize = need + 20; /* more fudge */
6248	New(906, PL_efloatbuf, PL_efloatsize, char);
6249	PL_efloatbuf[0] = '\0';
6250	}
6251
6252	eptr = ebuf + sizeof ebuf;
6253	*--eptr = '\0';
6254	*--eptr = c;
6255	#ifdef USE_LONG_DOUBLE
6256	{
6257	static char const my_prifldbl[] = PERL_PRIfldbl;
6258	char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6259	while (p >= my_prifldbl) { --eptr = p--; }
6260	}
6261	#endif
6262	if (has_precis) {
6263	base = precis;
6264	do { *--eptr = '0' + (base % 10); } while (base /= 10);
6265	*--eptr = '.';
6266	}
6267	if (width) {
6268	base = width;
6269	do { *--eptr = '0' + (base % 10); } while (base /= 10);
6270	}
6271	if (fill == '0')
6272	*--eptr = fill;
6273	if (left)
6274	*--eptr = '-';
6275	if (plus)
6276	*--eptr = plus;
6277	if (alt)
6278	*--eptr = '#';
6279	*--eptr = '%';
6280
6281	{
6282	RESTORE_NUMERIC_STANDARD();
6283	(void)sprintf(PL_efloatbuf, eptr, nv);
6284	RESTORE_NUMERIC_LOCAL();
6285	}
6286
6287	eptr = PL_efloatbuf;
6288	elen = strlen(PL_efloatbuf);
6289	break;
6290
6291	/* SPECIAL */
6292
6293	case 'n':
6294	vectorize = FALSE;
6295	i = SvCUR(sv) - origlen;
6296	if (args) {
6297	switch (intsize) {
6298	case 'h': (va_arg(args, short*)) = i; break;
6299	default: (va_arg(args, int*)) = i; break;
6300	case 'l': (va_arg(args, long*)) = i; break;
6301	case 'V': (va_arg(args, IV*)) = i; break;
6302	#ifdef HAS_QUAD
6303	case 'q': (va_arg(args, Quad_t*)) = i; break;
6304	#endif
6305	}
6306	}
6307	else if (svix < svmax)
6308	sv_setuv(svargs[svix++], (UV)i);
6309	continue; /* not "break" */
6310
6311	/* UNKNOWN */
6312
6313	default:
6314	unknown:
6315	vectorize = FALSE;
6316	if (!args && ckWARN(WARN_PRINTF) &&
6317	(PL_op->op_type == OP_PRTF \|\| PL_op->op_type == OP_SPRINTF)) {
6318	SV *msg = sv_newmortal();
6319	Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6320	(PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6321	if (c) {
6322	if (isPRINT(c))
6323	Perl_sv_catpvf(aTHX_ msg,
6324	"\"%%%c\"", c & 0xFF);
6325	else
6326	Perl_sv_catpvf(aTHX_ msg,
6327	"\"%%\\%03"UVof"\"",
6328	(UV)c & 0xFF);
6329	} else
6330	sv_catpv(msg, "end of string");
6331	Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6332	}
6333
6334	/* output mangled stuff ... */
6335	if (c == '\0')
6336	--q;
6337	eptr = p;
6338	elen = q - p;
6339
6340	/* ... right here, because formatting flags should not apply */
6341	SvGROW(sv, SvCUR(sv) + elen + 1);
6342	p = SvEND(sv);
6343	memcpy(p, eptr, elen);
6344	p += elen;
6345	*p = '\0';
6346	SvCUR(sv) = p - SvPVX(sv);
6347	continue; /* not "break" */
6348	}
6349
6350	have = esignlen + zeros + elen;
6351	need = (have > width ? have : width);
6352	gap = need - have;
6353
6354	SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6355	p = SvEND(sv);
6356	if (esignlen && fill == '0') {
6357	for (i = 0; i < esignlen; i++)
6358	*p++ = esignbuf[i];
6359	}
6360	if (gap && !left) {
6361	memset(p, fill, gap);
6362	p += gap;
6363	}
6364	if (esignlen && fill != '0') {
6365	for (i = 0; i < esignlen; i++)
6366	*p++ = esignbuf[i];
6367	}
6368	if (zeros) {
6369	for (i = zeros; i; i--)
6370	*p++ = '0';
6371	}
6372	if (elen) {
6373	memcpy(p, eptr, elen);
6374	p += elen;
6375	}
6376	if (gap && left) {
6377	memset(p, ' ', gap);
6378	p += gap;
6379	}
6380	if (vectorize) {
6381	if (veclen) {
6382	memcpy(p, dotstr, dotstrlen);
6383	p += dotstrlen;
6384	}
6385	else
6386	vectorize = FALSE; /* done iterating over vecstr */
6387	}
6388	if (is_utf)
6389	SvUTF8_on(sv);
6390	*p = '\0';
6391	SvCUR(sv) = p - SvPVX(sv);
6392	if (vectorize) {
6393	esignlen = 0;
6394	goto vector;
6395	}
6396	}
6397	}
6398
6399	#if defined(USE_ITHREADS)
6400
6401	#if defined(USE_THREADS)
6402	# include "error: USE_THREADS and USE_ITHREADS are incompatible"
6403	#endif
6404
6405	#ifndef GpREFCNT_inc
6406	# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6407	#endif
6408
6409
6410	#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6411	#define av_dup(s) (AV)sv_dup((SV)s)
6412	#define av_dup_inc(s) (AV)SvREFCNT_inc(sv_dup((SV)s))
6413	#define hv_dup(s) (HV)sv_dup((SV)s)
6414	#define hv_dup_inc(s) (HV)SvREFCNT_inc(sv_dup((SV)s))
6415	#define cv_dup(s) (CV)sv_dup((SV)s)
6416	#define cv_dup_inc(s) (CV)SvREFCNT_inc(sv_dup((SV)s))
6417	#define io_dup(s) (IO)sv_dup((SV)s)
6418	#define io_dup_inc(s) (IO)SvREFCNT_inc(sv_dup((SV)s))
6419	#define gv_dup(s) (GV)sv_dup((SV)s)
6420	#define gv_dup_inc(s) (GV)SvREFCNT_inc(sv_dup((SV)s))
6421	#define SAVEPV(p) (p ? savepv(p) : Nullch)
6422	#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6423
6424	REGEXP *
6425	Perl_re_dup(pTHX_ REGEXP *r)
6426	{
6427	/* XXX fix when pmop->op_pmregexp becomes shared */
6428	return ReREFCNT_inc(r);
6429	}
6430
6431	PerlIO *
6432	Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6433	{
6434	PerlIO *ret;
6435	if (!fp)
6436	return (PerlIO*)NULL;
6437
6438	/* look for it in the table first */
6439	ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6440	if (ret)
6441	return ret;
6442
6443	/* create anew and remember what it is */
6444	ret = PerlIO_fdupopen(fp);
6445	ptr_table_store(PL_ptr_table, fp, ret);
6446	return ret;
6447	}
6448
6449	DIR *
6450	Perl_dirp_dup(pTHX_ DIR *dp)
6451	{
6452	if (!dp)
6453	return (DIR*)NULL;
6454	/* XXX TODO */
6455	return dp;
6456	}
6457
6458	GP *
6459	Perl_gp_dup(pTHX_ GP *gp)
6460	{
6461	GP *ret;
6462	if (!gp)
6463	return (GP*)NULL;
6464	/* look for it in the table first */
6465	ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6466	if (ret)
6467	return ret;
6468
6469	/* create anew and remember what it is */
6470	Newz(0, ret, 1, GP);
6471	ptr_table_store(PL_ptr_table, gp, ret);
6472
6473	/* clone */
6474	ret->gp_refcnt = 0; /* must be before any other dups! */
6475	ret->gp_sv = sv_dup_inc(gp->gp_sv);
6476	ret->gp_io = io_dup_inc(gp->gp_io);
6477	ret->gp_form = cv_dup_inc(gp->gp_form);
6478	ret->gp_av = av_dup_inc(gp->gp_av);
6479	ret->gp_hv = hv_dup_inc(gp->gp_hv);
6480	ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6481	ret->gp_cv = cv_dup_inc(gp->gp_cv);
6482	ret->gp_cvgen = gp->gp_cvgen;
6483	ret->gp_flags = gp->gp_flags;
6484	ret->gp_line = gp->gp_line;
6485	ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6486	return ret;
6487	}
6488
6489	MAGIC *
6490	Perl_mg_dup(pTHX_ MAGIC *mg)
6491	{
6492	MAGIC mgret = (MAGIC)NULL;
6493	MAGIC *mgprev;
6494	if (!mg)
6495	return (MAGIC*)NULL;
6496	/* look for it in the table first */
6497	mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6498	if (mgret)
6499	return mgret;
6500
6501	for (; mg; mg = mg->mg_moremagic) {
6502	MAGIC *nmg;
6503	Newz(0, nmg, 1, MAGIC);
6504	if (!mgret)
6505	mgret = nmg;
6506	else
6507	mgprev->mg_moremagic = nmg;
6508	nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6509	nmg->mg_private = mg->mg_private;
6510	nmg->mg_type = mg->mg_type;
6511	nmg->mg_flags = mg->mg_flags;
6512	if (mg->mg_type == 'r') {
6513	nmg->mg_obj = (SV)re_dup((REGEXP)mg->mg_obj);
6514	}
6515	else {
6516	nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6517	? sv_dup_inc(mg->mg_obj)
6518	: sv_dup(mg->mg_obj);
6519	}
6520	nmg->mg_len = mg->mg_len;
6521	nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6522	if (mg->mg_ptr && mg->mg_type != 'g') {
6523	if (mg->mg_len >= 0) {
6524	nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6525	if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6526	AMT amtp = (AMT)mg->mg_ptr;
6527	AMT namtp = (AMT)nmg->mg_ptr;
6528	I32 i;
6529	for (i = 1; i < NofAMmeth; i++) {
6530	namtp->table[i] = cv_dup_inc(amtp->table[i]);
6531	}
6532	}
6533	}
6534	else if (mg->mg_len == HEf_SVKEY)
6535	nmg->mg_ptr = (char)sv_dup_inc((SV)mg->mg_ptr);
6536	}
6537	mgprev = nmg;
6538	}
6539	return mgret;
6540	}
6541
6542	PTR_TBL_t *
6543	Perl_ptr_table_new(pTHX)
6544	{
6545	PTR_TBL_t *tbl;
6546	Newz(0, tbl, 1, PTR_TBL_t);
6547	tbl->tbl_max = 511;
6548	tbl->tbl_items = 0;
6549	Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6550	return tbl;
6551	}
6552
6553	void *
6554	Perl_ptr_table_fetch(pTHX_ PTR_TBL_t tbl, void sv)
6555	{
6556	PTR_TBL_ENT_t *tblent;
6557	UV hash = PTR2UV(sv);
6558	assert(tbl);
6559	tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6560	for (; tblent; tblent = tblent->next) {
6561	if (tblent->oldval == sv)
6562	return tblent->newval;
6563	}
6564	return (void*)NULL;
6565	}
6566
6567	void
6568	Perl_ptr_table_store(pTHX_ PTR_TBL_t tbl, void oldv, void *newv)
6569	{
6570	PTR_TBL_ENT_t tblent, *otblent;
6571	/* XXX this may be pessimal on platforms where pointers aren't good
6572	* hash values e.g. if they grow faster in the most significant
6573	* bits */
6574	UV hash = PTR2UV(oldv);
6575	bool i = 1;
6576
6577	assert(tbl);
6578	otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6579	for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6580	if (tblent->oldval == oldv) {
6581	tblent->newval = newv;
6582	tbl->tbl_items++;
6583	return;
6584	}
6585	}
6586	Newz(0, tblent, 1, PTR_TBL_ENT_t);
6587	tblent->oldval = oldv;
6588	tblent->newval = newv;
6589	tblent->next = *otblent;
6590	*otblent = tblent;
6591	tbl->tbl_items++;
6592	if (i && tbl->tbl_items > tbl->tbl_max)
6593	ptr_table_split(tbl);
6594	}
6595
6596	void
6597	Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6598	{
6599	PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6600	UV oldsize = tbl->tbl_max + 1;
6601	UV newsize = oldsize * 2;
6602	UV i;
6603
6604	Renew(ary, newsize, PTR_TBL_ENT_t*);
6605	Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6606	tbl->tbl_max = --newsize;
6607	tbl->tbl_ary = ary;
6608	for (i=0; i < oldsize; i++, ary++) {
6609	PTR_TBL_ENT_t curentp, entp, *ent;
6610	if (!*ary)
6611	continue;
6612	curentp = ary + oldsize;
6613	for (entp = ary, ent = ary; ent; ent = entp) {
6614	if ((newsize & PTR2UV(ent->oldval)) != i) {
6615	*entp = ent->next;
6616	ent->next = *curentp;
6617	*curentp = ent;
6618	continue;
6619	}
6620	else
6621	entp = &ent->next;
6622	}
6623	}
6624	}
6625
6626	#ifdef DEBUGGING
6627	char *PL_watch_pvx;
6628	#endif
6629
6630	SV *
6631	Perl_sv_dup(pTHX_ SV *sstr)
6632	{
6633	SV *dstr;
6634
6635	if (!sstr \|\| SvTYPE(sstr) == SVTYPEMASK)
6636	return Nullsv;
6637	/* look for it in the table first */
6638	dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6639	if (dstr)
6640	return dstr;
6641
6642	/* create anew and remember what it is */
6643	new_SV(dstr);
6644	ptr_table_store(PL_ptr_table, sstr, dstr);
6645
6646	/* clone */
6647	SvFLAGS(dstr) = SvFLAGS(sstr);
6648	SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6649	SvREFCNT(dstr) = 0; /* must be before any other dups! */
6650
6651	#ifdef DEBUGGING
6652	if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6653	PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6654	PL_watch_pvx, SvPVX(sstr));
6655	#endif
6656
6657	switch (SvTYPE(sstr)) {
6658	case SVt_NULL:
6659	SvANY(dstr) = NULL;
6660	break;
6661	case SVt_IV:
6662	SvANY(dstr) = new_XIV();
6663	SvIVX(dstr) = SvIVX(sstr);
6664	break;
6665	case SVt_NV:
6666	SvANY(dstr) = new_XNV();
6667	SvNVX(dstr) = SvNVX(sstr);
6668	break;
6669	case SVt_RV:
6670	SvANY(dstr) = new_XRV();
6671	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6672	break;
6673	case SVt_PV:
6674	SvANY(dstr) = new_XPV();
6675	SvCUR(dstr) = SvCUR(sstr);
6676	SvLEN(dstr) = SvLEN(sstr);
6677	if (SvROK(sstr))
6678	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6679	else if (SvPVX(sstr) && SvLEN(sstr))
6680	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6681	else
6682	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6683	break;
6684	case SVt_PVIV:
6685	SvANY(dstr) = new_XPVIV();
6686	SvCUR(dstr) = SvCUR(sstr);
6687	SvLEN(dstr) = SvLEN(sstr);
6688	SvIVX(dstr) = SvIVX(sstr);
6689	if (SvROK(sstr))
6690	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6691	else if (SvPVX(sstr) && SvLEN(sstr))
6692	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6693	else
6694	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6695	break;
6696	case SVt_PVNV:
6697	SvANY(dstr) = new_XPVNV();
6698	SvCUR(dstr) = SvCUR(sstr);
6699	SvLEN(dstr) = SvLEN(sstr);
6700	SvIVX(dstr) = SvIVX(sstr);
6701	SvNVX(dstr) = SvNVX(sstr);
6702	if (SvROK(sstr))
6703	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6704	else if (SvPVX(sstr) && SvLEN(sstr))
6705	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6706	else
6707	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6708	break;
6709	case SVt_PVMG:
6710	SvANY(dstr) = new_XPVMG();
6711	SvCUR(dstr) = SvCUR(sstr);
6712	SvLEN(dstr) = SvLEN(sstr);
6713	SvIVX(dstr) = SvIVX(sstr);
6714	SvNVX(dstr) = SvNVX(sstr);
6715	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6716	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6717	if (SvROK(sstr))
6718	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6719	else if (SvPVX(sstr) && SvLEN(sstr))
6720	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6721	else
6722	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6723	break;
6724	case SVt_PVBM:
6725	SvANY(dstr) = new_XPVBM();
6726	SvCUR(dstr) = SvCUR(sstr);
6727	SvLEN(dstr) = SvLEN(sstr);
6728	SvIVX(dstr) = SvIVX(sstr);
6729	SvNVX(dstr) = SvNVX(sstr);
6730	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6731	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6732	if (SvROK(sstr))
6733	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6734	else if (SvPVX(sstr) && SvLEN(sstr))
6735	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6736	else
6737	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6738	BmRARE(dstr) = BmRARE(sstr);
6739	BmUSEFUL(dstr) = BmUSEFUL(sstr);
6740	BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6741	break;
6742	case SVt_PVLV:
6743	SvANY(dstr) = new_XPVLV();
6744	SvCUR(dstr) = SvCUR(sstr);
6745	SvLEN(dstr) = SvLEN(sstr);
6746	SvIVX(dstr) = SvIVX(sstr);
6747	SvNVX(dstr) = SvNVX(sstr);
6748	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6749	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6750	if (SvROK(sstr))
6751	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6752	else if (SvPVX(sstr) && SvLEN(sstr))
6753	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6754	else
6755	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6756	LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6757	LvTARGLEN(dstr) = LvTARGLEN(sstr);
6758	LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6759	LvTYPE(dstr) = LvTYPE(sstr);
6760	break;
6761	case SVt_PVGV:
6762	SvANY(dstr) = new_XPVGV();
6763	SvCUR(dstr) = SvCUR(sstr);
6764	SvLEN(dstr) = SvLEN(sstr);
6765	SvIVX(dstr) = SvIVX(sstr);
6766	SvNVX(dstr) = SvNVX(sstr);
6767	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6768	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6769	if (SvROK(sstr))
6770	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6771	else if (SvPVX(sstr) && SvLEN(sstr))
6772	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6773	else
6774	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6775	GvNAMELEN(dstr) = GvNAMELEN(sstr);
6776	GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6777	GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6778	GvFLAGS(dstr) = GvFLAGS(sstr);
6779	GvGP(dstr) = gp_dup(GvGP(sstr));
6780	(void)GpREFCNT_inc(GvGP(dstr));
6781	break;
6782	case SVt_PVIO:
6783	SvANY(dstr) = new_XPVIO();
6784	SvCUR(dstr) = SvCUR(sstr);
6785	SvLEN(dstr) = SvLEN(sstr);
6786	SvIVX(dstr) = SvIVX(sstr);
6787	SvNVX(dstr) = SvNVX(sstr);
6788	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6789	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6790	if (SvROK(sstr))
6791	SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6792	else if (SvPVX(sstr) && SvLEN(sstr))
6793	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6794	else
6795	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6796	IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6797	if (IoOFP(sstr) == IoIFP(sstr))
6798	IoOFP(dstr) = IoIFP(dstr);
6799	else
6800	IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6801	/* PL_rsfp_filters entries have fake IoDIRP() */
6802	if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6803	IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6804	else
6805	IoDIRP(dstr) = IoDIRP(sstr);
6806	IoLINES(dstr) = IoLINES(sstr);
6807	IoPAGE(dstr) = IoPAGE(sstr);
6808	IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6809	IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6810	IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6811	IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6812	IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6813	IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6814	IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6815	IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6816	IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6817	IoTYPE(dstr) = IoTYPE(sstr);
6818	IoFLAGS(dstr) = IoFLAGS(sstr);
6819	break;
6820	case SVt_PVAV:
6821	SvANY(dstr) = new_XPVAV();
6822	SvCUR(dstr) = SvCUR(sstr);
6823	SvLEN(dstr) = SvLEN(sstr);
6824	SvIVX(dstr) = SvIVX(sstr);
6825	SvNVX(dstr) = SvNVX(sstr);
6826	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6827	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6828	AvARYLEN((AV)dstr) = sv_dup_inc(AvARYLEN((AV)sstr));
6829	AvFLAGS((AV)dstr) = AvFLAGS((AV)sstr);
6830	if (AvARRAY((AV*)sstr)) {
6831	SV dst_ary, src_ary;
6832	SSize_t items = AvFILLp((AV*)sstr) + 1;
6833
6834	src_ary = AvARRAY((AV*)sstr);
6835	Newz(0, dst_ary, AvMAX((AV)sstr)+1, SV);
6836	ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6837	SvPVX(dstr) = (char*)dst_ary;
6838	AvALLOC((AV*)dstr) = dst_ary;
6839	if (AvREAL((AV*)sstr)) {
6840	while (items-- > 0)
6841	dst_ary++ = sv_dup_inc(src_ary++);
6842	}
6843	else {
6844	while (items-- > 0)
6845	dst_ary++ = sv_dup(src_ary++);
6846	}
6847	items = AvMAX((AV)sstr) - AvFILLp((AV)sstr);
6848	while (items-- > 0) {
6849	*dst_ary++ = &PL_sv_undef;
6850	}
6851	}
6852	else {
6853	SvPVX(dstr) = Nullch;
6854	AvALLOC((AV)dstr) = (SV*)NULL;
6855	}
6856	break;
6857	case SVt_PVHV:
6858	SvANY(dstr) = new_XPVHV();
6859	SvCUR(dstr) = SvCUR(sstr);
6860	SvLEN(dstr) = SvLEN(sstr);
6861	SvIVX(dstr) = SvIVX(sstr);
6862	SvNVX(dstr) = SvNVX(sstr);
6863	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6864	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6865	HvRITER((HV)dstr) = HvRITER((HV)sstr);
6866	if (HvARRAY((HV*)sstr)) {
6867	STRLEN i = 0;
6868	XPVHV dxhv = (XPVHV)SvANY(dstr);
6869	XPVHV sxhv = (XPVHV)SvANY(sstr);
6870	Newz(0, dxhv->xhv_array,
6871	PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6872	while (i <= sxhv->xhv_max) {
6873	((HE)dxhv->xhv_array)[i] = he_dup(((HE)sxhv->xhv_array)[i],
6874	!!HvSHAREKEYS(sstr));
6875	++i;
6876	}
6877	dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6878	}
6879	else {
6880	SvPVX(dstr) = Nullch;
6881	HvEITER((HV)dstr) = (HE)NULL;
6882	}
6883	HvPMROOT((HV)dstr) = HvPMROOT((HV)sstr); /* XXX */
6884	HvNAME((HV)dstr) = SAVEPV(HvNAME((HV)sstr));
6885	break;
6886	case SVt_PVFM:
6887	SvANY(dstr) = new_XPVFM();
6888	FmLINES(dstr) = FmLINES(sstr);
6889	goto dup_pvcv;
6890	/* NOTREACHED */
6891	case SVt_PVCV:
6892	SvANY(dstr) = new_XPVCV();
6893	dup_pvcv:
6894	SvCUR(dstr) = SvCUR(sstr);
6895	SvLEN(dstr) = SvLEN(sstr);
6896	SvIVX(dstr) = SvIVX(sstr);
6897	SvNVX(dstr) = SvNVX(sstr);
6898	SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6899	SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6900	if (SvPVX(sstr) && SvLEN(sstr))
6901	SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6902	else
6903	SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6904	CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6905	CvSTART(dstr) = CvSTART(sstr);
6906	CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6907	CvXSUB(dstr) = CvXSUB(sstr);
6908	CvXSUBANY(dstr) = CvXSUBANY(sstr);
6909	CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6910	CvDEPTH(dstr) = CvDEPTH(sstr);
6911	if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6912	/* XXX padlists are real, but pretend to be not */
6913	AvREAL_on(CvPADLIST(sstr));
6914	CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6915	AvREAL_off(CvPADLIST(sstr));
6916	AvREAL_off(CvPADLIST(dstr));
6917	}
6918	else
6919	CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6920	CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6921	CvFLAGS(dstr) = CvFLAGS(sstr);
6922	break;
6923	default:
6924	Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6925	break;
6926	}
6927
6928	if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6929	++PL_sv_objcount;
6930
6931	return dstr;
6932	}
6933
6934	PERL_CONTEXT *
6935	Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6936	{
6937	PERL_CONTEXT *ncxs;
6938
6939	if (!cxs)
6940	return (PERL_CONTEXT*)NULL;
6941
6942	/* look for it in the table first */
6943	ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6944	if (ncxs)
6945	return ncxs;
6946
6947	/* create anew and remember what it is */
6948	Newz(56, ncxs, max + 1, PERL_CONTEXT);
6949	ptr_table_store(PL_ptr_table, cxs, ncxs);
6950
6951	while (ix >= 0) {
6952	PERL_CONTEXT *cx = &cxs[ix];
6953	PERL_CONTEXT *ncx = &ncxs[ix];
6954	ncx->cx_type = cx->cx_type;
6955	if (CxTYPE(cx) == CXt_SUBST) {
6956	Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6957	}
6958	else {
6959	ncx->blk_oldsp = cx->blk_oldsp;
6960	ncx->blk_oldcop = cx->blk_oldcop;
6961	ncx->blk_oldretsp = cx->blk_oldretsp;
6962	ncx->blk_oldmarksp = cx->blk_oldmarksp;
6963	ncx->blk_oldscopesp = cx->blk_oldscopesp;
6964	ncx->blk_oldpm = cx->blk_oldpm;
6965	ncx->blk_gimme = cx->blk_gimme;
6966	switch (CxTYPE(cx)) {
6967	case CXt_SUB:
6968	ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6969	? cv_dup_inc(cx->blk_sub.cv)
6970	: cv_dup(cx->blk_sub.cv));
6971	ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6972	? av_dup_inc(cx->blk_sub.argarray)
6973	: Nullav);
6974	ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6975	ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6976	ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6977	ncx->blk_sub.lval = cx->blk_sub.lval;
6978	break;
6979	case CXt_EVAL:
6980	ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6981	ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6982	ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6983	ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6984	ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6985	break;
6986	case CXt_LOOP:
6987	ncx->blk_loop.label = cx->blk_loop.label;
6988	ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6989	ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6990	ncx->blk_loop.next_op = cx->blk_loop.next_op;
6991	ncx->blk_loop.last_op = cx->blk_loop.last_op;
6992	ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6993	? cx->blk_loop.iterdata
6994	: gv_dup((GV*)cx->blk_loop.iterdata));
6995	ncx->blk_loop.oldcurpad
6996	= (SV**)ptr_table_fetch(PL_ptr_table,
6997	cx->blk_loop.oldcurpad);
6998	ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6999	ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7000	ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7001	ncx->blk_loop.iterix = cx->blk_loop.iterix;
7002	ncx->blk_loop.itermax = cx->blk_loop.itermax;
7003	break;
7004	case CXt_FORMAT:
7005	ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7006	ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7007	ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7008	ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7009	break;
7010	case CXt_BLOCK:
7011	case CXt_NULL:
7012	break;
7013	}
7014	}
7015	--ix;
7016	}
7017	return ncxs;
7018	}
7019
7020	PERL_SI *
7021	Perl_si_dup(pTHX_ PERL_SI *si)
7022	{
7023	PERL_SI *nsi;
7024
7025	if (!si)
7026	return (PERL_SI*)NULL;
7027
7028	/* look for it in the table first */
7029	nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7030	if (nsi)
7031	return nsi;
7032
7033	/* create anew and remember what it is */
7034	Newz(56, nsi, 1, PERL_SI);
7035	ptr_table_store(PL_ptr_table, si, nsi);
7036
7037	nsi->si_stack = av_dup_inc(si->si_stack);
7038	nsi->si_cxix = si->si_cxix;
7039	nsi->si_cxmax = si->si_cxmax;
7040	nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7041	nsi->si_type = si->si_type;
7042	nsi->si_prev = si_dup(si->si_prev);
7043	nsi->si_next = si_dup(si->si_next);
7044	nsi->si_markoff = si->si_markoff;
7045
7046	return nsi;
7047	}
7048
7049	#define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7050	#define TOPINT(ss,ix) ((ss)[ix].any_i32)
7051	#define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7052	#define TOPLONG(ss,ix) ((ss)[ix].any_long)
7053	#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7054	#define TOPIV(ss,ix) ((ss)[ix].any_iv)
7055	#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7056	#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7057	#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7058	#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7059	#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7060	#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7061
7062	/* XXXXX todo */
7063	#define pv_dup_inc(p) SAVEPV(p)
7064	#define pv_dup(p) SAVEPV(p)
7065	#define svp_dup_inc(p,pp) any_dup(p,pp)
7066
7067	void *
7068	Perl_any_dup(pTHX_ void v, PerlInterpreter proto_perl)
7069	{
7070	void *ret;
7071
7072	if (!v)
7073	return (void*)NULL;
7074
7075	/* look for it in the table first */
7076	ret = ptr_table_fetch(PL_ptr_table, v);
7077	if (ret)
7078	return ret;
7079
7080	/* see if it is part of the interpreter structure */
7081	if (v >= (void)proto_perl && v < (void)(proto_perl+1))
7082	ret = (void)(((char)aTHXo) + (((char)v) - (char)proto_perl));
7083	else
7084	ret = v;
7085
7086	return ret;
7087	}
7088
7089	ANY *
7090	Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7091	{
7092	ANY *ss = proto_perl->Tsavestack;
7093	I32 ix = proto_perl->Tsavestack_ix;
7094	I32 max = proto_perl->Tsavestack_max;
7095	ANY *nss;
7096	SV *sv;
7097	GV *gv;
7098	AV *av;
7099	HV *hv;
7100	void* ptr;
7101	int intval;
7102	long longval;
7103	GP *gp;
7104	IV iv;
7105	I32 i;
7106	char *c;
7107	void (dptr) (void);
7108	void (dxptr) (pTHXo_ void);
7109	OP *o;
7110
7111	Newz(54, nss, max, ANY);
7112
7113	while (ix > 0) {
7114	i = POPINT(ss,ix);
7115	TOPINT(nss,ix) = i;
7116	switch (i) {
7117	case SAVEt_ITEM: /* normal string */
7118	sv = (SV*)POPPTR(ss,ix);
7119	TOPPTR(nss,ix) = sv_dup_inc(sv);
7120	sv = (SV*)POPPTR(ss,ix);
7121	TOPPTR(nss,ix) = sv_dup_inc(sv);
7122	break;
7123	case SAVEt_SV: /* scalar reference */
7124	sv = (SV*)POPPTR(ss,ix);
7125	TOPPTR(nss,ix) = sv_dup_inc(sv);
7126	gv = (GV*)POPPTR(ss,ix);
7127	TOPPTR(nss,ix) = gv_dup_inc(gv);
7128	break;
7129	case SAVEt_GENERIC_SVREF: /* generic sv */
7130	case SAVEt_SVREF: /* scalar reference */
7131	sv = (SV*)POPPTR(ss,ix);
7132	TOPPTR(nss,ix) = sv_dup_inc(sv);
7133	ptr = POPPTR(ss,ix);
7134	TOPPTR(nss,ix) = svp_dup_inc((SV*)ptr, proto_perl);/ XXXXX */
7135	break;
7136	case SAVEt_AV: /* array reference */
7137	av = (AV*)POPPTR(ss,ix);
7138	TOPPTR(nss,ix) = av_dup_inc(av);
7139	gv = (GV*)POPPTR(ss,ix);
7140	TOPPTR(nss,ix) = gv_dup(gv);
7141	break;
7142	case SAVEt_HV: /* hash reference */
7143	hv = (HV*)POPPTR(ss,ix);
7144	TOPPTR(nss,ix) = hv_dup_inc(hv);
7145	gv = (GV*)POPPTR(ss,ix);
7146	TOPPTR(nss,ix) = gv_dup(gv);
7147	break;
7148	case SAVEt_INT: /* int reference */
7149	ptr = POPPTR(ss,ix);
7150	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7151	intval = (int)POPINT(ss,ix);
7152	TOPINT(nss,ix) = intval;
7153	break;
7154	case SAVEt_LONG: /* long reference */
7155	ptr = POPPTR(ss,ix);
7156	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7157	longval = (long)POPLONG(ss,ix);
7158	TOPLONG(nss,ix) = longval;
7159	break;
7160	case SAVEt_I32: /* I32 reference */
7161	case SAVEt_I16: /* I16 reference */
7162	case SAVEt_I8: /* I8 reference */
7163	ptr = POPPTR(ss,ix);
7164	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7165	i = POPINT(ss,ix);
7166	TOPINT(nss,ix) = i;
7167	break;
7168	case SAVEt_IV: /* IV reference */
7169	ptr = POPPTR(ss,ix);
7170	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7171	iv = POPIV(ss,ix);
7172	TOPIV(nss,ix) = iv;
7173	break;
7174	case SAVEt_SPTR: /* SV* reference */
7175	ptr = POPPTR(ss,ix);
7176	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7177	sv = (SV*)POPPTR(ss,ix);
7178	TOPPTR(nss,ix) = sv_dup(sv);
7179	break;
7180	case SAVEt_VPTR: /* random* reference */
7181	ptr = POPPTR(ss,ix);
7182	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7183	ptr = POPPTR(ss,ix);
7184	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7185	break;
7186	case SAVEt_PPTR: /* char* reference */
7187	ptr = POPPTR(ss,ix);
7188	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7189	c = (char*)POPPTR(ss,ix);
7190	TOPPTR(nss,ix) = pv_dup(c);
7191	break;
7192	case SAVEt_HPTR: /* HV* reference */
7193	ptr = POPPTR(ss,ix);
7194	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7195	hv = (HV*)POPPTR(ss,ix);
7196	TOPPTR(nss,ix) = hv_dup(hv);
7197	break;
7198	case SAVEt_APTR: /* AV* reference */
7199	ptr = POPPTR(ss,ix);
7200	TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7201	av = (AV*)POPPTR(ss,ix);
7202	TOPPTR(nss,ix) = av_dup(av);
7203	break;
7204	case SAVEt_NSTAB:
7205	gv = (GV*)POPPTR(ss,ix);
7206	TOPPTR(nss,ix) = gv_dup(gv);
7207	break;
7208	case SAVEt_GP: /* scalar reference */
7209	gp = (GP*)POPPTR(ss,ix);
7210	TOPPTR(nss,ix) = gp = gp_dup(gp);
7211	(void)GpREFCNT_inc(gp);
7212	gv = (GV*)POPPTR(ss,ix);
7213	TOPPTR(nss,ix) = gv_dup_inc(c);
7214	c = (char*)POPPTR(ss,ix);
7215	TOPPTR(nss,ix) = pv_dup(c);
7216	iv = POPIV(ss,ix);
7217	TOPIV(nss,ix) = iv;
7218	iv = POPIV(ss,ix);
7219	TOPIV(nss,ix) = iv;
7220	break;
7221	case SAVEt_FREESV:
7222	sv = (SV*)POPPTR(ss,ix);
7223	TOPPTR(nss,ix) = sv_dup_inc(sv);
7224	break;
7225	case SAVEt_FREEOP:
7226	ptr = POPPTR(ss,ix);
7227	if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7228	/* these are assumed to be refcounted properly */
7229	switch (((OP*)ptr)->op_type) {
7230	case OP_LEAVESUB:
7231	case OP_LEAVESUBLV:
7232	case OP_LEAVEEVAL:
7233	case OP_LEAVE:
7234	case OP_SCOPE:
7235	case OP_LEAVEWRITE:
7236	TOPPTR(nss,ix) = ptr;
7237	o = (OP*)ptr;
7238	OpREFCNT_inc(o);
7239	break;
7240	default:
7241	TOPPTR(nss,ix) = Nullop;
7242	break;
7243	}
7244	}
7245	else
7246	TOPPTR(nss,ix) = Nullop;
7247	break;
7248	case SAVEt_FREEPV:
7249	c = (char*)POPPTR(ss,ix);
7250	TOPPTR(nss,ix) = pv_dup_inc(c);
7251	break;
7252	case SAVEt_CLEARSV:
7253	longval = POPLONG(ss,ix);
7254	TOPLONG(nss,ix) = longval;
7255	break;
7256	case SAVEt_DELETE:
7257	hv = (HV*)POPPTR(ss,ix);
7258	TOPPTR(nss,ix) = hv_dup_inc(hv);
7259	c = (char*)POPPTR(ss,ix);
7260	TOPPTR(nss,ix) = pv_dup_inc(c);
7261	i = POPINT(ss,ix);
7262	TOPINT(nss,ix) = i;
7263	break;
7264	case SAVEt_DESTRUCTOR:
7265	ptr = POPPTR(ss,ix);
7266	TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7267	dptr = POPDPTR(ss,ix);
7268	TOPDPTR(nss,ix) = (void ()(void))any_dup((void *)dptr, proto_perl);
7269	break;
7270	case SAVEt_DESTRUCTOR_X:
7271	ptr = POPPTR(ss,ix);
7272	TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7273	dxptr = POPDXPTR(ss,ix);
7274	TOPDXPTR(nss,ix) = (void ()(pTHXo_ void))any_dup((void *)dxptr, proto_perl);
7275	break;
7276	case SAVEt_REGCONTEXT:
7277	case SAVEt_ALLOC:
7278	i = POPINT(ss,ix);
7279	TOPINT(nss,ix) = i;
7280	ix -= i;
7281	break;
7282	case SAVEt_STACK_POS: /* Position on Perl stack */
7283	i = POPINT(ss,ix);
7284	TOPINT(nss,ix) = i;
7285	break;
7286	case SAVEt_AELEM: /* array element */
7287	sv = (SV*)POPPTR(ss,ix);
7288	TOPPTR(nss,ix) = sv_dup_inc(sv);
7289	i = POPINT(ss,ix);
7290	TOPINT(nss,ix) = i;
7291	av = (AV*)POPPTR(ss,ix);
7292	TOPPTR(nss,ix) = av_dup_inc(av);
7293	break;
7294	case SAVEt_HELEM: /* hash element */
7295	sv = (SV*)POPPTR(ss,ix);
7296	TOPPTR(nss,ix) = sv_dup_inc(sv);
7297	sv = (SV*)POPPTR(ss,ix);
7298	TOPPTR(nss,ix) = sv_dup_inc(sv);
7299	hv = (HV*)POPPTR(ss,ix);
7300	TOPPTR(nss,ix) = hv_dup_inc(hv);
7301	break;
7302	case SAVEt_OP:
7303	ptr = POPPTR(ss,ix);
7304	TOPPTR(nss,ix) = ptr;
7305	break;
7306	case SAVEt_HINTS:
7307	i = POPINT(ss,ix);
7308	TOPINT(nss,ix) = i;
7309	break;
7310	case SAVEt_COMPPAD:
7311	av = (AV*)POPPTR(ss,ix);
7312	TOPPTR(nss,ix) = av_dup(av);
7313	break;
7314	default:
7315	Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7316	}
7317	}
7318
7319	return nss;
7320	}
7321
7322	#ifdef PERL_OBJECT
7323	#include "XSUB.h"
7324	#endif
7325
7326	PerlInterpreter *
7327	perl_clone(PerlInterpreter *proto_perl, UV flags)
7328	{
7329	#ifdef PERL_OBJECT
7330	CPerlObj pPerl = (CPerlObj)proto_perl;
7331	#endif
7332
7333	#ifdef PERL_IMPLICIT_SYS
7334	return perl_clone_using(proto_perl, flags,
7335	proto_perl->IMem,
7336	proto_perl->IMemShared,
7337	proto_perl->IMemParse,
7338	proto_perl->IEnv,
7339	proto_perl->IStdIO,
7340	proto_perl->ILIO,
7341	proto_perl->IDir,
7342	proto_perl->ISock,
7343	proto_perl->IProc);
7344	}
7345
7346	PerlInterpreter *
7347	perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7348	struct IPerlMem* ipM, struct IPerlMem* ipMS,
7349	struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7350	struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7351	struct IPerlDir* ipD, struct IPerlSock* ipS,
7352	struct IPerlProc* ipP)
7353	{
7354	/* XXX many of the string copies here can be optimized if they're
7355	* constants; they need to be allocated as common memory and just
7356	* their pointers copied. */
7357
7358	IV i;
7359	# ifdef PERL_OBJECT
7360	CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7361	ipD, ipS, ipP);
7362	PERL_SET_THX(pPerl);
7363	# else /* !PERL_OBJECT */
7364	PerlInterpreter my_perl = (PerlInterpreter)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7365	PERL_SET_THX(my_perl);
7366
7367	# ifdef DEBUGGING
7368	memset(my_perl, 0xab, sizeof(PerlInterpreter));
7369	PL_markstack = 0;
7370	PL_scopestack = 0;
7371	PL_savestack = 0;
7372	PL_retstack = 0;
7373	# else /* !DEBUGGING */
7374	Zero(my_perl, 1, PerlInterpreter);
7375	# endif /* DEBUGGING */
7376
7377	/* host pointers */
7378	PL_Mem = ipM;
7379	PL_MemShared = ipMS;
7380	PL_MemParse = ipMP;
7381	PL_Env = ipE;
7382	PL_StdIO = ipStd;
7383	PL_LIO = ipLIO;
7384	PL_Dir = ipD;
7385	PL_Sock = ipS;
7386	PL_Proc = ipP;
7387	# endif /* PERL_OBJECT */
7388	#else /* !PERL_IMPLICIT_SYS */
7389	IV i;
7390	PerlInterpreter my_perl = (PerlInterpreter)PerlMem_malloc(sizeof(PerlInterpreter));
7391	PERL_SET_THX(my_perl);
7392
7393	# ifdef DEBUGGING
7394	memset(my_perl, 0xab, sizeof(PerlInterpreter));
7395	PL_markstack = 0;
7396	PL_scopestack = 0;
7397	PL_savestack = 0;
7398	PL_retstack = 0;
7399	# else /* !DEBUGGING */
7400	Zero(my_perl, 1, PerlInterpreter);
7401	# endif /* DEBUGGING */
7402	#endif /* PERL_IMPLICIT_SYS */
7403
7404	/* arena roots */
7405	PL_xiv_arenaroot = NULL;
7406	PL_xiv_root = NULL;
7407	PL_xnv_root = NULL;
7408	PL_xrv_root = NULL;
7409	PL_xpv_root = NULL;
7410	PL_xpviv_root = NULL;
7411	PL_xpvnv_root = NULL;
7412	PL_xpvcv_root = NULL;
7413	PL_xpvav_root = NULL;
7414	PL_xpvhv_root = NULL;
7415	PL_xpvmg_root = NULL;
7416	PL_xpvlv_root = NULL;
7417	PL_xpvbm_root = NULL;
7418	PL_he_root = NULL;
7419	PL_nice_chunk = NULL;
7420	PL_nice_chunk_size = 0;
7421	PL_sv_count = 0;
7422	PL_sv_objcount = 0;
7423	PL_sv_root = Nullsv;
7424	PL_sv_arenaroot = Nullsv;
7425
7426	PL_debug = proto_perl->Idebug;
7427
7428	/* create SV map for pointer relocation */
7429	PL_ptr_table = ptr_table_new();
7430
7431	/* initialize these special pointers as early as possible */
7432	SvANY(&PL_sv_undef) = NULL;
7433	SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7434	SvFLAGS(&PL_sv_undef) = SVf_READONLY\|SVt_NULL;
7435	ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7436
7437	#ifdef PERL_OBJECT
7438	SvUPGRADE(&PL_sv_no, SVt_PVNV);
7439	#else
7440	SvANY(&PL_sv_no) = new_XPVNV();
7441	#endif
7442	SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7443	SvFLAGS(&PL_sv_no) = SVp_NOK\|SVf_NOK\|SVp_POK\|SVf_POK\|SVf_READONLY\|SVt_PVNV;
7444	SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7445	SvCUR(&PL_sv_no) = 0;
7446	SvLEN(&PL_sv_no) = 1;
7447	SvNVX(&PL_sv_no) = 0;
7448	ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7449
7450	#ifdef PERL_OBJECT
7451	SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7452	#else
7453	SvANY(&PL_sv_yes) = new_XPVNV();
7454	#endif
7455	SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7456	SvFLAGS(&PL_sv_yes) = SVp_NOK\|SVf_NOK\|SVp_POK\|SVf_POK\|SVf_READONLY\|SVt_PVNV;
7457	SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7458	SvCUR(&PL_sv_yes) = 1;
7459	SvLEN(&PL_sv_yes) = 2;
7460	SvNVX(&PL_sv_yes) = 1;
7461	ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7462
7463	/* create shared string table */
7464	PL_strtab = newHV();
7465	HvSHAREKEYS_off(PL_strtab);
7466	hv_ksplit(PL_strtab, 512);
7467	ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7468
7469	PL_compiling = proto_perl->Icompiling;
7470	PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7471	PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7472	ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7473	if (!specialWARN(PL_compiling.cop_warnings))
7474	PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7475	PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7476
7477	/* pseudo environmental stuff */
7478	PL_origargc = proto_perl->Iorigargc;
7479	i = PL_origargc;
7480	New(0, PL_origargv, i+1, char*);
7481	PL_origargv[i] = '\0';
7482	while (i-- > 0) {
7483	PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7484	}
7485	PL_envgv = gv_dup(proto_perl->Ienvgv);
7486	PL_incgv = gv_dup(proto_perl->Iincgv);
7487	PL_hintgv = gv_dup(proto_perl->Ihintgv);
7488	PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7489	PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7490	PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7491
7492	/* switches */
7493	PL_minus_c = proto_perl->Iminus_c;
7494	PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7495	PL_localpatches = proto_perl->Ilocalpatches;
7496	PL_splitstr = proto_perl->Isplitstr;
7497	PL_preprocess = proto_perl->Ipreprocess;
7498	PL_minus_n = proto_perl->Iminus_n;
7499	PL_minus_p = proto_perl->Iminus_p;
7500	PL_minus_l = proto_perl->Iminus_l;
7501	PL_minus_a = proto_perl->Iminus_a;
7502	PL_minus_F = proto_perl->Iminus_F;
7503	PL_doswitches = proto_perl->Idoswitches;
7504	PL_dowarn = proto_perl->Idowarn;
7505	PL_doextract = proto_perl->Idoextract;
7506	PL_sawampersand = proto_perl->Isawampersand;
7507	PL_unsafe = proto_perl->Iunsafe;
7508	PL_inplace = SAVEPV(proto_perl->Iinplace);
7509	PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7510	PL_perldb = proto_perl->Iperldb;
7511	PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7512
7513	/* magical thingies */
7514	/* XXX time(&PL_basetime) when asked for? */
7515	PL_basetime = proto_perl->Ibasetime;
7516	PL_formfeed = sv_dup(proto_perl->Iformfeed);
7517
7518	PL_maxsysfd = proto_perl->Imaxsysfd;
7519	PL_multiline = proto_perl->Imultiline;
7520	PL_statusvalue = proto_perl->Istatusvalue;
7521	#ifdef VMS
7522	PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7523	#endif
7524
7525	/* shortcuts to various I/O objects */
7526	PL_stdingv = gv_dup(proto_perl->Istdingv);
7527	PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7528	PL_defgv = gv_dup(proto_perl->Idefgv);
7529	PL_argvgv = gv_dup(proto_perl->Iargvgv);
7530	PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7531	PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7532
7533	/* shortcuts to regexp stuff */
7534	PL_replgv = gv_dup(proto_perl->Ireplgv);
7535
7536	/* shortcuts to misc objects */
7537	PL_errgv = gv_dup(proto_perl->Ierrgv);
7538
7539	/* shortcuts to debugging objects */
7540	PL_DBgv = gv_dup(proto_perl->IDBgv);
7541	PL_DBline = gv_dup(proto_perl->IDBline);
7542	PL_DBsub = gv_dup(proto_perl->IDBsub);
7543	PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7544	PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7545	PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7546	PL_lineary = av_dup(proto_perl->Ilineary);
7547	PL_dbargs = av_dup(proto_perl->Idbargs);
7548
7549	/* symbol tables */
7550	PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7551	PL_curstash = hv_dup(proto_perl->Tcurstash);
7552	PL_debstash = hv_dup(proto_perl->Idebstash);
7553	PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7554	PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7555
7556	PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7557	PL_endav = av_dup_inc(proto_perl->Iendav);
7558	PL_checkav = av_dup_inc(proto_perl->Icheckav);
7559	PL_initav = av_dup_inc(proto_perl->Iinitav);
7560
7561	PL_sub_generation = proto_perl->Isub_generation;
7562
7563	/* funky return mechanisms */
7564	PL_forkprocess = proto_perl->Iforkprocess;
7565
7566	/* subprocess state */
7567	PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7568
7569	/* internal state */
7570	PL_tainting = proto_perl->Itainting;
7571	PL_maxo = proto_perl->Imaxo;
7572	if (proto_perl->Iop_mask)
7573	PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7574	else
7575	PL_op_mask = Nullch;
7576
7577	/* current interpreter roots */
7578	PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7579	PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7580	PL_main_start = proto_perl->Imain_start;
7581	PL_eval_root = proto_perl->Ieval_root;
7582	PL_eval_start = proto_perl->Ieval_start;
7583
7584	/* runtime control stuff */
7585	PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7586	PL_copline = proto_perl->Icopline;
7587
7588	PL_filemode = proto_perl->Ifilemode;
7589	PL_lastfd = proto_perl->Ilastfd;
7590	PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7591	PL_Argv = NULL;
7592	PL_Cmd = Nullch;
7593	PL_gensym = proto_perl->Igensym;
7594	PL_preambled = proto_perl->Ipreambled;
7595	PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7596	PL_laststatval = proto_perl->Ilaststatval;
7597	PL_laststype = proto_perl->Ilaststype;
7598	PL_mess_sv = Nullsv;
7599
7600	PL_orslen = proto_perl->Iorslen;
7601	PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7602	PL_ofmt = SAVEPV(proto_perl->Iofmt);
7603
7604	/* interpreter atexit processing */
7605	PL_exitlistlen = proto_perl->Iexitlistlen;
7606	if (PL_exitlistlen) {
7607	New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7608	Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7609	}
7610	else
7611	PL_exitlist = (PerlExitListEntry*)NULL;
7612	PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7613
7614	PL_profiledata = NULL;
7615	PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7616	/* PL_rsfp_filters entries have fake IoDIRP() */
7617	PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7618
7619	PL_compcv = cv_dup(proto_perl->Icompcv);
7620	PL_comppad = av_dup(proto_perl->Icomppad);
7621	PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7622	PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7623	PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7624	PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7625	proto_perl->Tcurpad);
7626
7627	#ifdef HAVE_INTERP_INTERN
7628	sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7629	#endif
7630
7631	/* more statics moved here */
7632	PL_generation = proto_perl->Igeneration;
7633	PL_DBcv = cv_dup(proto_perl->IDBcv);
7634
7635	PL_in_clean_objs = proto_perl->Iin_clean_objs;
7636	PL_in_clean_all = proto_perl->Iin_clean_all;
7637
7638	PL_uid = proto_perl->Iuid;
7639	PL_euid = proto_perl->Ieuid;
7640	PL_gid = proto_perl->Igid;
7641	PL_egid = proto_perl->Iegid;
7642	PL_nomemok = proto_perl->Inomemok;
7643	PL_an = proto_perl->Ian;
7644	PL_cop_seqmax = proto_perl->Icop_seqmax;
7645	PL_op_seqmax = proto_perl->Iop_seqmax;
7646	PL_evalseq = proto_perl->Ievalseq;
7647	PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7648	PL_origalen = proto_perl->Iorigalen;
7649	PL_pidstatus = newHV(); /* XXX flag for cloning? */
7650	PL_osname = SAVEPV(proto_perl->Iosname);
7651	PL_sh_path = SAVEPV(proto_perl->Ish_path);
7652	PL_sighandlerp = proto_perl->Isighandlerp;
7653
7654
7655	PL_runops = proto_perl->Irunops;
7656
7657	Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7658
7659	#ifdef CSH
7660	PL_cshlen = proto_perl->Icshlen;
7661	PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7662	#endif
7663
7664	PL_lex_state = proto_perl->Ilex_state;
7665	PL_lex_defer = proto_perl->Ilex_defer;
7666	PL_lex_expect = proto_perl->Ilex_expect;
7667	PL_lex_formbrack = proto_perl->Ilex_formbrack;
7668	PL_lex_dojoin = proto_perl->Ilex_dojoin;
7669	PL_lex_starts = proto_perl->Ilex_starts;
7670	PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7671	PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7672	PL_lex_op = proto_perl->Ilex_op;
7673	PL_lex_inpat = proto_perl->Ilex_inpat;
7674	PL_lex_inwhat = proto_perl->Ilex_inwhat;
7675	PL_lex_brackets = proto_perl->Ilex_brackets;
7676	i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7677	PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7678	PL_lex_casemods = proto_perl->Ilex_casemods;
7679	i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7680	PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7681
7682	Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7683	Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7684	PL_nexttoke = proto_perl->Inexttoke;
7685
7686	PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7687	i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7688	PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7689	i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7690	PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7691	i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7692	PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7693	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7694	i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7695	PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7696	PL_pending_ident = proto_perl->Ipending_ident;
7697	PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7698
7699	PL_expect = proto_perl->Iexpect;
7700
7701	PL_multi_start = proto_perl->Imulti_start;
7702	PL_multi_end = proto_perl->Imulti_end;
7703	PL_multi_open = proto_perl->Imulti_open;
7704	PL_multi_close = proto_perl->Imulti_close;
7705
7706	PL_error_count = proto_perl->Ierror_count;
7707	PL_subline = proto_perl->Isubline;
7708	PL_subname = sv_dup_inc(proto_perl->Isubname);
7709
7710	PL_min_intro_pending = proto_perl->Imin_intro_pending;
7711	PL_max_intro_pending = proto_perl->Imax_intro_pending;
7712	PL_padix = proto_perl->Ipadix;
7713	PL_padix_floor = proto_perl->Ipadix_floor;
7714	PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7715
7716	i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7717	PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7718	i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7719	PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7720	PL_last_lop_op = proto_perl->Ilast_lop_op;
7721	PL_in_my = proto_perl->Iin_my;
7722	PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7723	#ifdef FCRYPT
7724	PL_cryptseen = proto_perl->Icryptseen;
7725	#endif
7726
7727	PL_hints = proto_perl->Ihints;
7728
7729	PL_amagic_generation = proto_perl->Iamagic_generation;
7730
7731	#ifdef USE_LOCALE_COLLATE
7732	PL_collation_ix = proto_perl->Icollation_ix;
7733	PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7734	PL_collation_standard = proto_perl->Icollation_standard;
7735	PL_collxfrm_base = proto_perl->Icollxfrm_base;
7736	PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7737	#endif /* USE_LOCALE_COLLATE */
7738
7739	#ifdef USE_LOCALE_NUMERIC
7740	PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7741	PL_numeric_standard = proto_perl->Inumeric_standard;
7742	PL_numeric_local = proto_perl->Inumeric_local;
7743	PL_numeric_radix = proto_perl->Inumeric_radix;
7744	#endif /* !USE_LOCALE_NUMERIC */
7745
7746	/* utf8 character classes */
7747	PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7748	PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7749	PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7750	PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7751	PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7752	PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7753	PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7754	PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7755	PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7756	PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7757	PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7758	PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7759	PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7760	PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7761	PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7762	PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7763	PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7764
7765	/* swatch cache */
7766	PL_last_swash_hv = Nullhv; /* reinits on demand */
7767	PL_last_swash_klen = 0;
7768	PL_last_swash_key[0]= '\0';
7769	PL_last_swash_tmps = (U8*)NULL;
7770	PL_last_swash_slen = 0;
7771
7772	/* perly.c globals */
7773	PL_yydebug = proto_perl->Iyydebug;
7774	PL_yynerrs = proto_perl->Iyynerrs;
7775	PL_yyerrflag = proto_perl->Iyyerrflag;
7776	PL_yychar = proto_perl->Iyychar;
7777	PL_yyval = proto_perl->Iyyval;
7778	PL_yylval = proto_perl->Iyylval;
7779
7780	PL_glob_index = proto_perl->Iglob_index;
7781	PL_srand_called = proto_perl->Isrand_called;
7782	PL_uudmap['M'] = 0; /* reinits on demand */
7783	PL_bitcount = Nullch; /* reinits on demand */
7784
7785	if (proto_perl->Ipsig_ptr) {
7786	int sig_num[] = { SIG_NUM };
7787	Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(sig_num), SV);
7788	Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(sig_num), SV);
7789	for (i = 1; PL_sig_name[i]; i++) {
7790	PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7791	PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7792	}
7793	}
7794	else {
7795	PL_psig_ptr = (SV**)NULL;
7796	PL_psig_name = (SV**)NULL;
7797	}
7798
7799	/* thrdvar.h stuff */
7800
7801	if (flags & 1) {
7802	/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7803	PL_tmps_ix = proto_perl->Ttmps_ix;
7804	PL_tmps_max = proto_perl->Ttmps_max;
7805	PL_tmps_floor = proto_perl->Ttmps_floor;
7806	Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7807	i = 0;
7808	while (i <= PL_tmps_ix) {
7809	PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7810	++i;
7811	}
7812
7813	/* next PUSHMARK() sets (PL_markstack_ptr+1) /
7814	i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7815	Newz(54, PL_markstack, i, I32);
7816	PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7817	- proto_perl->Tmarkstack);
7818	PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7819	- proto_perl->Tmarkstack);
7820	Copy(proto_perl->Tmarkstack, PL_markstack,
7821	PL_markstack_ptr - PL_markstack + 1, I32);
7822
7823	/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7824	* NOTE: unlike the others! */
7825	PL_scopestack_ix = proto_perl->Tscopestack_ix;
7826	PL_scopestack_max = proto_perl->Tscopestack_max;
7827	Newz(54, PL_scopestack, PL_scopestack_max, I32);
7828	Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7829
7830	/* next push_return() sets PL_retstack[PL_retstack_ix]
7831	* NOTE: unlike the others! */
7832	PL_retstack_ix = proto_perl->Tretstack_ix;
7833	PL_retstack_max = proto_perl->Tretstack_max;
7834	Newz(54, PL_retstack, PL_retstack_max, OP*);
7835	Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7836
7837	/* NOTE: si_dup() looks at PL_markstack */
7838	PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7839
7840	/* PL_curstack = PL_curstackinfo->si_stack; */
7841	PL_curstack = av_dup(proto_perl->Tcurstack);
7842	PL_mainstack = av_dup(proto_perl->Tmainstack);
7843
7844	/* next PUSHs() etc. set (PL_stack_sp+1) /
7845	PL_stack_base = AvARRAY(PL_curstack);
7846	PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7847	- proto_perl->Tstack_base);
7848	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7849
7850	/* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7851	* NOTE: unlike the others! */
7852	PL_savestack_ix = proto_perl->Tsavestack_ix;
7853	PL_savestack_max = proto_perl->Tsavestack_max;
7854	/Newz(54, PL_savestack, PL_savestack_max, ANY);/
7855	PL_savestack = ss_dup(proto_perl);
7856	}
7857	else {
7858	init_stacks();
7859	}
7860
7861	PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7862	PL_top_env = &PL_start_env;
7863
7864	PL_op = proto_perl->Top;
7865
7866	PL_Sv = Nullsv;
7867	PL_Xpv = (XPV*)NULL;
7868	PL_na = proto_perl->Tna;
7869
7870	PL_statbuf = proto_perl->Tstatbuf;
7871	PL_statcache = proto_perl->Tstatcache;
7872	PL_statgv = gv_dup(proto_perl->Tstatgv);
7873	PL_statname = sv_dup_inc(proto_perl->Tstatname);
7874	#ifdef HAS_TIMES
7875	PL_timesbuf = proto_perl->Ttimesbuf;
7876	#endif
7877
7878	PL_tainted = proto_perl->Ttainted;
7879	PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7880	PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7881	PL_rs = sv_dup_inc(proto_perl->Trs);
7882	PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7883	PL_ofslen = proto_perl->Tofslen;
7884	PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7885	PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7886	PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7887	PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7888	PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7889	PL_formtarget = sv_dup(proto_perl->Tformtarget);
7890
7891	PL_restartop = proto_perl->Trestartop;
7892	PL_in_eval = proto_perl->Tin_eval;
7893	PL_delaymagic = proto_perl->Tdelaymagic;
7894	PL_dirty = proto_perl->Tdirty;
7895	PL_localizing = proto_perl->Tlocalizing;
7896
7897	#ifdef PERL_FLEXIBLE_EXCEPTIONS
7898	PL_protect = proto_perl->Tprotect;
7899	#endif
7900	PL_errors = sv_dup_inc(proto_perl->Terrors);
7901	PL_av_fetch_sv = Nullsv;
7902	PL_hv_fetch_sv = Nullsv;
7903	Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7904	PL_modcount = proto_perl->Tmodcount;
7905	PL_lastgotoprobe = Nullop;
7906	PL_dumpindent = proto_perl->Tdumpindent;
7907
7908	PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7909	PL_sortstash = hv_dup(proto_perl->Tsortstash);
7910	PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7911	PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7912	PL_sortcxix = proto_perl->Tsortcxix;
7913	PL_efloatbuf = Nullch; /* reinits on demand */
7914	PL_efloatsize = 0; /* reinits on demand */
7915
7916	/* regex stuff */
7917
7918	PL_screamfirst = NULL;
7919	PL_screamnext = NULL;
7920	PL_maxscream = -1; /* reinits on demand */
7921	PL_lastscream = Nullsv;
7922
7923	PL_watchaddr = NULL;
7924	PL_watchok = Nullch;
7925
7926	PL_regdummy = proto_perl->Tregdummy;
7927	PL_regcomp_parse = Nullch;
7928	PL_regxend = Nullch;
7929	PL_regcode = (regnode*)NULL;
7930	PL_regnaughty = 0;
7931	PL_regsawback = 0;
7932	PL_regprecomp = Nullch;
7933	PL_regnpar = 0;
7934	PL_regsize = 0;
7935	PL_regflags = 0;
7936	PL_regseen = 0;
7937	PL_seen_zerolen = 0;
7938	PL_seen_evals = 0;
7939	PL_regcomp_rx = (regexp*)NULL;
7940	PL_extralen = 0;
7941	PL_colorset = 0; /* reinits PL_colors[] */
7942	/PL_colors[6] = {0,0,0,0,0,0};/
7943	PL_reg_whilem_seen = 0;
7944	PL_reginput = Nullch;
7945	PL_regbol = Nullch;
7946	PL_regeol = Nullch;
7947	PL_regstartp = (I32*)NULL;
7948	PL_regendp = (I32*)NULL;
7949	PL_reglastparen = (U32*)NULL;
7950	PL_regtill = Nullch;
7951	PL_regprev = '\n';
7952	PL_reg_start_tmp = (char**)NULL;
7953	PL_reg_start_tmpl = 0;
7954	PL_regdata = (struct reg_data*)NULL;
7955	PL_bostr = Nullch;
7956	PL_reg_flags = 0;
7957	PL_reg_eval_set = 0;
7958	PL_regnarrate = 0;
7959	PL_regprogram = (regnode*)NULL;
7960	PL_regindent = 0;
7961	PL_regcc = (CURCUR*)NULL;
7962	PL_reg_call_cc = (struct re_cc_state*)NULL;
7963	PL_reg_re = (regexp*)NULL;
7964	PL_reg_ganch = Nullch;
7965	PL_reg_sv = Nullsv;
7966	PL_reg_magic = (MAGIC*)NULL;
7967	PL_reg_oldpos = 0;
7968	PL_reg_oldcurpm = (PMOP*)NULL;
7969	PL_reg_curpm = (PMOP*)NULL;
7970	PL_reg_oldsaved = Nullch;
7971	PL_reg_oldsavedlen = 0;
7972	PL_reg_maxiter = 0;
7973	PL_reg_leftiter = 0;
7974	PL_reg_poscache = Nullch;
7975	PL_reg_poscache_size= 0;
7976
7977	/* RE engine - function pointers */
7978	PL_regcompp = proto_perl->Tregcompp;
7979	PL_regexecp = proto_perl->Tregexecp;
7980	PL_regint_start = proto_perl->Tregint_start;
7981	PL_regint_string = proto_perl->Tregint_string;
7982	PL_regfree = proto_perl->Tregfree;
7983
7984	PL_reginterp_cnt = 0;
7985	PL_reg_starttry = 0;
7986
7987	#ifdef PERL_OBJECT
7988	return (PerlInterpreter*)pPerl;
7989	#else
7990	return my_perl;
7991	#endif
7992	}
7993
7994	#else /* !USE_ITHREADS */
7995
7996	#ifdef PERL_OBJECT
7997	#include "XSUB.h"
7998	#endif
7999
8000	#endif /* USE_ITHREADS */
8001
8002	static void
8003	do_report_used(pTHXo_ SV *sv)
8004	{
8005	if (SvTYPE(sv) != SVTYPEMASK) {
8006	PerlIO_printf(Perl_debug_log, "****\n");
8007	sv_dump(sv);
8008	}
8009	}
8010
8011	static void
8012	do_clean_objs(pTHXo_ SV *sv)
8013	{
8014	SV* rv;
8015
8016	if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8017	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8018	SvROK_off(sv);
8019	SvRV(sv) = 0;
8020	SvREFCNT_dec(rv);
8021	}
8022
8023	/* XXX Might want to check arrays, etc. */
8024	}
8025
8026	#ifndef DISABLE_DESTRUCTOR_KLUDGE
8027	static void
8028	do_clean_named_objs(pTHXo_ SV *sv)
8029	{
8030	if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8031	if ( SvOBJECT(GvSV(sv)) \|\|
8032	(GvAV(sv) && SvOBJECT(GvAV(sv))) \|\|
8033	(GvHV(sv) && SvOBJECT(GvHV(sv))) \|\|
8034	(GvIO(sv) && SvOBJECT(GvIO(sv))) \|\|
8035	(GvCV(sv) && SvOBJECT(GvCV(sv))) )
8036	{
8037	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8038	SvREFCNT_dec(sv);
8039	}
8040	}
8041	}
8042	#endif
8043
8044	static void
8045	do_clean_all(pTHXo_ SV *sv)
8046	{
8047	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8048	SvFLAGS(sv) \|= SVf_BREAK;
8049	SvREFCNT_dec(sv);
8050	}
8051

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

Download in other formats: