Context Navigation

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

Visit:

Revision 17035, 186.7 KB checked in by zacheiss, 23 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r17034, which included commits to RCS files with non-trunk default branches.

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

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

Download in other formats: