Context Navigation

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

Visit:

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

Line
1	/* sv.c
2	*
3	* Copyright (c) 1991-1997, 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	#include "perl.h"
16
17	#ifdef OVR_DBL_DIG
18	/* Use an overridden DBL_DIG */
19	# ifdef DBL_DIG
20	# undef DBL_DIG
21	# endif
22	# define DBL_DIG OVR_DBL_DIG
23	#else
24	/* The following is all to get DBL_DIG, in order to pick a nice
25	default value for printing floating point numbers in Gconvert.
26	(see config.h)
27	*/
28	#ifdef I_LIMITS
29	#include <limits.h>
30	#endif
31	#ifdef I_FLOAT
32	#include <float.h>
33	#endif
34	#ifndef HAS_DBL_DIG
35	#define DBL_DIG 15 /* A guess that works lots of places */
36	#endif
37	#endif
38
39	#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
40	# define FAST_SV_GETS
41	#endif
42
43	static IV asIV _((SV* sv));
44	static UV asUV _((SV* sv));
45	static SV *more_sv _((void));
46	static XPVIV *more_xiv _((void));
47	static XPVNV *more_xnv _((void));
48	static XPV *more_xpv _((void));
49	static XRV *more_xrv _((void));
50	static XPVIV *new_xiv _((void));
51	static XPVNV *new_xnv _((void));
52	static XPV *new_xpv _((void));
53	static XRV *new_xrv _((void));
54	static void del_xiv _((XPVIV* p));
55	static void del_xnv _((XPVNV* p));
56	static void del_xpv _((XPV* p));
57	static void del_xrv _((XRV* p));
58	static void sv_mortalgrow _((void));
59	static void sv_unglob _((SV* sv));
60
61	typedef void (SVFUNC) _((SV));
62
63	#ifdef PURIFY
64
65	#define new_SV(p) \
66	do { \
67	(p) = (SV*)safemalloc(sizeof(SV)); \
68	reg_add(p); \
69	} while (0)
70
71	#define del_SV(p) \
72	do { \
73	reg_remove(p); \
74	free((char*)(p)); \
75	} while (0)
76
77	static SV **registry;
78	static I32 regsize;
79
80	#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
81
82	#define REG_REPLACE(sv,a,b) \
83	do { \
84	void* p = sv->sv_any; \
85	I32 h = REGHASH(sv, regsize); \
86	I32 i = h; \
87	while (registry[i] != (a)) { \
88	if (++i >= regsize) \
89	i = 0; \
90	if (i == h) \
91	die("SV registry bug"); \
92	} \
93	registry[i] = (b); \
94	} while (0)
95
96	#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
97	#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
98
99	static void
100	reg_add(sv)
101	SV* sv;
102	{
103	if (sv_count >= (regsize >> 1))
104	{
105	SV **oldreg = registry;
106	I32 oldsize = regsize;
107
108	regsize = regsize ? ((regsize << 2) + 1) : 2037;
109	registry = (SV*)safemalloc(regsize sizeof(SV*));
110	memzero(registry, regsize * sizeof(SV*));
111
112	if (oldreg) {
113	I32 i;
114
115	for (i = 0; i < oldsize; ++i) {
116	SV* oldsv = oldreg[i];
117	if (oldsv)
118	REG_ADD(oldsv);
119	}
120	Safefree(oldreg);
121	}
122	}
123
124	REG_ADD(sv);
125	++sv_count;
126	}
127
128	static void
129	reg_remove(sv)
130	SV* sv;
131	{
132	REG_REMOVE(sv);
133	--sv_count;
134	}
135
136	static void
137	visit(f)
138	SVFUNC f;
139	{
140	I32 i;
141
142	for (i = 0; i < regsize; ++i) {
143	SV* sv = registry[i];
144	if (sv)
145	(*f)(sv);
146	}
147	}
148
149	void
150	sv_add_arena(ptr, size, flags)
151	char* ptr;
152	U32 size;
153	U32 flags;
154	{
155	if (!(flags & SVf_FAKE))
156	free(ptr);
157	}
158
159	#else /* ! PURIFY */
160
161	/*
162	* "A time to plant, and a time to uproot what was planted..."
163	*/
164
165	#define plant_SV(p) \
166	do { \
167	SvANY(p) = (void *)sv_root; \
168	SvFLAGS(p) = SVTYPEMASK; \
169	sv_root = (p); \
170	--sv_count; \
171	} while (0)
172
173	#define uproot_SV(p) \
174	do { \
175	(p) = sv_root; \
176	sv_root = (SV*)SvANY(p); \
177	++sv_count; \
178	} while (0)
179
180	#define new_SV(p) \
181	if (sv_root) \
182	uproot_SV(p); \
183	else \
184	(p) = more_sv()
185
186	#ifdef DEBUGGING
187
188	#define del_SV(p) \
189	if (debug & 32768) \
190	del_sv(p); \
191	else \
192	plant_SV(p)
193
194	static void
195	del_sv(p)
196	SV* p;
197	{
198	if (debug & 32768) {
199	SV* sva;
200	SV* sv;
201	SV* svend;
202	int ok = 0;
203	for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
204	sv = sva + 1;
205	svend = &sva[SvREFCNT(sva)];
206	if (p >= sv && p < svend)
207	ok = 1;
208	}
209	if (!ok) {
210	warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
211	return;
212	}
213	}
214	plant_SV(p);
215	}
216
217	#else /* ! DEBUGGING */
218
219	#define del_SV(p) plant_SV(p)
220
221	#endif /* DEBUGGING */
222
223	void
224	sv_add_arena(ptr, size, flags)
225	char* ptr;
226	U32 size;
227	U32 flags;
228	{
229	SV* sva = (SV*)ptr;
230	register SV* sv;
231	register SV* svend;
232	Zero(sva, size, char);
233
234	/* The first SV in an arena isn't an SV. */
235	SvANY(sva) = (void ) sv_arenaroot; / ptr to next arena */
236	SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
237	SvFLAGS(sva) = flags; /* FAKE if not to be freed */
238
239	sv_arenaroot = sva;
240	sv_root = sva + 1;
241
242	svend = &sva[SvREFCNT(sva) - 1];
243	sv = sva + 1;
244	while (sv < svend) {
245	SvANY(sv) = (void )(SV)(sv + 1);
246	SvFLAGS(sv) = SVTYPEMASK;
247	sv++;
248	}
249	SvANY(sv) = 0;
250	SvFLAGS(sv) = SVTYPEMASK;
251	}
252
253	static SV*
254	more_sv()
255	{
256	register SV* sv;
257
258	if (nice_chunk) {
259	sv_add_arena(nice_chunk, nice_chunk_size, 0);
260	nice_chunk = Nullch;
261	}
262	else {
263	char chunk; / must use New here to match call to */
264	New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
265	sv_add_arena(chunk, 1008, 0);
266	}
267	uproot_SV(sv);
268	return sv;
269	}
270
271	static void
272	visit(f)
273	SVFUNC f;
274	{
275	SV* sva;
276	SV* sv;
277	register SV* svend;
278
279	for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
280	svend = &sva[SvREFCNT(sva)];
281	for (sv = sva + 1; sv < svend; ++sv) {
282	if (SvTYPE(sv) != SVTYPEMASK)
283	(*f)(sv);
284	}
285	}
286	}
287
288	#endif /* PURIFY */
289
290	static void
291	do_report_used(sv)
292	SV* sv;
293	{
294	if (SvTYPE(sv) != SVTYPEMASK) {
295	/* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
296	PerlIO_printf(PerlIO_stderr(), "****\n");
297	sv_dump(sv);
298	}
299	}
300
301	void
302	sv_report_used()
303	{
304	visit(do_report_used);
305	}
306
307	static void
308	do_clean_objs(sv)
309	SV* sv;
310	{
311	SV* rv;
312
313	if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
314	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
315	SvROK_off(sv);
316	SvRV(sv) = 0;
317	SvREFCNT_dec(rv);
318	}
319
320	/* XXX Might want to check arrays, etc. */
321	}
322
323	#ifndef DISABLE_DESTRUCTOR_KLUDGE
324	static void
325	do_clean_named_objs(sv)
326	SV* sv;
327	{
328	if (SvTYPE(sv) == SVt_PVGV && GvSV(sv))
329	do_clean_objs(GvSV(sv));
330	}
331	#endif
332
333	static bool in_clean_objs = FALSE;
334
335	void
336	sv_clean_objs()
337	{
338	in_clean_objs = TRUE;
339	#ifndef DISABLE_DESTRUCTOR_KLUDGE
340	visit(do_clean_named_objs);
341	#endif
342	visit(do_clean_objs);
343	in_clean_objs = FALSE;
344	}
345
346	static void
347	do_clean_all(sv)
348	SV* sv;
349	{
350	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));)
351	SvFLAGS(sv) \|= SVf_BREAK;
352	SvREFCNT_dec(sv);
353	}
354
355	static bool in_clean_all = FALSE;
356
357	void
358	sv_clean_all()
359	{
360	in_clean_all = TRUE;
361	visit(do_clean_all);
362	in_clean_all = FALSE;
363	}
364
365	void
366	sv_free_arenas()
367	{
368	SV* sva;
369	SV* svanext;
370
371	/* Free arenas here, but be careful about fake ones. (We assume
372	contiguity of the fake ones with the corresponding real ones.) */
373
374	for (sva = sv_arenaroot; sva; sva = svanext) {
375	svanext = (SV*) SvANY(sva);
376	while (svanext && SvFAKE(svanext))
377	svanext = (SV*) SvANY(svanext);
378
379	if (!SvFAKE(sva))
380	Safefree((void *)sva);
381	}
382
383	sv_arenaroot = 0;
384	sv_root = 0;
385	}
386
387	static XPVIV*
388	new_xiv()
389	{
390	IV** xiv;
391	if (xiv_root) {
392	xiv = xiv_root;
393	/*
394	* See comment in more_xiv() -- RAM.
395	*/
396	xiv_root = (IV*)xiv;
397	return (XPVIV)((char)xiv - sizeof(XPV));
398	}
399	return more_xiv();
400	}
401
402	static void
403	del_xiv(p)
404	XPVIV* p;
405	{
406	IV xiv = (IV)((char*)(p) + sizeof(XPV));
407	xiv = (IV )xiv_root;
408	xiv_root = xiv;
409	}
410
411	static XPVIV*
412	more_xiv()
413	{
414	register IV** xiv;
415	register IV** xivend;
416	XPV* ptr = (XPV*)safemalloc(1008);
417	ptr->xpv_pv = (char)xiv_arenaroot; / linked list of xiv arenas */
418	xiv_arenaroot = ptr; /* to keep Purify happy */
419
420	xiv = (IV**) ptr;
421	xivend = &xiv[1008 / sizeof(IV *) - 1];
422	xiv += (sizeof(XPV) - 1) / sizeof(IV ) + 1; / fudge by size of XPV */
423	xiv_root = xiv;
424	while (xiv < xivend) {
425	xiv = (IV )(xiv + 1);
426	xiv++;
427	}
428	*xiv = 0;
429	return new_xiv();
430	}
431
432	static XPVNV*
433	new_xnv()
434	{
435	double* xnv;
436	if (xnv_root) {
437	xnv = xnv_root;
438	xnv_root = (double*)xnv;
439	return (XPVNV)((char)xnv - sizeof(XPVIV));
440	}
441	return more_xnv();
442	}
443
444	static void
445	del_xnv(p)
446	XPVNV* p;
447	{
448	double* xnv = (double)((char)(p) + sizeof(XPVIV));
449	(double*)xnv = xnv_root;
450	xnv_root = xnv;
451	}
452
453	static XPVNV*
454	more_xnv()
455	{
456	register double* xnv;
457	register double* xnvend;
458	xnv = (double*)safemalloc(1008);
459	xnvend = &xnv[1008 / sizeof(double) - 1];
460	xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
461	xnv_root = xnv;
462	while (xnv < xnvend) {
463	(double)xnv = (double)(xnv + 1);
464	xnv++;
465	}
466	(double*)xnv = 0;
467	return new_xnv();
468	}
469
470	static XRV*
471	new_xrv()
472	{
473	XRV* xrv;
474	if (xrv_root) {
475	xrv = xrv_root;
476	xrv_root = (XRV*)xrv->xrv_rv;
477	return xrv;
478	}
479	return more_xrv();
480	}
481
482	static void
483	del_xrv(p)
484	XRV* p;
485	{
486	p->xrv_rv = (SV*)xrv_root;
487	xrv_root = p;
488	}
489
490	static XRV*
491	more_xrv()
492	{
493	register XRV* xrv;
494	register XRV* xrvend;
495	xrv_root = (XRV*)safemalloc(1008);
496	xrv = xrv_root;
497	xrvend = &xrv[1008 / sizeof(XRV) - 1];
498	while (xrv < xrvend) {
499	xrv->xrv_rv = (SV*)(xrv + 1);
500	xrv++;
501	}
502	xrv->xrv_rv = 0;
503	return new_xrv();
504	}
505
506	static XPV*
507	new_xpv()
508	{
509	XPV* xpv;
510	if (xpv_root) {
511	xpv = xpv_root;
512	xpv_root = (XPV*)xpv->xpv_pv;
513	return xpv;
514	}
515	return more_xpv();
516	}
517
518	static void
519	del_xpv(p)
520	XPV* p;
521	{
522	p->xpv_pv = (char*)xpv_root;
523	xpv_root = p;
524	}
525
526	static XPV*
527	more_xpv()
528	{
529	register XPV* xpv;
530	register XPV* xpvend;
531	xpv_root = (XPV*)safemalloc(1008);
532	xpv = xpv_root;
533	xpvend = &xpv[1008 / sizeof(XPV) - 1];
534	while (xpv < xpvend) {
535	xpv->xpv_pv = (char*)(xpv + 1);
536	xpv++;
537	}
538	xpv->xpv_pv = 0;
539	return new_xpv();
540	}
541
542	#ifdef PURIFY
543	#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
544	#define del_XIV(p) free((char*)p)
545	#else
546	#define new_XIV() (void*)new_xiv()
547	#define del_XIV(p) del_xiv(p)
548	#endif
549
550	#ifdef PURIFY
551	#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
552	#define del_XNV(p) free((char*)p)
553	#else
554	#define new_XNV() (void*)new_xnv()
555	#define del_XNV(p) del_xnv(p)
556	#endif
557
558	#ifdef PURIFY
559	#define new_XRV() (void*)safemalloc(sizeof(XRV))
560	#define del_XRV(p) free((char*)p)
561	#else
562	#define new_XRV() (void*)new_xrv()
563	#define del_XRV(p) del_xrv(p)
564	#endif
565
566	#ifdef PURIFY
567	#define new_XPV() (void*)safemalloc(sizeof(XPV))
568	#define del_XPV(p) free((char*)p)
569	#else
570	#define new_XPV() (void*)new_xpv()
571	#define del_XPV(p) del_xpv(p)
572	#endif
573
574	#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
575	#define del_XPVIV(p) free((char*)p)
576
577	#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
578	#define del_XPVNV(p) free((char*)p)
579
580	#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
581	#define del_XPVMG(p) free((char*)p)
582
583	#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
584	#define del_XPVLV(p) free((char*)p)
585
586	#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
587	#define del_XPVAV(p) free((char*)p)
588
589	#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
590	#define del_XPVHV(p) free((char*)p)
591
592	#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
593	#define del_XPVCV(p) free((char*)p)
594
595	#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV))
596	#define del_XPVGV(p) free((char*)p)
597
598	#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
599	#define del_XPVBM(p) free((char*)p)
600
601	#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM))
602	#define del_XPVFM(p) free((char*)p)
603
604	#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO))
605	#define del_XPVIO(p) free((char*)p)
606
607	bool
608	sv_upgrade(sv, mt)
609	register SV* sv;
610	U32 mt;
611	{
612	char* pv;
613	U32 cur;
614	U32 len;
615	IV iv;
616	double nv;
617	MAGIC* magic;
618	HV* stash;
619
620	if (SvTYPE(sv) == mt)
621	return TRUE;
622
623	if (mt < SVt_PVIV)
624	(void)SvOOK_off(sv);
625
626	switch (SvTYPE(sv)) {
627	case SVt_NULL:
628	pv = 0;
629	cur = 0;
630	len = 0;
631	iv = 0;
632	nv = 0.0;
633	magic = 0;
634	stash = 0;
635	break;
636	case SVt_IV:
637	pv = 0;
638	cur = 0;
639	len = 0;
640	iv = SvIVX(sv);
641	nv = (double)SvIVX(sv);
642	del_XIV(SvANY(sv));
643	magic = 0;
644	stash = 0;
645	if (mt == SVt_NV)
646	mt = SVt_PVNV;
647	else if (mt < SVt_PVIV)
648	mt = SVt_PVIV;
649	break;
650	case SVt_NV:
651	pv = 0;
652	cur = 0;
653	len = 0;
654	nv = SvNVX(sv);
655	iv = I_32(nv);
656	magic = 0;
657	stash = 0;
658	del_XNV(SvANY(sv));
659	SvANY(sv) = 0;
660	if (mt < SVt_PVNV)
661	mt = SVt_PVNV;
662	break;
663	case SVt_RV:
664	pv = (char*)SvRV(sv);
665	cur = 0;
666	len = 0;
667	iv = (IV)pv;
668	nv = (double)(unsigned long)pv;
669	del_XRV(SvANY(sv));
670	magic = 0;
671	stash = 0;
672	break;
673	case SVt_PV:
674	pv = SvPVX(sv);
675	cur = SvCUR(sv);
676	len = SvLEN(sv);
677	iv = 0;
678	nv = 0.0;
679	magic = 0;
680	stash = 0;
681	del_XPV(SvANY(sv));
682	if (mt <= SVt_IV)
683	mt = SVt_PVIV;
684	else if (mt == SVt_NV)
685	mt = SVt_PVNV;
686	break;
687	case SVt_PVIV:
688	pv = SvPVX(sv);
689	cur = SvCUR(sv);
690	len = SvLEN(sv);
691	iv = SvIVX(sv);
692	nv = 0.0;
693	magic = 0;
694	stash = 0;
695	del_XPVIV(SvANY(sv));
696	break;
697	case SVt_PVNV:
698	pv = SvPVX(sv);
699	cur = SvCUR(sv);
700	len = SvLEN(sv);
701	iv = SvIVX(sv);
702	nv = SvNVX(sv);
703	magic = 0;
704	stash = 0;
705	del_XPVNV(SvANY(sv));
706	break;
707	case SVt_PVMG:
708	pv = SvPVX(sv);
709	cur = SvCUR(sv);
710	len = SvLEN(sv);
711	iv = SvIVX(sv);
712	nv = SvNVX(sv);
713	magic = SvMAGIC(sv);
714	stash = SvSTASH(sv);
715	del_XPVMG(SvANY(sv));
716	break;
717	default:
718	croak("Can't upgrade that kind of scalar");
719	}
720
721	switch (mt) {
722	case SVt_NULL:
723	croak("Can't upgrade to undef");
724	case SVt_IV:
725	SvANY(sv) = new_XIV();
726	SvIVX(sv) = iv;
727	break;
728	case SVt_NV:
729	SvANY(sv) = new_XNV();
730	SvNVX(sv) = nv;
731	break;
732	case SVt_RV:
733	SvANY(sv) = new_XRV();
734	SvRV(sv) = (SV*)pv;
735	break;
736	case SVt_PV:
737	SvANY(sv) = new_XPV();
738	SvPVX(sv) = pv;
739	SvCUR(sv) = cur;
740	SvLEN(sv) = len;
741	break;
742	case SVt_PVIV:
743	SvANY(sv) = new_XPVIV();
744	SvPVX(sv) = pv;
745	SvCUR(sv) = cur;
746	SvLEN(sv) = len;
747	SvIVX(sv) = iv;
748	if (SvNIOK(sv))
749	(void)SvIOK_on(sv);
750	SvNOK_off(sv);
751	break;
752	case SVt_PVNV:
753	SvANY(sv) = new_XPVNV();
754	SvPVX(sv) = pv;
755	SvCUR(sv) = cur;
756	SvLEN(sv) = len;
757	SvIVX(sv) = iv;
758	SvNVX(sv) = nv;
759	break;
760	case SVt_PVMG:
761	SvANY(sv) = new_XPVMG();
762	SvPVX(sv) = pv;
763	SvCUR(sv) = cur;
764	SvLEN(sv) = len;
765	SvIVX(sv) = iv;
766	SvNVX(sv) = nv;
767	SvMAGIC(sv) = magic;
768	SvSTASH(sv) = stash;
769	break;
770	case SVt_PVLV:
771	SvANY(sv) = new_XPVLV();
772	SvPVX(sv) = pv;
773	SvCUR(sv) = cur;
774	SvLEN(sv) = len;
775	SvIVX(sv) = iv;
776	SvNVX(sv) = nv;
777	SvMAGIC(sv) = magic;
778	SvSTASH(sv) = stash;
779	LvTARGOFF(sv) = 0;
780	LvTARGLEN(sv) = 0;
781	LvTARG(sv) = 0;
782	LvTYPE(sv) = 0;
783	break;
784	case SVt_PVAV:
785	SvANY(sv) = new_XPVAV();
786	if (pv)
787	Safefree(pv);
788	SvPVX(sv) = 0;
789	AvMAX(sv) = -1;
790	AvFILL(sv) = -1;
791	SvIVX(sv) = 0;
792	SvNVX(sv) = 0.0;
793	SvMAGIC(sv) = magic;
794	SvSTASH(sv) = stash;
795	AvALLOC(sv) = 0;
796	AvARYLEN(sv) = 0;
797	AvFLAGS(sv) = 0;
798	break;
799	case SVt_PVHV:
800	SvANY(sv) = new_XPVHV();
801	if (pv)
802	Safefree(pv);
803	SvPVX(sv) = 0;
804	HvFILL(sv) = 0;
805	HvMAX(sv) = 0;
806	HvKEYS(sv) = 0;
807	SvNVX(sv) = 0.0;
808	SvMAGIC(sv) = magic;
809	SvSTASH(sv) = stash;
810	HvRITER(sv) = 0;
811	HvEITER(sv) = 0;
812	HvPMROOT(sv) = 0;
813	HvNAME(sv) = 0;
814	break;
815	case SVt_PVCV:
816	SvANY(sv) = new_XPVCV();
817	Zero(SvANY(sv), 1, XPVCV);
818	SvPVX(sv) = pv;
819	SvCUR(sv) = cur;
820	SvLEN(sv) = len;
821	SvIVX(sv) = iv;
822	SvNVX(sv) = nv;
823	SvMAGIC(sv) = magic;
824	SvSTASH(sv) = stash;
825	break;
826	case SVt_PVGV:
827	SvANY(sv) = new_XPVGV();
828	SvPVX(sv) = pv;
829	SvCUR(sv) = cur;
830	SvLEN(sv) = len;
831	SvIVX(sv) = iv;
832	SvNVX(sv) = nv;
833	SvMAGIC(sv) = magic;
834	SvSTASH(sv) = stash;
835	GvGP(sv) = 0;
836	GvNAME(sv) = 0;
837	GvNAMELEN(sv) = 0;
838	GvSTASH(sv) = 0;
839	GvFLAGS(sv) = 0;
840	break;
841	case SVt_PVBM:
842	SvANY(sv) = new_XPVBM();
843	SvPVX(sv) = pv;
844	SvCUR(sv) = cur;
845	SvLEN(sv) = len;
846	SvIVX(sv) = iv;
847	SvNVX(sv) = nv;
848	SvMAGIC(sv) = magic;
849	SvSTASH(sv) = stash;
850	BmRARE(sv) = 0;
851	BmUSEFUL(sv) = 0;
852	BmPREVIOUS(sv) = 0;
853	break;
854	case SVt_PVFM:
855	SvANY(sv) = new_XPVFM();
856	Zero(SvANY(sv), 1, XPVFM);
857	SvPVX(sv) = pv;
858	SvCUR(sv) = cur;
859	SvLEN(sv) = len;
860	SvIVX(sv) = iv;
861	SvNVX(sv) = nv;
862	SvMAGIC(sv) = magic;
863	SvSTASH(sv) = stash;
864	break;
865	case SVt_PVIO:
866	SvANY(sv) = new_XPVIO();
867	Zero(SvANY(sv), 1, XPVIO);
868	SvPVX(sv) = pv;
869	SvCUR(sv) = cur;
870	SvLEN(sv) = len;
871	SvIVX(sv) = iv;
872	SvNVX(sv) = nv;
873	SvMAGIC(sv) = magic;
874	SvSTASH(sv) = stash;
875	IoPAGE_LEN(sv) = 60;
876	break;
877	}
878	SvFLAGS(sv) &= ~SVTYPEMASK;
879	SvFLAGS(sv) \|= mt;
880	return TRUE;
881	}
882
883	#ifdef DEBUGGING
884	char *
885	sv_peek(sv)
886	register SV *sv;
887	{
888	SV *t = sv_newmortal();
889	STRLEN prevlen;
890	int unref = 0;
891
892	sv_setpvn(t, "", 0);
893	retry:
894	if (!sv) {
895	sv_catpv(t, "VOID");
896	goto finish;
897	}
898	else if (sv == (SV*)0x55555555 \|\| SvTYPE(sv) == 'U') {
899	sv_catpv(t, "WILD");
900	goto finish;
901	}
902	else if (sv == &sv_undef \|\| sv == &sv_no \|\| sv == &sv_yes) {
903	if (sv == &sv_undef) {
904	sv_catpv(t, "SV_UNDEF");
905	if (!(SvFLAGS(sv) & (SVf_OK\|SVf_OOK\|SVs_OBJECT\|
906	SVs_GMG\|SVs_SMG\|SVs_RMG)) &&
907	SvREADONLY(sv))
908	goto finish;
909	}
910	else if (sv == &sv_no) {
911	sv_catpv(t, "SV_NO");
912	if (!(SvFLAGS(sv) & (SVf_ROK\|SVf_OOK\|SVs_OBJECT\|
913	SVs_GMG\|SVs_SMG\|SVs_RMG)) &&
914	!(~SvFLAGS(sv) & (SVf_POK\|SVf_NOK\|SVf_READONLY\|
915	SVp_POK\|SVp_NOK)) &&
916	SvCUR(sv) == 0 &&
917	SvNVX(sv) == 0.0)
918	goto finish;
919	}
920	else {
921	sv_catpv(t, "SV_YES");
922	if (!(SvFLAGS(sv) & (SVf_ROK\|SVf_OOK\|SVs_OBJECT\|
923	SVs_GMG\|SVs_SMG\|SVs_RMG)) &&
924	!(~SvFLAGS(sv) & (SVf_POK\|SVf_NOK\|SVf_READONLY\|
925	SVp_POK\|SVp_NOK)) &&
926	SvCUR(sv) == 1 &&
927	SvPVX(sv) && *SvPVX(sv) == '1' &&
928	SvNVX(sv) == 1.0)
929	goto finish;
930	}
931	sv_catpv(t, ":");
932	}
933	else if (SvREFCNT(sv) == 0) {
934	sv_catpv(t, "(");
935	unref++;
936	}
937	if (SvROK(sv)) {
938	sv_catpv(t, "\\");
939	if (SvCUR(t) + unref > 10) {
940	SvCUR(t) = unref + 3;
941	*SvEND(t) = '\0';
942	sv_catpv(t, "...");
943	goto finish;
944	}
945	sv = (SV*)SvRV(sv);
946	goto retry;
947	}
948	switch (SvTYPE(sv)) {
949	default:
950	sv_catpv(t, "FREED");
951	goto finish;
952
953	case SVt_NULL:
954	sv_catpv(t, "UNDEF");
955	goto finish;
956	case SVt_IV:
957	sv_catpv(t, "IV");
958	break;
959	case SVt_NV:
960	sv_catpv(t, "NV");
961	break;
962	case SVt_RV:
963	sv_catpv(t, "RV");
964	break;
965	case SVt_PV:
966	sv_catpv(t, "PV");
967	break;
968	case SVt_PVIV:
969	sv_catpv(t, "PVIV");
970	break;
971	case SVt_PVNV:
972	sv_catpv(t, "PVNV");
973	break;
974	case SVt_PVMG:
975	sv_catpv(t, "PVMG");
976	break;
977	case SVt_PVLV:
978	sv_catpv(t, "PVLV");
979	break;
980	case SVt_PVAV:
981	sv_catpv(t, "AV");
982	break;
983	case SVt_PVHV:
984	sv_catpv(t, "HV");
985	break;
986	case SVt_PVCV:
987	if (CvGV(sv))
988	sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
989	else
990	sv_catpv(t, "CV()");
991	goto finish;
992	case SVt_PVGV:
993	sv_catpv(t, "GV");
994	break;
995	case SVt_PVBM:
996	sv_catpv(t, "BM");
997	break;
998	case SVt_PVFM:
999	sv_catpv(t, "FM");
1000	break;
1001	case SVt_PVIO:
1002	sv_catpv(t, "IO");
1003	break;
1004	}
1005
1006	if (SvPOKp(sv)) {
1007	if (!SvPVX(sv))
1008	sv_catpv(t, "(null)");
1009	if (SvOOK(sv))
1010	sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
1011	else
1012	sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
1013	}
1014	else if (SvNOKp(sv)) {
1015	SET_NUMERIC_STANDARD();
1016	sv_catpvf(t, "(%g)",SvNVX(sv));
1017	}
1018	else if (SvIOKp(sv))
1019	sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
1020	else
1021	sv_catpv(t, "()");
1022
1023	finish:
1024	if (unref) {
1025	while (unref--)
1026	sv_catpv(t, ")");
1027	}
1028	return SvPV(t, na);
1029	}
1030	#endif
1031
1032	int
1033	sv_backoff(sv)
1034	register SV *sv;
1035	{
1036	assert(SvOOK(sv));
1037	if (SvIVX(sv)) {
1038	char *s = SvPVX(sv);
1039	SvLEN(sv) += SvIVX(sv);
1040	SvPVX(sv) -= SvIVX(sv);
1041	SvIV_set(sv, 0);
1042	Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1043	}
1044	SvFLAGS(sv) &= ~SVf_OOK;
1045	return 0;
1046	}
1047
1048	char *
1049	sv_grow(sv,newlen)
1050	register SV *sv;
1051	#ifndef DOSISH
1052	register I32 newlen;
1053	#else
1054	unsigned long newlen;
1055	#endif
1056	{
1057	register char *s;
1058
1059	#ifdef HAS_64K_LIMIT
1060	if (newlen >= 0x10000) {
1061	PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
1062	my_exit(1);
1063	}
1064	#endif /* HAS_64K_LIMIT */
1065	if (SvROK(sv))
1066	sv_unref(sv);
1067	if (SvTYPE(sv) < SVt_PV) {
1068	sv_upgrade(sv, SVt_PV);
1069	s = SvPVX(sv);
1070	}
1071	else if (SvOOK(sv)) { /* pv is offset? */
1072	sv_backoff(sv);
1073	s = SvPVX(sv);
1074	if (newlen > SvLEN(sv))
1075	newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1076	}
1077	else
1078	s = SvPVX(sv);
1079	if (newlen > SvLEN(sv)) { /* need more room? */
1080	if (SvLEN(sv) && s)
1081	Renew(s,newlen,char);
1082	else
1083	New(703,s,newlen,char);
1084	SvPV_set(sv, s);
1085	SvLEN_set(sv, newlen);
1086	}
1087	return s;
1088	}
1089
1090	void
1091	sv_setiv(sv,i)
1092	register SV *sv;
1093	IV i;
1094	{
1095	if (SvTHINKFIRST(sv)) {
1096	if (SvREADONLY(sv) && curcop != &compiling)
1097	croak(no_modify);
1098	if (SvROK(sv))
1099	sv_unref(sv);
1100	}
1101	switch (SvTYPE(sv)) {
1102	case SVt_NULL:
1103	sv_upgrade(sv, SVt_IV);
1104	break;
1105	case SVt_NV:
1106	sv_upgrade(sv, SVt_PVNV);
1107	break;
1108	case SVt_RV:
1109	case SVt_PV:
1110	sv_upgrade(sv, SVt_PVIV);
1111	break;
1112
1113	case SVt_PVGV:
1114	if (SvFAKE(sv)) {
1115	sv_unglob(sv);
1116	break;
1117	}
1118	/* FALL THROUGH */
1119	case SVt_PVAV:
1120	case SVt_PVHV:
1121	case SVt_PVCV:
1122	case SVt_PVFM:
1123	case SVt_PVIO:
1124	croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
1125	op_desc[op->op_type]);
1126	}
1127	(void)SvIOK_only(sv); /* validate number */
1128	SvIVX(sv) = i;
1129	SvTAINT(sv);
1130	}
1131
1132	void
1133	sv_setuv(sv,u)
1134	register SV *sv;
1135	UV u;
1136	{
1137	if (u <= IV_MAX)
1138	sv_setiv(sv, u);
1139	else
1140	sv_setnv(sv, (double)u);
1141	}
1142
1143	void
1144	sv_setnv(sv,num)
1145	register SV *sv;
1146	double num;
1147	{
1148	if (SvTHINKFIRST(sv)) {
1149	if (SvREADONLY(sv) && curcop != &compiling)
1150	croak(no_modify);
1151	if (SvROK(sv))
1152	sv_unref(sv);
1153	}
1154	switch (SvTYPE(sv)) {
1155	case SVt_NULL:
1156	case SVt_IV:
1157	sv_upgrade(sv, SVt_NV);
1158	break;
1159	case SVt_NV:
1160	case SVt_RV:
1161	case SVt_PV:
1162	case SVt_PVIV:
1163	sv_upgrade(sv, SVt_PVNV);
1164	/* FALL THROUGH */
1165	case SVt_PVNV:
1166	case SVt_PVMG:
1167	case SVt_PVBM:
1168	case SVt_PVLV:
1169	if (SvOOK(sv))
1170	(void)SvOOK_off(sv);
1171	break;
1172	case SVt_PVGV:
1173	if (SvFAKE(sv)) {
1174	sv_unglob(sv);
1175	break;
1176	}
1177	/* FALL THROUGH */
1178	case SVt_PVAV:
1179	case SVt_PVHV:
1180	case SVt_PVCV:
1181	case SVt_PVFM:
1182	case SVt_PVIO:
1183	croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
1184	op_name[op->op_type]);
1185	}
1186	SvNVX(sv) = num;
1187	(void)SvNOK_only(sv); /* validate number */
1188	SvTAINT(sv);
1189	}
1190
1191	static void
1192	not_a_number(sv)
1193	SV *sv;
1194	{
1195	char tmpbuf[64];
1196	char *d = tmpbuf;
1197	char *s;
1198	char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1199	/* each *s can expand to 4 chars + "...\0",
1200	i.e. need room for 8 chars */
1201
1202	for (s = SvPVX(sv); *s && d < limit; s++) {
1203	int ch = *s & 0xFF;
1204	if (ch & 128 && !isPRINT_LC(ch)) {
1205	*d++ = 'M';
1206	*d++ = '-';
1207	ch &= 127;
1208	}
1209	if (ch == '\n') {
1210	*d++ = '\\';
1211	*d++ = 'n';
1212	}
1213	else if (ch == '\r') {
1214	*d++ = '\\';
1215	*d++ = 'r';
1216	}
1217	else if (ch == '\f') {
1218	*d++ = '\\';
1219	*d++ = 'f';
1220	}
1221	else if (ch == '\\') {
1222	*d++ = '\\';
1223	*d++ = '\\';
1224	}
1225	else if (isPRINT_LC(ch))
1226	*d++ = ch;
1227	else {
1228	*d++ = '^';
1229	*d++ = toCTRL(ch);
1230	}
1231	}
1232	if (*s) {
1233	*d++ = '.';
1234	*d++ = '.';
1235	*d++ = '.';
1236	}
1237	*d = '\0';
1238
1239	if (op)
1240	warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
1241	op_name[op->op_type]);
1242	else
1243	warn("Argument \"%s\" isn't numeric", tmpbuf);
1244	}
1245
1246	IV
1247	sv_2iv(sv)
1248	register SV *sv;
1249	{
1250	if (!sv)
1251	return 0;
1252	if (SvGMAGICAL(sv)) {
1253	mg_get(sv);
1254	if (SvIOKp(sv))
1255	return SvIVX(sv);
1256	if (SvNOKp(sv)) {
1257	if (SvNVX(sv) < 0.0)
1258	return I_V(SvNVX(sv));
1259	else
1260	return (IV) U_V(SvNVX(sv));
1261	}
1262	if (SvPOKp(sv) && SvLEN(sv))
1263	return asIV(sv);
1264	if (!SvROK(sv)) {
1265	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1266	warn(warn_uninit);
1267	return 0;
1268	}
1269	}
1270	if (SvTHINKFIRST(sv)) {
1271	if (SvROK(sv)) {
1272	#ifdef OVERLOAD
1273	SV* tmpstr;
1274	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1275	return SvIV(tmpstr);
1276	#endif /* OVERLOAD */
1277	return (IV)SvRV(sv);
1278	}
1279	if (SvREADONLY(sv)) {
1280	if (SvNOKp(sv)) {
1281	if (SvNVX(sv) < 0.0)
1282	return I_V(SvNVX(sv));
1283	else
1284	return (IV) U_V(SvNVX(sv));
1285	}
1286	if (SvPOKp(sv) && SvLEN(sv))
1287	return asIV(sv);
1288	if (dowarn)
1289	warn(warn_uninit);
1290	return 0;
1291	}
1292	}
1293	switch (SvTYPE(sv)) {
1294	case SVt_NULL:
1295	sv_upgrade(sv, SVt_IV);
1296	break;
1297	case SVt_PV:
1298	sv_upgrade(sv, SVt_PVIV);
1299	break;
1300	case SVt_NV:
1301	sv_upgrade(sv, SVt_PVNV);
1302	break;
1303	}
1304	if (SvNOKp(sv)) {
1305	(void)SvIOK_on(sv);
1306	if (SvNVX(sv) < 0.0)
1307	SvIVX(sv) = I_V(SvNVX(sv));
1308	else
1309	SvUVX(sv) = U_V(SvNVX(sv));
1310	}
1311	else if (SvPOKp(sv) && SvLEN(sv)) {
1312	(void)SvIOK_on(sv);
1313	SvIVX(sv) = asIV(sv);
1314	}
1315	else {
1316	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1317	warn(warn_uninit);
1318	return 0;
1319	}
1320	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1321	(unsigned long)sv,(long)SvIVX(sv)));
1322	return SvIVX(sv);
1323	}
1324
1325	UV
1326	sv_2uv(sv)
1327	register SV *sv;
1328	{
1329	if (!sv)
1330	return 0;
1331	if (SvGMAGICAL(sv)) {
1332	mg_get(sv);
1333	if (SvIOKp(sv))
1334	return SvUVX(sv);
1335	if (SvNOKp(sv))
1336	return U_V(SvNVX(sv));
1337	if (SvPOKp(sv) && SvLEN(sv))
1338	return asUV(sv);
1339	if (!SvROK(sv)) {
1340	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1341	warn(warn_uninit);
1342	return 0;
1343	}
1344	}
1345	if (SvTHINKFIRST(sv)) {
1346	if (SvROK(sv)) {
1347	#ifdef OVERLOAD
1348	SV* tmpstr;
1349	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1350	return SvUV(tmpstr);
1351	#endif /* OVERLOAD */
1352	return (UV)SvRV(sv);
1353	}
1354	if (SvREADONLY(sv)) {
1355	if (SvNOKp(sv)) {
1356	return U_V(SvNVX(sv));
1357	}
1358	if (SvPOKp(sv) && SvLEN(sv))
1359	return asUV(sv);
1360	if (dowarn)
1361	warn(warn_uninit);
1362	return 0;
1363	}
1364	}
1365	switch (SvTYPE(sv)) {
1366	case SVt_NULL:
1367	sv_upgrade(sv, SVt_IV);
1368	break;
1369	case SVt_PV:
1370	sv_upgrade(sv, SVt_PVIV);
1371	break;
1372	case SVt_NV:
1373	sv_upgrade(sv, SVt_PVNV);
1374	break;
1375	}
1376	if (SvNOKp(sv)) {
1377	(void)SvIOK_on(sv);
1378	SvUVX(sv) = U_V(SvNVX(sv));
1379	}
1380	else if (SvPOKp(sv) && SvLEN(sv)) {
1381	(void)SvIOK_on(sv);
1382	SvUVX(sv) = asUV(sv);
1383	}
1384	else {
1385	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1386	warn(warn_uninit);
1387	return 0;
1388	}
1389	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1390	(unsigned long)sv,SvUVX(sv)));
1391	return SvUVX(sv);
1392	}
1393
1394	double
1395	sv_2nv(sv)
1396	register SV *sv;
1397	{
1398	if (!sv)
1399	return 0.0;
1400	if (SvGMAGICAL(sv)) {
1401	mg_get(sv);
1402	if (SvNOKp(sv))
1403	return SvNVX(sv);
1404	if (SvPOKp(sv) && SvLEN(sv)) {
1405	if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
1406	not_a_number(sv);
1407	SET_NUMERIC_STANDARD();
1408	return atof(SvPVX(sv));
1409	}
1410	if (SvIOKp(sv))
1411	return (double)SvIVX(sv);
1412	if (!SvROK(sv)) {
1413	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1414	warn(warn_uninit);
1415	return 0;
1416	}
1417	}
1418	if (SvTHINKFIRST(sv)) {
1419	if (SvROK(sv)) {
1420	#ifdef OVERLOAD
1421	SV* tmpstr;
1422	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1423	return SvNV(tmpstr);
1424	#endif /* OVERLOAD */
1425	return (double)(unsigned long)SvRV(sv);
1426	}
1427	if (SvREADONLY(sv)) {
1428	if (SvPOKp(sv) && SvLEN(sv)) {
1429	if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
1430	not_a_number(sv);
1431	SET_NUMERIC_STANDARD();
1432	return atof(SvPVX(sv));
1433	}
1434	if (SvIOKp(sv))
1435	return (double)SvIVX(sv);
1436	if (dowarn)
1437	warn(warn_uninit);
1438	return 0.0;
1439	}
1440	}
1441	if (SvTYPE(sv) < SVt_NV) {
1442	if (SvTYPE(sv) == SVt_IV)
1443	sv_upgrade(sv, SVt_PVNV);
1444	else
1445	sv_upgrade(sv, SVt_NV);
1446	DEBUG_c(SET_NUMERIC_STANDARD());
1447	DEBUG_c(PerlIO_printf(Perl_debug_log,
1448	"0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
1449	}
1450	else if (SvTYPE(sv) < SVt_PVNV)
1451	sv_upgrade(sv, SVt_PVNV);
1452	if (SvIOKp(sv) &&
1453	(!SvPOKp(sv) \|\| !strchr(SvPVX(sv),'.') \|\| !looks_like_number(sv)))
1454	{
1455	SvNVX(sv) = (double)SvIVX(sv);
1456	}
1457	else if (SvPOKp(sv) && SvLEN(sv)) {
1458	if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
1459	not_a_number(sv);
1460	SET_NUMERIC_STANDARD();
1461	SvNVX(sv) = atof(SvPVX(sv));
1462	}
1463	else {
1464	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1465	warn(warn_uninit);
1466	return 0.0;
1467	}
1468	SvNOK_on(sv);
1469	DEBUG_c(SET_NUMERIC_STANDARD());
1470	DEBUG_c(PerlIO_printf(Perl_debug_log,
1471	"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
1472	return SvNVX(sv);
1473	}
1474
1475	static IV
1476	asIV(sv)
1477	SV *sv;
1478	{
1479	I32 numtype = looks_like_number(sv);
1480	double d;
1481
1482	if (numtype == 1)
1483	return atol(SvPVX(sv));
1484	if (!numtype && dowarn)
1485	not_a_number(sv);
1486	SET_NUMERIC_STANDARD();
1487	d = atof(SvPVX(sv));
1488	if (d < 0.0)
1489	return I_V(d);
1490	else
1491	return (IV) U_V(d);
1492	}
1493
1494	static UV
1495	asUV(sv)
1496	SV *sv;
1497	{
1498	I32 numtype = looks_like_number(sv);
1499
1500	#ifdef HAS_STRTOUL
1501	if (numtype == 1)
1502	return strtoul(SvPVX(sv), Null(char**), 10);
1503	#endif
1504	if (!numtype && dowarn)
1505	not_a_number(sv);
1506	SET_NUMERIC_STANDARD();
1507	return U_V(atof(SvPVX(sv)));
1508	}
1509
1510	I32
1511	looks_like_number(sv)
1512	SV *sv;
1513	{
1514	register char *s;
1515	register char *send;
1516	register char *sbegin;
1517	I32 numtype;
1518	STRLEN len;
1519
1520	if (SvPOK(sv)) {
1521	sbegin = SvPVX(sv);
1522	len = SvCUR(sv);
1523	}
1524	else if (SvPOKp(sv))
1525	sbegin = SvPV(sv, len);
1526	else
1527	return 1;
1528	send = sbegin + len;
1529
1530	s = sbegin;
1531	while (isSPACE(*s))
1532	s++;
1533	if (s == '+' \|\| s == '-')
1534	s++;
1535
1536	/* next must be digit or '.' */
1537	if (isDIGIT(*s)) {
1538	do {
1539	s++;
1540	} while (isDIGIT(*s));
1541	if (*s == '.') {
1542	s++;
1543	while (isDIGIT(s)) / optional digits after "." */
1544	s++;
1545	}
1546	}
1547	else if (*s == '.') {
1548	s++;
1549	/* no digits before '.' means we need digits after it */
1550	if (isDIGIT(*s)) {
1551	do {
1552	s++;
1553	} while (isDIGIT(*s));
1554	}
1555	else
1556	return 0;
1557	}
1558	else
1559	return 0;
1560
1561	/*
1562	* we return 1 if the number can be converted to _integer_ with atol()
1563	* and 2 if you need (int)atof().
1564	*/
1565	numtype = 1;
1566
1567	/* we can have an optional exponent part */
1568	if (s == 'e' \|\| s == 'E') {
1569	numtype = 2;
1570	s++;
1571	if (s == '+' \|\| s == '-')
1572	s++;
1573	if (isDIGIT(*s)) {
1574	do {
1575	s++;
1576	} while (isDIGIT(*s));
1577	}
1578	else
1579	return 0;
1580	}
1581	while (isSPACE(*s))
1582	s++;
1583	if (s >= send)
1584	return numtype;
1585	if (len == 10 && memEQ(sbegin, "0 but true", 10))
1586	return 1;
1587	return 0;
1588	}
1589
1590	char *
1591	sv_2pv(sv, lp)
1592	register SV *sv;
1593	STRLEN *lp;
1594	{
1595	register char *s;
1596	int olderrno;
1597	SV *tsv;
1598
1599	if (!sv) {
1600	*lp = 0;
1601	return "";
1602	}
1603	if (SvGMAGICAL(sv)) {
1604	mg_get(sv);
1605	if (SvPOKp(sv)) {
1606	*lp = SvCUR(sv);
1607	return SvPVX(sv);
1608	}
1609	if (SvIOKp(sv)) {
1610	(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
1611	tsv = Nullsv;
1612	goto tokensave;
1613	}
1614	if (SvNOKp(sv)) {
1615	SET_NUMERIC_STANDARD();
1616	Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
1617	tsv = Nullsv;
1618	goto tokensave;
1619	}
1620	if (!SvROK(sv)) {
1621	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1622	warn(warn_uninit);
1623	*lp = 0;
1624	return "";
1625	}
1626	}
1627	if (SvTHINKFIRST(sv)) {
1628	if (SvROK(sv)) {
1629	#ifdef OVERLOAD
1630	SV* tmpstr;
1631	if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1632	return SvPV(tmpstr,*lp);
1633	#endif /* OVERLOAD */
1634	sv = (SV*)SvRV(sv);
1635	if (!sv)
1636	s = "NULLREF";
1637	else {
1638	switch (SvTYPE(sv)) {
1639	case SVt_NULL:
1640	case SVt_IV:
1641	case SVt_NV:
1642	case SVt_RV:
1643	case SVt_PV:
1644	case SVt_PVIV:
1645	case SVt_PVNV:
1646	case SVt_PVBM:
1647	case SVt_PVMG: s = "SCALAR"; break;
1648	case SVt_PVLV: s = "LVALUE"; break;
1649	case SVt_PVAV: s = "ARRAY"; break;
1650	case SVt_PVHV: s = "HASH"; break;
1651	case SVt_PVCV: s = "CODE"; break;
1652	case SVt_PVGV: s = "GLOB"; break;
1653	case SVt_PVFM: s = "FORMATLINE"; break;
1654	case SVt_PVIO: s = "IO"; break;
1655	default: s = "UNKNOWN"; break;
1656	}
1657	tsv = NEWSV(0,0);
1658	if (SvOBJECT(sv))
1659	sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1660	else
1661	sv_setpv(tsv, s);
1662	sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
1663	goto tokensaveref;
1664	}
1665	*lp = strlen(s);
1666	return s;
1667	}
1668	if (SvREADONLY(sv)) {
1669	if (SvNOKp(sv)) {
1670	SET_NUMERIC_STANDARD();
1671	Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
1672	tsv = Nullsv;
1673	goto tokensave;
1674	}
1675	if (SvIOKp(sv)) {
1676	(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
1677	tsv = Nullsv;
1678	goto tokensave;
1679	}
1680	if (dowarn)
1681	warn(warn_uninit);
1682	*lp = 0;
1683	return "";
1684	}
1685	}
1686	if (!SvUPGRADE(sv, SVt_PV))
1687	return 0;
1688	if (SvNOKp(sv)) {
1689	if (SvTYPE(sv) < SVt_PVNV)
1690	sv_upgrade(sv, SVt_PVNV);
1691	SvGROW(sv, 28);
1692	s = SvPVX(sv);
1693	olderrno = errno; /* some Xenix systems wipe out errno here */
1694	#ifdef apollo
1695	if (SvNVX(sv) == 0.0)
1696	(void)strcpy(s,"0");
1697	else
1698	#endif /apollo/
1699	{
1700	SET_NUMERIC_STANDARD();
1701	Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1702	}
1703	errno = olderrno;
1704	#ifdef FIXNEGATIVEZERO
1705	if (*s == '-' && s[1] == '0' && !s[2])
1706	strcpy(s,"0");
1707	#endif
1708	while (*s) s++;
1709	#ifdef hcx
1710	if (s[-1] == '.')
1711	*--s = '\0';
1712	#endif
1713	}
1714	else if (SvIOKp(sv)) {
1715	U32 oldIOK = SvIOK(sv);
1716	if (SvTYPE(sv) < SVt_PVIV)
1717	sv_upgrade(sv, SVt_PVIV);
1718	olderrno = errno; /* some Xenix systems wipe out errno here */
1719	sv_setpviv(sv, SvIVX(sv));
1720	errno = olderrno;
1721	s = SvEND(sv);
1722	if (oldIOK)
1723	SvIOK_on(sv);
1724	else
1725	SvIOKp_on(sv);
1726	}
1727	else {
1728	if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1729	warn(warn_uninit);
1730	*lp = 0;
1731	return "";
1732	}
1733	*lp = s - SvPVX(sv);
1734	SvCUR_set(sv, *lp);
1735	SvPOK_on(sv);
1736	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1737	return SvPVX(sv);
1738
1739	tokensave:
1740	if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1741	/* Sneaky stuff here */
1742
1743	tokensaveref:
1744	if (!tsv)
1745	tsv = newSVpv(tokenbuf, 0);
1746	sv_2mortal(tsv);
1747	*lp = SvCUR(tsv);
1748	return SvPVX(tsv);
1749	}
1750	else {
1751	STRLEN len;
1752	char *t;
1753
1754	if (tsv) {
1755	sv_2mortal(tsv);
1756	t = SvPVX(tsv);
1757	len = SvCUR(tsv);
1758	}
1759	else {
1760	t = tokenbuf;
1761	len = strlen(tokenbuf);
1762	}
1763	#ifdef FIXNEGATIVEZERO
1764	if (len == 2 && t[0] == '-' && t[1] == '0') {
1765	t = "0";
1766	len = 1;
1767	}
1768	#endif
1769	(void)SvUPGRADE(sv, SVt_PV);
1770	*lp = len;
1771	s = SvGROW(sv, len + 1);
1772	SvCUR_set(sv, len);
1773	(void)strcpy(s, t);
1774	SvPOKp_on(sv);
1775	return s;
1776	}
1777	}
1778
1779	/* This function is only called on magical items */
1780	bool
1781	sv_2bool(sv)
1782	register SV *sv;
1783	{
1784	if (SvGMAGICAL(sv))
1785	mg_get(sv);
1786
1787	if (!SvOK(sv))
1788	return 0;
1789	if (SvROK(sv)) {
1790	#ifdef OVERLOAD
1791	{
1792	SV* tmpsv;
1793	if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1794	return SvTRUE(tmpsv);
1795	}
1796	#endif /* OVERLOAD */
1797	return SvRV(sv) != 0;
1798	}
1799	if (SvPOKp(sv)) {
1800	register XPV* Xpv;
1801	if ((Xpv = (XPV*)SvANY(sv)) &&
1802	(*Xpv->xpv_pv > '0' \|\|
1803	Xpv->xpv_cur > 1 \|\|
1804	(Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
1805	return 1;
1806	else
1807	return 0;
1808	}
1809	else {
1810	if (SvIOKp(sv))
1811	return SvIVX(sv) != 0;
1812	else {
1813	if (SvNOKp(sv))
1814	return SvNVX(sv) != 0.0;
1815	else
1816	return FALSE;
1817	}
1818	}
1819	}
1820
1821	/* Note: sv_setsv() should not be called with a source string that needs
1822	* to be reused, since it may destroy the source string if it is marked
1823	* as temporary.
1824	*/
1825
1826	void
1827	sv_setsv(dstr,sstr)
1828	SV *dstr;
1829	register SV *sstr;
1830	{
1831	register U32 sflags;
1832	register int dtype;
1833	register int stype;
1834
1835	if (sstr == dstr)
1836	return;
1837	if (SvTHINKFIRST(dstr)) {
1838	if (SvREADONLY(dstr) && curcop != &compiling)
1839	croak(no_modify);
1840	if (SvROK(dstr))
1841	sv_unref(dstr);
1842	}
1843	if (!sstr)
1844	sstr = &sv_undef;
1845	stype = SvTYPE(sstr);
1846	dtype = SvTYPE(dstr);
1847
1848	if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
1849	sv_unglob(dstr); /* so fake GLOB won't perpetuate */
1850	sv_setpvn(dstr, "", 0);
1851	(void)SvPOK_only(dstr);
1852	dtype = SvTYPE(dstr);
1853	}
1854
1855	#ifdef OVERLOAD
1856	SvAMAGIC_off(dstr);
1857	#endif /* OVERLOAD */
1858	/* There's a lot of redundancy below but we're going for speed here */
1859
1860	switch (stype) {
1861	case SVt_NULL:
1862	(void)SvOK_off(dstr);
1863	return;
1864	case SVt_IV:
1865	if (dtype != SVt_IV && dtype < SVt_PVIV) {
1866	if (dtype < SVt_IV)
1867	sv_upgrade(dstr, SVt_IV);
1868	else if (dtype == SVt_NV)
1869	sv_upgrade(dstr, SVt_PVNV);
1870	else
1871	sv_upgrade(dstr, SVt_PVIV);
1872	}
1873	break;
1874	case SVt_NV:
1875	if (dtype != SVt_NV && dtype < SVt_PVNV) {
1876	if (dtype < SVt_NV)
1877	sv_upgrade(dstr, SVt_NV);
1878	else
1879	sv_upgrade(dstr, SVt_PVNV);
1880	}
1881	break;
1882	case SVt_RV:
1883	if (dtype < SVt_RV)
1884	sv_upgrade(dstr, SVt_RV);
1885	else if (dtype == SVt_PVGV &&
1886	SvTYPE(SvRV(sstr)) == SVt_PVGV) {
1887	sstr = SvRV(sstr);
1888	if (sstr == dstr) {
1889	if (curcop->cop_stash != GvSTASH(dstr))
1890	GvIMPORTED_on(dstr);
1891	GvMULTI_on(dstr);
1892	return;
1893	}
1894	goto glob_assign;
1895	}
1896	break;
1897	case SVt_PV:
1898	case SVt_PVFM:
1899	if (dtype < SVt_PV)
1900	sv_upgrade(dstr, SVt_PV);
1901	break;
1902	case SVt_PVIV:
1903	if (dtype < SVt_PVIV)
1904	sv_upgrade(dstr, SVt_PVIV);
1905	break;
1906	case SVt_PVNV:
1907	if (dtype < SVt_PVNV)
1908	sv_upgrade(dstr, SVt_PVNV);
1909	break;
1910
1911	case SVt_PVLV:
1912	sv_upgrade(dstr, SVt_PVLV);
1913	break;
1914
1915	case SVt_PVAV:
1916	case SVt_PVHV:
1917	case SVt_PVCV:
1918	case SVt_PVIO:
1919	if (op)
1920	croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
1921	op_name[op->op_type]);
1922	else
1923	croak("Bizarre copy of %s", sv_reftype(sstr, 0));
1924	break;
1925
1926	case SVt_PVGV:
1927	if (dtype <= SVt_PVGV) {
1928	glob_assign:
1929	if (dtype != SVt_PVGV) {
1930	char *name = GvNAME(sstr);
1931	STRLEN len = GvNAMELEN(sstr);
1932	sv_upgrade(dstr, SVt_PVGV);
1933	sv_magic(dstr, dstr, '*', name, len);
1934	GvSTASH(dstr) = GvSTASH(sstr);
1935	GvNAME(dstr) = savepvn(name, len);
1936	GvNAMELEN(dstr) = len;
1937	SvFAKE_on(dstr); /* can coerce to non-glob */
1938	}
1939	/* ahem, death to those who redefine active sort subs */
1940	else if (curstack == sortstack
1941	&& GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
1942	croak("Can't redefine active sort subroutine %s",
1943	GvNAME(dstr));
1944	(void)SvOK_off(dstr);
1945	GvINTRO_off(dstr); /* one-shot flag */
1946	gp_free((GV*)dstr);
1947	GvGP(dstr) = gp_ref(GvGP(sstr));
1948	SvTAINT(dstr);
1949	if (curcop->cop_stash != GvSTASH(dstr))
1950	GvIMPORTED_on(dstr);
1951	GvMULTI_on(dstr);
1952	return;
1953	}
1954	/* FALL THROUGH */
1955
1956	default:
1957	if (SvGMAGICAL(sstr)) {
1958	mg_get(sstr);
1959	if (SvTYPE(sstr) != stype) {
1960	stype = SvTYPE(sstr);
1961	if (stype == SVt_PVGV && dtype <= SVt_PVGV)
1962	goto glob_assign;
1963	}
1964	}
1965	if (dtype < stype)
1966	sv_upgrade(dstr, stype);
1967	}
1968
1969	sflags = SvFLAGS(sstr);
1970
1971	if (sflags & SVf_ROK) {
1972	if (dtype >= SVt_PV) {
1973	if (dtype == SVt_PVGV) {
1974	SV *sref = SvREFCNT_inc(SvRV(sstr));
1975	SV *dref = 0;
1976	int intro = GvINTRO(dstr);
1977
1978	if (intro) {
1979	GP *gp;
1980	GvGP(dstr)->gp_refcnt--;
1981	GvINTRO_off(dstr); /* one-shot flag */
1982	Newz(602,gp, 1, GP);
1983	GvGP(dstr) = gp_ref(gp);
1984	GvSV(dstr) = NEWSV(72,0);
1985	GvLINE(dstr) = curcop->cop_line;
1986	GvEGV(dstr) = (GV*)dstr;
1987	}
1988	GvMULTI_on(dstr);
1989	switch (SvTYPE(sref)) {
1990	case SVt_PVAV:
1991	if (intro)
1992	SAVESPTR(GvAV(dstr));
1993	else
1994	dref = (SV*)GvAV(dstr);
1995	GvAV(dstr) = (AV*)sref;
1996	if (curcop->cop_stash != GvSTASH(dstr))
1997	GvIMPORTED_AV_on(dstr);
1998	break;
1999	case SVt_PVHV:
2000	if (intro)
2001	SAVESPTR(GvHV(dstr));
2002	else
2003	dref = (SV*)GvHV(dstr);
2004	GvHV(dstr) = (HV*)sref;
2005	if (curcop->cop_stash != GvSTASH(dstr))
2006	GvIMPORTED_HV_on(dstr);
2007	break;
2008	case SVt_PVCV:
2009	if (intro) {
2010	if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2011	SvREFCNT_dec(GvCV(dstr));
2012	GvCV(dstr) = Nullcv;
2013	GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2014	sub_generation++;
2015	}
2016	SAVESPTR(GvCV(dstr));
2017	}
2018	else
2019	dref = (SV*)GvCV(dstr);
2020	if (GvCV(dstr) != (CV*)sref) {
2021	CV* cv = GvCV(dstr);
2022	if (cv) {
2023	if (!GvCVGEN((GV*)dstr) &&
2024	(CvROOT(cv) \|\| CvXSUB(cv)))
2025	{
2026	/* ahem, death to those who redefine
2027	* active sort subs */
2028	if (curstack == sortstack &&
2029	sortcop == CvSTART(cv))
2030	croak(
2031	"Can't redefine active sort subroutine %s",
2032	GvENAME((GV*)dstr));
2033	if (cv_const_sv(cv))
2034	warn("Constant subroutine %s redefined",
2035	GvENAME((GV*)dstr));
2036	else if (dowarn)
2037	warn("Subroutine %s redefined",
2038	GvENAME((GV*)dstr));
2039	}
2040	cv_ckproto(cv, (GV*)dstr,
2041	SvPOK(sref) ? SvPVX(sref) : Nullch);
2042	}
2043	GvCV(dstr) = (CV*)sref;
2044	GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2045	GvASSUMECV_on(dstr);
2046	sub_generation++;
2047	}
2048	if (curcop->cop_stash != GvSTASH(dstr))
2049	GvIMPORTED_CV_on(dstr);
2050	break;
2051	case SVt_PVIO:
2052	if (intro)
2053	SAVESPTR(GvIOp(dstr));
2054	else
2055	dref = (SV*)GvIOp(dstr);
2056	GvIOp(dstr) = (IO*)sref;
2057	break;
2058	default:
2059	if (intro)
2060	SAVESPTR(GvSV(dstr));
2061	else
2062	dref = (SV*)GvSV(dstr);
2063	GvSV(dstr) = sref;
2064	if (curcop->cop_stash != GvSTASH(dstr))
2065	GvIMPORTED_SV_on(dstr);
2066	break;
2067	}
2068	if (dref)
2069	SvREFCNT_dec(dref);
2070	if (intro)
2071	SAVEFREESV(sref);
2072	SvTAINT(dstr);
2073	return;
2074	}
2075	if (SvPVX(dstr)) {
2076	(void)SvOOK_off(dstr); /* backoff */
2077	Safefree(SvPVX(dstr));
2078	SvLEN(dstr)=SvCUR(dstr)=0;
2079	}
2080	}
2081	(void)SvOK_off(dstr);
2082	SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2083	SvROK_on(dstr);
2084	if (sflags & SVp_NOK) {
2085	SvNOK_on(dstr);
2086	SvNVX(dstr) = SvNVX(sstr);
2087	}
2088	if (sflags & SVp_IOK) {
2089	(void)SvIOK_on(dstr);
2090	SvIVX(dstr) = SvIVX(sstr);
2091	}
2092	#ifdef OVERLOAD
2093	if (SvAMAGIC(sstr)) {
2094	SvAMAGIC_on(dstr);
2095	}
2096	#endif /* OVERLOAD */
2097	}
2098	else if (sflags & SVp_POK) {
2099
2100	/*
2101	* Check to see if we can just swipe the string. If so, it's a
2102	* possible small lose on short strings, but a big win on long ones.
2103	* It might even be a win on short strings if SvPVX(dstr)
2104	* has to be allocated and SvPVX(sstr) has to be freed.
2105	*/
2106
2107	if (SvTEMP(sstr) && /* slated for free anyway? */
2108	!(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2109	{
2110	if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2111	if (SvOOK(dstr)) {
2112	SvFLAGS(dstr) &= ~SVf_OOK;
2113	Safefree(SvPVX(dstr) - SvIVX(dstr));
2114	}
2115	else
2116	Safefree(SvPVX(dstr));
2117	}
2118	(void)SvPOK_only(dstr);
2119	SvPV_set(dstr, SvPVX(sstr));
2120	SvLEN_set(dstr, SvLEN(sstr));
2121	SvCUR_set(dstr, SvCUR(sstr));
2122	SvTEMP_off(dstr);
2123	(void)SvOK_off(sstr);
2124	SvPV_set(sstr, Nullch);
2125	SvLEN_set(sstr, 0);
2126	SvCUR_set(sstr, 0);
2127	SvTEMP_off(sstr);
2128	}
2129	else { /* have to copy actual string */
2130	STRLEN len = SvCUR(sstr);
2131
2132	SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2133	Move(SvPVX(sstr),SvPVX(dstr),len,char);
2134	SvCUR_set(dstr, len);
2135	*SvEND(dstr) = '\0';
2136	(void)SvPOK_only(dstr);
2137	}
2138	/SUPPRESS 560/
2139	if (sflags & SVp_NOK) {
2140	SvNOK_on(dstr);
2141	SvNVX(dstr) = SvNVX(sstr);
2142	}
2143	if (sflags & SVp_IOK) {
2144	(void)SvIOK_on(dstr);
2145	SvIVX(dstr) = SvIVX(sstr);
2146	}
2147	}
2148	else if (sflags & SVp_NOK) {
2149	SvNVX(dstr) = SvNVX(sstr);
2150	(void)SvNOK_only(dstr);
2151	if (SvIOK(sstr)) {
2152	(void)SvIOK_on(dstr);
2153	SvIVX(dstr) = SvIVX(sstr);
2154	}
2155	}
2156	else if (sflags & SVp_IOK) {
2157	(void)SvIOK_only(dstr);
2158	SvIVX(dstr) = SvIVX(sstr);
2159	}
2160	else {
2161	(void)SvOK_off(dstr);
2162	}
2163	SvTAINT(dstr);
2164	}
2165
2166	void
2167	sv_setpvn(sv,ptr,len)
2168	register SV *sv;
2169	register const char *ptr;
2170	register STRLEN len;
2171	{
2172	assert(len >= 0); /* STRLEN is probably unsigned, so this may
2173	elicit a warning, but it won't hurt. */
2174	if (SvTHINKFIRST(sv)) {
2175	if (SvREADONLY(sv) && curcop != &compiling)
2176	croak(no_modify);
2177	if (SvROK(sv))
2178	sv_unref(sv);
2179	}
2180	if (!ptr) {
2181	(void)SvOK_off(sv);
2182	return;
2183	}
2184	if (SvTYPE(sv) >= SVt_PV) {
2185	if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2186	sv_unglob(sv);
2187	}
2188	else if (!sv_upgrade(sv, SVt_PV))
2189	return;
2190	SvGROW(sv, len + 1);
2191	Move(ptr,SvPVX(sv),len,char);
2192	SvCUR_set(sv, len);
2193	*SvEND(sv) = '\0';
2194	(void)SvPOK_only(sv); /* validate pointer */
2195	SvTAINT(sv);
2196	}
2197
2198	void
2199	sv_setpv(sv,ptr)
2200	register SV *sv;
2201	register const char *ptr;
2202	{
2203	register STRLEN len;
2204
2205	if (SvTHINKFIRST(sv)) {
2206	if (SvREADONLY(sv) && curcop != &compiling)
2207	croak(no_modify);
2208	if (SvROK(sv))
2209	sv_unref(sv);
2210	}
2211	if (!ptr) {
2212	(void)SvOK_off(sv);
2213	return;
2214	}
2215	len = strlen(ptr);
2216	if (SvTYPE(sv) >= SVt_PV) {
2217	if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2218	sv_unglob(sv);
2219	}
2220	else if (!sv_upgrade(sv, SVt_PV))
2221	return;
2222	SvGROW(sv, len + 1);
2223	Move(ptr,SvPVX(sv),len+1,char);
2224	SvCUR_set(sv, len);
2225	(void)SvPOK_only(sv); /* validate pointer */
2226	SvTAINT(sv);
2227	}
2228
2229	void
2230	sv_usepvn(sv,ptr,len)
2231	register SV *sv;
2232	register char *ptr;
2233	register STRLEN len;
2234	{
2235	if (SvTHINKFIRST(sv)) {
2236	if (SvREADONLY(sv) && curcop != &compiling)
2237	croak(no_modify);
2238	if (SvROK(sv))
2239	sv_unref(sv);
2240	}
2241	if (!SvUPGRADE(sv, SVt_PV))
2242	return;
2243	if (!ptr) {
2244	(void)SvOK_off(sv);
2245	return;
2246	}
2247	if (SvPVX(sv))
2248	Safefree(SvPVX(sv));
2249	Renew(ptr, len+1, char);
2250	SvPVX(sv) = ptr;
2251	SvCUR_set(sv, len);
2252	SvLEN_set(sv, len+1);
2253	*SvEND(sv) = '\0';
2254	(void)SvPOK_only(sv); /* validate pointer */
2255	SvTAINT(sv);
2256	}
2257
2258	void
2259	sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
2260	register SV *sv;
2261	register char *ptr;
2262	{
2263	register STRLEN delta;
2264
2265	if (!ptr \|\| !SvPOKp(sv))
2266	return;
2267	if (SvTHINKFIRST(sv)) {
2268	if (SvREADONLY(sv) && curcop != &compiling)
2269	croak(no_modify);
2270	if (SvROK(sv))
2271	sv_unref(sv);
2272	}
2273	if (SvTYPE(sv) < SVt_PVIV)
2274	sv_upgrade(sv,SVt_PVIV);
2275
2276	if (!SvOOK(sv)) {
2277	SvIVX(sv) = 0;
2278	SvFLAGS(sv) \|= SVf_OOK;
2279	}
2280	SvFLAGS(sv) &= ~(SVf_IOK\|SVf_NOK\|SVp_IOK\|SVp_NOK);
2281	delta = ptr - SvPVX(sv);
2282	SvLEN(sv) -= delta;
2283	SvCUR(sv) -= delta;
2284	SvPVX(sv) += delta;
2285	SvIVX(sv) += delta;
2286	}
2287
2288	void
2289	sv_catpvn(sv,ptr,len)
2290	register SV *sv;
2291	register char *ptr;
2292	register STRLEN len;
2293	{
2294	STRLEN tlen;
2295	char *junk;
2296
2297	junk = SvPV_force(sv, tlen);
2298	SvGROW(sv, tlen + len + 1);
2299	if (ptr == junk)
2300	ptr = SvPVX(sv);
2301	Move(ptr,SvPVX(sv)+tlen,len,char);
2302	SvCUR(sv) += len;
2303	*SvEND(sv) = '\0';
2304	(void)SvPOK_only(sv); /* validate pointer */
2305	SvTAINT(sv);
2306	}
2307
2308	void
2309	sv_catsv(dstr,sstr)
2310	SV *dstr;
2311	register SV *sstr;
2312	{
2313	char *s;
2314	STRLEN len;
2315	if (!sstr)
2316	return;
2317	if (s = SvPV(sstr, len))
2318	sv_catpvn(dstr,s,len);
2319	}
2320
2321	void
2322	sv_catpv(sv,ptr)
2323	register SV *sv;
2324	register char *ptr;
2325	{
2326	register STRLEN len;
2327	STRLEN tlen;
2328	char *junk;
2329
2330	if (!ptr)
2331	return;
2332	junk = SvPV_force(sv, tlen);
2333	len = strlen(ptr);
2334	SvGROW(sv, tlen + len + 1);
2335	if (ptr == junk)
2336	ptr = SvPVX(sv);
2337	Move(ptr,SvPVX(sv)+tlen,len+1,char);
2338	SvCUR(sv) += len;
2339	(void)SvPOK_only(sv); /* validate pointer */
2340	SvTAINT(sv);
2341	}
2342
2343	SV *
2344	#ifdef LEAKTEST
2345	newSV(x,len)
2346	I32 x;
2347	#else
2348	newSV(len)
2349	#endif
2350	STRLEN len;
2351	{
2352	register SV *sv;
2353
2354	new_SV(sv);
2355	SvANY(sv) = 0;
2356	SvREFCNT(sv) = 1;
2357	SvFLAGS(sv) = 0;
2358	if (len) {
2359	sv_upgrade(sv, SVt_PV);
2360	SvGROW(sv, len + 1);
2361	}
2362	return sv;
2363	}
2364
2365	/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2366
2367	void
2368	sv_magic(sv, obj, how, name, namlen)
2369	register SV *sv;
2370	SV *obj;
2371	int how;
2372	char *name;
2373	I32 namlen;
2374	{
2375	MAGIC* mg;
2376
2377	if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
2378	croak(no_modify);
2379	if (SvMAGICAL(sv) \|\| (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2380	if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2381	if (how == 't')
2382	mg->mg_len \|= 1;
2383	return;
2384	}
2385	}
2386	else {
2387	if (!SvUPGRADE(sv, SVt_PVMG))
2388	return;
2389	}
2390	Newz(702,mg, 1, MAGIC);
2391	mg->mg_moremagic = SvMAGIC(sv);
2392
2393	SvMAGIC(sv) = mg;
2394	if (!obj \|\| obj == sv \|\| how == '#')
2395	mg->mg_obj = obj;
2396	else {
2397	mg->mg_obj = SvREFCNT_inc(obj);
2398	mg->mg_flags \|= MGf_REFCOUNTED;
2399	}
2400	mg->mg_type = how;
2401	mg->mg_len = namlen;
2402	if (name)
2403	if (namlen >= 0)
2404	mg->mg_ptr = savepvn(name, namlen);
2405	else if (namlen == HEf_SVKEY)
2406	mg->mg_ptr = (char)SvREFCNT_inc((SV)name);
2407
2408	switch (how) {
2409	case 0:
2410	mg->mg_virtual = &vtbl_sv;
2411	break;
2412	#ifdef OVERLOAD
2413	case 'A':
2414	mg->mg_virtual = &vtbl_amagic;
2415	break;
2416	case 'a':
2417	mg->mg_virtual = &vtbl_amagicelem;
2418	break;
2419	case 'c':
2420	mg->mg_virtual = 0;
2421	break;
2422	#endif /* OVERLOAD */
2423	case 'B':
2424	mg->mg_virtual = &vtbl_bm;
2425	break;
2426	case 'E':
2427	mg->mg_virtual = &vtbl_env;
2428	break;
2429	case 'f':
2430	mg->mg_virtual = &vtbl_fm;
2431	break;
2432	case 'e':
2433	mg->mg_virtual = &vtbl_envelem;
2434	break;
2435	case 'g':
2436	mg->mg_virtual = &vtbl_mglob;
2437	break;
2438	case 'I':
2439	mg->mg_virtual = &vtbl_isa;
2440	break;
2441	case 'i':
2442	mg->mg_virtual = &vtbl_isaelem;
2443	break;
2444	case 'k':
2445	mg->mg_virtual = &vtbl_nkeys;
2446	break;
2447	case 'L':
2448	SvRMAGICAL_on(sv);
2449	mg->mg_virtual = 0;
2450	break;
2451	case 'l':
2452	mg->mg_virtual = &vtbl_dbline;
2453	break;
2454	#ifdef USE_LOCALE_COLLATE
2455	case 'o':
2456	mg->mg_virtual = &vtbl_collxfrm;
2457	break;
2458	#endif /* USE_LOCALE_COLLATE */
2459	case 'P':
2460	mg->mg_virtual = &vtbl_pack;
2461	break;
2462	case 'p':
2463	case 'q':
2464	mg->mg_virtual = &vtbl_packelem;
2465	break;
2466	case 'S':
2467	mg->mg_virtual = &vtbl_sig;
2468	break;
2469	case 's':
2470	mg->mg_virtual = &vtbl_sigelem;
2471	break;
2472	case 't':
2473	mg->mg_virtual = &vtbl_taint;
2474	mg->mg_len = 1;
2475	break;
2476	case 'U':
2477	mg->mg_virtual = &vtbl_uvar;
2478	break;
2479	case 'v':
2480	mg->mg_virtual = &vtbl_vec;
2481	break;
2482	case 'x':
2483	mg->mg_virtual = &vtbl_substr;
2484	break;
2485	case 'y':
2486	mg->mg_virtual = &vtbl_defelem;
2487	break;
2488	case '*':
2489	mg->mg_virtual = &vtbl_glob;
2490	break;
2491	case '#':
2492	mg->mg_virtual = &vtbl_arylen;
2493	break;
2494	case '.':
2495	mg->mg_virtual = &vtbl_pos;
2496	break;
2497	case '~': /* Reserved for use by extensions not perl internals. */
2498	/* Useful for attaching extension internal data to perl vars. */
2499	/* Note that multiple extensions may clash if magical scalars */
2500	/* etc holding private data from one are passed to another. */
2501	SvRMAGICAL_on(sv);
2502	break;
2503	default:
2504	croak("Don't know how to handle magic of type '%c'", how);
2505	}
2506	mg_magical(sv);
2507	if (SvGMAGICAL(sv))
2508	SvFLAGS(sv) &= ~(SVf_IOK\|SVf_NOK\|SVf_POK);
2509	}
2510
2511	int
2512	sv_unmagic(sv, type)
2513	SV* sv;
2514	int type;
2515	{
2516	MAGIC* mg;
2517	MAGIC** mgp;
2518	if (SvTYPE(sv) < SVt_PVMG \|\| !SvMAGIC(sv))
2519	return 0;
2520	mgp = &SvMAGIC(sv);
2521	for (mg = mgp; mg; mg = mgp) {
2522	if (mg->mg_type == type) {
2523	MGVTBL* vtbl = mg->mg_virtual;
2524	*mgp = mg->mg_moremagic;
2525	if (vtbl && vtbl->svt_free)
2526	(*vtbl->svt_free)(sv, mg);
2527	if (mg->mg_ptr && mg->mg_type != 'g')
2528	if (mg->mg_len >= 0)
2529	Safefree(mg->mg_ptr);
2530	else if (mg->mg_len == HEf_SVKEY)
2531	SvREFCNT_dec((SV*)mg->mg_ptr);
2532	if (mg->mg_flags & MGf_REFCOUNTED)
2533	SvREFCNT_dec(mg->mg_obj);
2534	Safefree(mg);
2535	}
2536	else
2537	mgp = &mg->mg_moremagic;
2538	}
2539	if (!SvMAGIC(sv)) {
2540	SvMAGICAL_off(sv);
2541	SvFLAGS(sv) \|= (SvFLAGS(sv) & (SVp_IOK\|SVp_NOK\|SVp_POK)) >> PRIVSHIFT;
2542	}
2543
2544	return 0;
2545	}
2546
2547	void
2548	sv_insert(bigstr,offset,len,little,littlelen)
2549	SV *bigstr;
2550	STRLEN offset;
2551	STRLEN len;
2552	char *little;
2553	STRLEN littlelen;
2554	{
2555	register char *big;
2556	register char *mid;
2557	register char *midend;
2558	register char *bigend;
2559	register I32 i;
2560
2561	if (!bigstr)
2562	croak("Can't modify non-existent substring");
2563	SvPV_force(bigstr, na);
2564
2565	i = littlelen - len;
2566	if (i > 0) { /* string might grow */
2567	big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2568	mid = big + offset + len;
2569	midend = bigend = big + SvCUR(bigstr);
2570	bigend += i;
2571	*bigend = '\0';
2572	while (midend > mid) /* shove everything down */
2573	--bigend = --midend;
2574	Move(little,big+offset,littlelen,char);
2575	SvCUR(bigstr) += i;
2576	SvSETMAGIC(bigstr);
2577	return;
2578	}
2579	else if (i == 0) {
2580	Move(little,SvPVX(bigstr)+offset,len,char);
2581	SvSETMAGIC(bigstr);
2582	return;
2583	}
2584
2585	big = SvPVX(bigstr);
2586	mid = big + offset;
2587	midend = mid + len;
2588	bigend = big + SvCUR(bigstr);
2589
2590	if (midend > bigend)
2591	croak("panic: sv_insert");
2592
2593	if (mid - big > bigend - midend) { /* faster to shorten from end */
2594	if (littlelen) {
2595	Move(little, mid, littlelen,char);
2596	mid += littlelen;
2597	}
2598	i = bigend - midend;
2599	if (i > 0) {
2600	Move(midend, mid, i,char);
2601	mid += i;
2602	}
2603	*mid = '\0';
2604	SvCUR_set(bigstr, mid - big);
2605	}
2606	/SUPPRESS 560/
2607	else if (i = mid - big) { /* faster from front */
2608	midend -= littlelen;
2609	mid = midend;
2610	sv_chop(bigstr,midend-i);
2611	big += i;
2612	while (i--)
2613	--midend = --big;
2614	if (littlelen)
2615	Move(little, mid, littlelen,char);
2616	}
2617	else if (littlelen) {
2618	midend -= littlelen;
2619	sv_chop(bigstr,midend);
2620	Move(little,midend,littlelen,char);
2621	}
2622	else {
2623	sv_chop(bigstr,midend);
2624	}
2625	SvSETMAGIC(bigstr);
2626	}
2627
2628	/* make sv point to what nstr did */
2629
2630	void
2631	sv_replace(sv,nsv)
2632	register SV *sv;
2633	register SV *nsv;
2634	{
2635	U32 refcnt = SvREFCNT(sv);
2636	if (SvTHINKFIRST(sv)) {
2637	if (SvREADONLY(sv) && curcop != &compiling)
2638	croak(no_modify);
2639	if (SvROK(sv))
2640	sv_unref(sv);
2641	}
2642	if (SvREFCNT(nsv) != 1)
2643	warn("Reference miscount in sv_replace()");
2644	if (SvMAGICAL(sv)) {
2645	if (SvMAGICAL(nsv))
2646	mg_free(nsv);
2647	else
2648	sv_upgrade(nsv, SVt_PVMG);
2649	SvMAGIC(nsv) = SvMAGIC(sv);
2650	SvFLAGS(nsv) \|= SvMAGICAL(sv);
2651	SvMAGICAL_off(sv);
2652	SvMAGIC(sv) = 0;
2653	}
2654	SvREFCNT(sv) = 0;
2655	sv_clear(sv);
2656	assert(!SvREFCNT(sv));
2657	StructCopy(nsv,sv,SV);
2658	SvREFCNT(sv) = refcnt;
2659	SvFLAGS(nsv) \|= SVTYPEMASK; /* Mark as freed */
2660	del_SV(nsv);
2661	}
2662
2663	void
2664	sv_clear(sv)
2665	register SV *sv;
2666	{
2667	assert(sv);
2668	assert(SvREFCNT(sv) == 0);
2669
2670	if (SvOBJECT(sv)) {
2671	if (defstash) { /* Still have a symbol table? */
2672	dSP;
2673	GV* destructor;
2674
2675	ENTER;
2676	SAVEFREESV(SvSTASH(sv));
2677
2678	destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2679	if (destructor) {
2680	SV ref;
2681
2682	Zero(&ref, 1, SV);
2683	sv_upgrade(&ref, SVt_RV);
2684	SvRV(&ref) = SvREFCNT_inc(sv);
2685	SvROK_on(&ref);
2686	SvREFCNT(&ref) = 1; /* Fake, but otherwise
2687	creating+destructing a ref
2688	leads to disaster. */
2689
2690	EXTEND(SP, 2);
2691	PUSHMARK(SP);
2692	PUSHs(&ref);
2693	PUTBACK;
2694	perl_call_sv((SV*)GvCV(destructor),
2695	G_DISCARD\|G_EVAL\|G_KEEPERR);
2696	del_XRV(SvANY(&ref));
2697	SvREFCNT(sv)--;
2698	}
2699
2700	LEAVE;
2701	}
2702	else
2703	SvREFCNT_dec(SvSTASH(sv));
2704	if (SvOBJECT(sv)) {
2705	SvOBJECT_off(sv); /* Curse the object. */
2706	if (SvTYPE(sv) != SVt_PVIO)
2707	--sv_objcount; /* XXX Might want something more general */
2708	}
2709	if (SvREFCNT(sv)) {
2710	if (in_clean_objs)
2711	croak("DESTROY created new reference to dead object");
2712	/* DESTROY gave object new lease on life */
2713	return;
2714	}
2715	}
2716	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2717	mg_free(sv);
2718	switch (SvTYPE(sv)) {
2719	case SVt_PVIO:
2720	if (IoIFP(sv) != PerlIO_stdin() &&
2721	IoIFP(sv) != PerlIO_stdout() &&
2722	IoIFP(sv) != PerlIO_stderr())
2723	io_close((IO*)sv);
2724	Safefree(IoTOP_NAME(sv));
2725	Safefree(IoFMT_NAME(sv));
2726	Safefree(IoBOTTOM_NAME(sv));
2727	/* FALL THROUGH */
2728	case SVt_PVBM:
2729	goto freescalar;
2730	case SVt_PVCV:
2731	case SVt_PVFM:
2732	cv_undef((CV*)sv);
2733	goto freescalar;
2734	case SVt_PVHV:
2735	hv_undef((HV*)sv);
2736	break;
2737	case SVt_PVAV:
2738	av_undef((AV*)sv);
2739	break;
2740	case SVt_PVGV:
2741	gp_free((GV*)sv);
2742	Safefree(GvNAME(sv));
2743	/* FALL THROUGH */
2744	case SVt_PVLV:
2745	case SVt_PVMG:
2746	case SVt_PVNV:
2747	case SVt_PVIV:
2748	freescalar:
2749	(void)SvOOK_off(sv);
2750	/* FALL THROUGH */
2751	case SVt_PV:
2752	case SVt_RV:
2753	if (SvROK(sv))
2754	SvREFCNT_dec(SvRV(sv));
2755	else if (SvPVX(sv) && SvLEN(sv))
2756	Safefree(SvPVX(sv));
2757	break;
2758	/*
2759	case SVt_NV:
2760	case SVt_IV:
2761	case SVt_NULL:
2762	break;
2763	*/
2764	}
2765
2766	switch (SvTYPE(sv)) {
2767	case SVt_NULL:
2768	break;
2769	case SVt_IV:
2770	del_XIV(SvANY(sv));
2771	break;
2772	case SVt_NV:
2773	del_XNV(SvANY(sv));
2774	break;
2775	case SVt_RV:
2776	del_XRV(SvANY(sv));
2777	break;
2778	case SVt_PV:
2779	del_XPV(SvANY(sv));
2780	break;
2781	case SVt_PVIV:
2782	del_XPVIV(SvANY(sv));
2783	break;
2784	case SVt_PVNV:
2785	del_XPVNV(SvANY(sv));
2786	break;
2787	case SVt_PVMG:
2788	del_XPVMG(SvANY(sv));
2789	break;
2790	case SVt_PVLV:
2791	del_XPVLV(SvANY(sv));
2792	break;
2793	case SVt_PVAV:
2794	del_XPVAV(SvANY(sv));
2795	break;
2796	case SVt_PVHV:
2797	del_XPVHV(SvANY(sv));
2798	break;
2799	case SVt_PVCV:
2800	del_XPVCV(SvANY(sv));
2801	break;
2802	case SVt_PVGV:
2803	del_XPVGV(SvANY(sv));
2804	break;
2805	case SVt_PVBM:
2806	del_XPVBM(SvANY(sv));
2807	break;
2808	case SVt_PVFM:
2809	del_XPVFM(SvANY(sv));
2810	break;
2811	case SVt_PVIO:
2812	del_XPVIO(SvANY(sv));
2813	break;
2814	}
2815	SvFLAGS(sv) &= SVf_BREAK;
2816	SvFLAGS(sv) \|= SVTYPEMASK;
2817	}
2818
2819	SV *
2820	sv_newref(sv)
2821	SV* sv;
2822	{
2823	if (sv)
2824	SvREFCNT(sv)++;
2825	return sv;
2826	}
2827
2828	void
2829	sv_free(sv)
2830	SV *sv;
2831	{
2832	if (!sv)
2833	return;
2834	if (SvREADONLY(sv)) {
2835	if (sv == &sv_undef \|\| sv == &sv_yes \|\| sv == &sv_no)
2836	return;
2837	}
2838	if (SvREFCNT(sv) == 0) {
2839	if (SvFLAGS(sv) & SVf_BREAK)
2840	return;
2841	if (in_clean_all) /* All is fair */
2842	return;
2843	warn("Attempt to free unreferenced scalar");
2844	return;
2845	}
2846	if (--SvREFCNT(sv) > 0)
2847	return;
2848	#ifdef DEBUGGING
2849	if (SvTEMP(sv)) {
2850	warn("Attempt to free temp prematurely");
2851	return;
2852	}
2853	#endif
2854	sv_clear(sv);
2855	if (! SvREFCNT(sv))
2856	del_SV(sv);
2857	}
2858
2859	STRLEN
2860	sv_len(sv)
2861	register SV *sv;
2862	{
2863	char *junk;
2864	STRLEN len;
2865
2866	if (!sv)
2867	return 0;
2868
2869	if (SvGMAGICAL(sv))
2870	len = mg_len(sv);
2871	else
2872	junk = SvPV(sv, len);
2873	return len;
2874	}
2875
2876	I32
2877	sv_eq(str1,str2)
2878	register SV *str1;
2879	register SV *str2;
2880	{
2881	char *pv1;
2882	STRLEN cur1;
2883	char *pv2;
2884	STRLEN cur2;
2885
2886	if (!str1) {
2887	pv1 = "";
2888	cur1 = 0;
2889	}
2890	else
2891	pv1 = SvPV(str1, cur1);
2892
2893	if (!str2)
2894	return !cur1;
2895	else
2896	pv2 = SvPV(str2, cur2);
2897
2898	if (cur1 != cur2)
2899	return 0;
2900
2901	return memEQ(pv1, pv2, cur1);
2902	}
2903
2904	I32
2905	sv_cmp(str1, str2)
2906	register SV *str1;
2907	register SV *str2;
2908	{
2909	STRLEN cur1 = 0;
2910	char *pv1 = str1 ? SvPV(str1, cur1) : NULL;
2911	STRLEN cur2 = 0;
2912	char *pv2 = str2 ? SvPV(str2, cur2) : NULL;
2913	I32 retval;
2914
2915	if (!cur1)
2916	return cur2 ? -1 : 0;
2917
2918	if (!cur2)
2919	return 1;
2920
2921	retval = memcmp((void)pv1, (void)pv2, cur1 < cur2 ? cur1 : cur2);
2922
2923	if (retval)
2924	return retval < 0 ? -1 : 1;
2925
2926	if (cur1 == cur2)
2927	return 0;
2928	else
2929	return cur1 < cur2 ? -1 : 1;
2930	}
2931
2932	I32
2933	sv_cmp_locale(sv1, sv2)
2934	register SV *sv1;
2935	register SV *sv2;
2936	{
2937	#ifdef USE_LOCALE_COLLATE
2938
2939	char pv1, pv2;
2940	STRLEN len1, len2;
2941	I32 retval;
2942
2943	if (collation_standard)
2944	goto raw_compare;
2945
2946	len1 = 0;
2947	pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL;
2948	len2 = 0;
2949	pv2 = sv2 ? sv_collxfrm(sv2, &len2) : NULL;
2950
2951	if (!pv1 \|\| !len1) {
2952	if (pv2 && len2)
2953	return -1;
2954	else
2955	goto raw_compare;
2956	}
2957	else {
2958	if (!pv2 \|\| !len2)
2959	return 1;
2960	}
2961
2962	retval = memcmp((void)pv1, (void)pv2, len1 < len2 ? len1 : len2);
2963
2964	if (retval)
2965	return retval < 0 ? -1 : 1;
2966
2967	/*
2968	* When the result of collation is equality, that doesn't mean
2969	* that there are no differences -- some locales exclude some
2970	* characters from consideration. So to avoid false equalities,
2971	* we use the raw string as a tiebreaker.
2972	*/
2973
2974	raw_compare:
2975	/* FALL THROUGH */
2976
2977	#endif /* USE_LOCALE_COLLATE */
2978
2979	return sv_cmp(sv1, sv2);
2980	}
2981
2982	#ifdef USE_LOCALE_COLLATE
2983	/*
2984	* Any scalar variable may carry an 'o' magic that contains the
2985	* scalar data of the variable transformed to such a format that
2986	* a normal memory comparison can be used to compare the data
2987	* according to the locale settings.
2988	*/
2989	char *
2990	sv_collxfrm(sv, nxp)
2991	SV *sv;
2992	STRLEN *nxp;
2993	{
2994	MAGIC *mg;
2995
2996	mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
2997	if (!mg \|\| !mg->mg_ptr \|\| (U32)mg->mg_ptr != collation_ix) {
2998	char s, xf;
2999	STRLEN len, xlen;
3000
3001	if (mg)
3002	Safefree(mg->mg_ptr);
3003	s = SvPV(sv, len);
3004	if ((xf = mem_collxfrm(s, len, &xlen))) {
3005	if (SvREADONLY(sv)) {
3006	SAVEFREEPV(xf);
3007	*nxp = xlen;
3008	return xf + sizeof(collation_ix);
3009	}
3010	if (! mg) {
3011	sv_magic(sv, 0, 'o', 0, 0);
3012	mg = mg_find(sv, 'o');
3013	assert(mg);
3014	}
3015	mg->mg_ptr = xf;
3016	mg->mg_len = xlen;
3017	}
3018	else {
3019	if (mg) {
3020	mg->mg_ptr = NULL;
3021	mg->mg_len = -1;
3022	}
3023	}
3024	}
3025	if (mg && mg->mg_ptr) {
3026	*nxp = mg->mg_len;
3027	return mg->mg_ptr + sizeof(collation_ix);
3028	}
3029	else {
3030	*nxp = 0;
3031	return NULL;
3032	}
3033	}
3034
3035	#endif /* USE_LOCALE_COLLATE */
3036
3037	char *
3038	sv_gets(sv,fp,append)
3039	register SV *sv;
3040	register PerlIO *fp;
3041	I32 append;
3042	{
3043	char *rsptr;
3044	STRLEN rslen;
3045	register STDCHAR rslast;
3046	register STDCHAR *bp;
3047	register I32 cnt;
3048	I32 i;
3049
3050	if (SvTHINKFIRST(sv)) {
3051	if (SvREADONLY(sv) && curcop != &compiling)
3052	croak(no_modify);
3053	if (SvROK(sv))
3054	sv_unref(sv);
3055	}
3056	if (!SvUPGRADE(sv, SVt_PV))
3057	return 0;
3058	SvSCREAM_off(sv);
3059
3060	if (RsSNARF(rs)) {
3061	rsptr = NULL;
3062	rslen = 0;
3063	}
3064	else if (RsPARA(rs)) {
3065	rsptr = "\n\n";
3066	rslen = 2;
3067	}
3068	else
3069	rsptr = SvPV(rs, rslen);
3070	rslast = rslen ? rsptr[rslen - 1] : '\0';
3071
3072	if (RsPARA(rs)) { /* have to do this both before and after */
3073	do { /* to make sure file boundaries work right */
3074	if (PerlIO_eof(fp))
3075	return 0;
3076	i = PerlIO_getc(fp);
3077	if (i != '\n') {
3078	if (i == -1)
3079	return 0;
3080	PerlIO_ungetc(fp,i);
3081	break;
3082	}
3083	} while (i != EOF);
3084	}
3085
3086	/* See if we know enough about I/O mechanism to cheat it ! */
3087
3088	/* This used to be #ifdef test - it is made run-time test for ease
3089	of abstracting out stdio interface. One call should be cheap
3090	enough here - and may even be a macro allowing compile
3091	time optimization.
3092	*/
3093
3094	if (PerlIO_fast_gets(fp)) {
3095
3096	/*
3097	* We're going to steal some values from the stdio struct
3098	* and put EVERYTHING in the innermost loop into registers.
3099	*/
3100	register STDCHAR *ptr;
3101	STRLEN bpx;
3102	I32 shortbuffered;
3103
3104	#if defined(VMS) && defined(PERLIO_IS_STDIO)
3105	/* An ungetc()d char is handled separately from the regular
3106	* buffer, so we getc() it back out and stuff it in the buffer.
3107	*/
3108	i = PerlIO_getc(fp);
3109	if (i == EOF) return 0;
3110	(--((fp)->_ptr)) = (unsigned char) i;
3111	(*fp)->_cnt++;
3112	#endif
3113
3114	/* Here is some breathtakingly efficient cheating */
3115
3116	cnt = PerlIO_get_cnt(fp); /* get count into register */
3117	(void)SvPOK_only(sv); /* validate pointer */
3118	if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3119	if (cnt > 80 && SvLEN(sv) > append) {
3120	shortbuffered = cnt - SvLEN(sv) + append + 1;
3121	cnt -= shortbuffered;
3122	}
3123	else {
3124	shortbuffered = 0;
3125	/* remember that cnt can be negative */
3126	SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3127	}
3128	}
3129	else
3130	shortbuffered = 0;
3131	bp = (STDCHAR)SvPVX(sv) + append; / move these two too to registers */
3132	ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3133	DEBUG_P(PerlIO_printf(Perl_debug_log,
3134	"Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3135	DEBUG_P(PerlIO_printf(Perl_debug_log,
3136	"Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3137	(long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3138	(long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3139	for (;;) {
3140	screamer:
3141	if (cnt > 0) {
3142	if (rslen) {
3143	while (cnt > 0) { /* this \| eat */
3144	cnt--;
3145	if ((bp++ = ptr++) == rslast) /* really \| dust */
3146	goto thats_all_folks; /* screams \| sed :-) */
3147	}
3148	}
3149	else {
3150	Copy(ptr, bp, cnt, char); /* this \| eat */
3151	bp += cnt; /* screams \| dust */
3152	ptr += cnt; /* louder \| sed :-) */
3153	cnt = 0;
3154	}
3155	}
3156
3157	if (shortbuffered) { /* oh well, must extend */
3158	cnt = shortbuffered;
3159	shortbuffered = 0;
3160	bpx = bp - (STDCHAR)SvPVX(sv); / box up before relocation */
3161	SvCUR_set(sv, bpx);
3162	SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3163	bp = (STDCHAR)SvPVX(sv) + bpx; / unbox after relocation */
3164	continue;
3165	}
3166
3167	DEBUG_P(PerlIO_printf(Perl_debug_log,
3168	"Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3169	PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3170	DEBUG_P(PerlIO_printf(Perl_debug_log,
3171	"Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3172	(long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3173	(long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3174	/* This used to call 'filbuf' in stdio form, but as that behaves like
3175	getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3176	another abstraction. */
3177	i = PerlIO_getc(fp); /* get more characters */
3178	DEBUG_P(PerlIO_printf(Perl_debug_log,
3179	"Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3180	(long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3181	(long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3182	cnt = PerlIO_get_cnt(fp);
3183	ptr = (STDCHAR)PerlIO_get_ptr(fp); / reregisterize cnt and ptr */
3184	DEBUG_P(PerlIO_printf(Perl_debug_log,
3185	"Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3186
3187	if (i == EOF) /* all done for ever? */
3188	goto thats_really_all_folks;
3189
3190	bpx = bp - (STDCHAR)SvPVX(sv); / box up before relocation */
3191	SvCUR_set(sv, bpx);
3192	SvGROW(sv, bpx + cnt + 2);
3193	bp = (STDCHAR)SvPVX(sv) + bpx; / unbox after relocation */
3194
3195	bp++ = i; / store character from PerlIO_getc */
3196
3197	if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3198	goto thats_all_folks;
3199	}
3200
3201	thats_all_folks:
3202	if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) \|\|
3203	memNE((char*)bp - rslen, rsptr, rslen))
3204	goto screamer; /* go back to the fray */
3205	thats_really_all_folks:
3206	if (shortbuffered)
3207	cnt += shortbuffered;
3208	DEBUG_P(PerlIO_printf(Perl_debug_log,
3209	"Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3210	PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3211	DEBUG_P(PerlIO_printf(Perl_debug_log,
3212	"Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3213	(long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3214	(long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3215	*bp = '\0';
3216	SvCUR_set(sv, bp - (STDCHAR)SvPVX(sv)); / set length */
3217	DEBUG_P(PerlIO_printf(Perl_debug_log,
3218	"Screamer: done, len=%ld, string=\|%.*s\|\n",
3219	(long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3220	}
3221	else
3222	{
3223	/The big, slow, and stupid way /
3224	STDCHAR buf[8192];
3225
3226	screamer2:
3227	if (rslen) {
3228	register STDCHAR *bpe = buf + sizeof(buf);
3229	bp = buf;
3230	while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3231	; /* keep reading */
3232	cnt = bp - buf;
3233	}
3234	else {
3235	cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3236	/* Accomodate broken VAXC compiler, which applies U8 cast to
3237	* both args of ?: operator, causing EOF to change into 255
3238	*/
3239	if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3240	}
3241
3242	if (append)
3243	sv_catpvn(sv, (char *) buf, cnt);
3244	else
3245	sv_setpvn(sv, (char *) buf, cnt);
3246
3247	if (i != EOF && /* joy */
3248	(!rslen \|\|
3249	SvCUR(sv) < rslen \|\|
3250	memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3251	{
3252	append = -1;
3253	/*
3254	* If we're reading from a TTY and we get a short read,
3255	* indicating that the user hit his EOF character, we need
3256	* to notice it now, because if we try to read from the TTY
3257	* again, the EOF condition will disappear.
3258	*
3259	* The comparison of cnt to sizeof(buf) is an optimization
3260	* that prevents unnecessary calls to feof().
3261	*
3262	* - jik 9/25/96
3263	*/
3264	if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3265	goto screamer2;
3266	}
3267	}
3268
3269	if (RsPARA(rs)) { /* have to do this both before and after */
3270	while (i != EOF) { /* to make sure file boundaries work right */
3271	i = PerlIO_getc(fp);
3272	if (i != '\n') {
3273	PerlIO_ungetc(fp,i);
3274	break;
3275	}
3276	}
3277	}
3278
3279	return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3280	}
3281
3282
3283	void
3284	sv_inc(sv)
3285	register SV *sv;
3286	{
3287	register char *d;
3288	int flags;
3289
3290	if (!sv)
3291	return;
3292	if (SvTHINKFIRST(sv)) {
3293	if (SvREADONLY(sv) && curcop != &compiling)
3294	croak(no_modify);
3295	if (SvROK(sv)) {
3296	#ifdef OVERLOAD
3297	if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
3298	#endif /* OVERLOAD */
3299	sv_unref(sv);
3300	}
3301	}
3302	if (SvGMAGICAL(sv))
3303	mg_get(sv);
3304	flags = SvFLAGS(sv);
3305	if (flags & SVp_NOK) {
3306	(void)SvNOK_only(sv);
3307	SvNVX(sv) += 1.0;
3308	return;
3309	}
3310	if (flags & SVp_IOK) {
3311	if (SvIVX(sv) == IV_MAX)
3312	sv_setnv(sv, (double)IV_MAX + 1.0);
3313	else {
3314	(void)SvIOK_only(sv);
3315	++SvIVX(sv);
3316	}
3317	return;
3318	}
3319	if (!(flags & SVp_POK) \|\| !*SvPVX(sv)) {
3320	if ((flags & SVTYPEMASK) < SVt_PVNV)
3321	sv_upgrade(sv, SVt_NV);
3322	SvNVX(sv) = 1.0;
3323	(void)SvNOK_only(sv);
3324	return;
3325	}
3326	d = SvPVX(sv);
3327	while (isALPHA(*d)) d++;
3328	while (isDIGIT(*d)) d++;
3329	if (*d) {
3330	SET_NUMERIC_STANDARD();
3331	sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
3332	return;
3333	}
3334	d--;
3335	while (d >= SvPVX(sv)) {
3336	if (isDIGIT(*d)) {
3337	if (++*d <= '9')
3338	return;
3339	*(d--) = '0';
3340	}
3341	else {
3342	++*d;
3343	if (isALPHA(*d))
3344	return;
3345	*(d--) -= 'z' - 'a' + 1;
3346	}
3347	}
3348	/* oh,oh, the number grew */
3349	SvGROW(sv, SvCUR(sv) + 2);
3350	SvCUR(sv)++;
3351	for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3352	*d = d[-1];
3353	if (isDIGIT(d[1]))
3354	*d = '1';
3355	else
3356	*d = d[1];
3357	}
3358
3359	void
3360	sv_dec(sv)
3361	register SV *sv;
3362	{
3363	int flags;
3364
3365	if (!sv)
3366	return;
3367	if (SvTHINKFIRST(sv)) {
3368	if (SvREADONLY(sv) && curcop != &compiling)
3369	croak(no_modify);
3370	if (SvROK(sv)) {
3371	#ifdef OVERLOAD
3372	if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
3373	#endif /* OVERLOAD */
3374	sv_unref(sv);
3375	}
3376	}
3377	if (SvGMAGICAL(sv))
3378	mg_get(sv);
3379	flags = SvFLAGS(sv);
3380	if (flags & SVp_NOK) {
3381	SvNVX(sv) -= 1.0;
3382	(void)SvNOK_only(sv);
3383	return;
3384	}
3385	if (flags & SVp_IOK) {
3386	if (SvIVX(sv) == IV_MIN)
3387	sv_setnv(sv, (double)IV_MIN - 1.0);
3388	else {
3389	(void)SvIOK_only(sv);
3390	--SvIVX(sv);
3391	}
3392	return;
3393	}
3394	if (!(flags & SVp_POK)) {
3395	if ((flags & SVTYPEMASK) < SVt_PVNV)
3396	sv_upgrade(sv, SVt_NV);
3397	SvNVX(sv) = -1.0;
3398	(void)SvNOK_only(sv);
3399	return;
3400	}
3401	SET_NUMERIC_STANDARD();
3402	sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
3403	}
3404
3405	/* Make a string that will exist for the duration of the expression
3406	* evaluation. Actually, it may have to last longer than that, but
3407	* hopefully we won't free it until it has been assigned to a
3408	* permanent location. */
3409
3410	static void
3411	sv_mortalgrow()
3412	{
3413	tmps_max += (tmps_max < 512) ? 128 : 512;
3414	Renew(tmps_stack, tmps_max, SV*);
3415	}
3416
3417	SV *
3418	sv_mortalcopy(oldstr)
3419	SV *oldstr;
3420	{
3421	register SV *sv;
3422
3423	new_SV(sv);
3424	SvANY(sv) = 0;
3425	SvREFCNT(sv) = 1;
3426	SvFLAGS(sv) = 0;
3427	sv_setsv(sv,oldstr);
3428	if (++tmps_ix >= tmps_max)
3429	sv_mortalgrow();
3430	tmps_stack[tmps_ix] = sv;
3431	SvTEMP_on(sv);
3432	return sv;
3433	}
3434
3435	SV *
3436	sv_newmortal()
3437	{
3438	register SV *sv;
3439
3440	new_SV(sv);
3441	SvANY(sv) = 0;
3442	SvREFCNT(sv) = 1;
3443	SvFLAGS(sv) = SVs_TEMP;
3444	if (++tmps_ix >= tmps_max)
3445	sv_mortalgrow();
3446	tmps_stack[tmps_ix] = sv;
3447	return sv;
3448	}
3449
3450	/* same thing without the copying */
3451
3452	SV *
3453	sv_2mortal(sv)
3454	register SV *sv;
3455	{
3456	if (!sv)
3457	return sv;
3458	if (SvREADONLY(sv) && curcop != &compiling)
3459	croak(no_modify);
3460	if (++tmps_ix >= tmps_max)
3461	sv_mortalgrow();
3462	tmps_stack[tmps_ix] = sv;
3463	SvTEMP_on(sv);
3464	return sv;
3465	}
3466
3467	SV *
3468	newSVpv(s,len)
3469	char *s;
3470	STRLEN len;
3471	{
3472	register SV *sv;
3473
3474	new_SV(sv);
3475	SvANY(sv) = 0;
3476	SvREFCNT(sv) = 1;
3477	SvFLAGS(sv) = 0;
3478	if (!len)
3479	len = strlen(s);
3480	sv_setpvn(sv,s,len);
3481	return sv;
3482	}
3483
3484	#ifdef I_STDARG
3485	SV *
3486	newSVpvf(const char* pat, ...)
3487	#else
3488	/VARARGS0/
3489	SV *
3490	newSVpvf(pat, va_alist)
3491	const char *pat;
3492	va_dcl
3493	#endif
3494	{
3495	register SV *sv;
3496	va_list args;
3497
3498	new_SV(sv);
3499	SvANY(sv) = 0;
3500	SvREFCNT(sv) = 1;
3501	SvFLAGS(sv) = 0;
3502	#ifdef I_STDARG
3503	va_start(args, pat);
3504	#else
3505	va_start(args);
3506	#endif
3507	sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV*), 0, Null(bool));
3508	va_end(args);
3509	return sv;
3510	}
3511
3512
3513	SV *
3514	newSVnv(n)
3515	double n;
3516	{
3517	register SV *sv;
3518
3519	new_SV(sv);
3520	SvANY(sv) = 0;
3521	SvREFCNT(sv) = 1;
3522	SvFLAGS(sv) = 0;
3523	sv_setnv(sv,n);
3524	return sv;
3525	}
3526
3527	SV *
3528	newSViv(i)
3529	IV i;
3530	{
3531	register SV *sv;
3532
3533	new_SV(sv);
3534	SvANY(sv) = 0;
3535	SvREFCNT(sv) = 1;
3536	SvFLAGS(sv) = 0;
3537	sv_setiv(sv,i);
3538	return sv;
3539	}
3540
3541	SV *
3542	newRV(ref)
3543	SV *ref;
3544	{
3545	register SV *sv;
3546
3547	new_SV(sv);
3548	SvANY(sv) = 0;
3549	SvREFCNT(sv) = 1;
3550	SvFLAGS(sv) = 0;
3551	sv_upgrade(sv, SVt_RV);
3552	SvTEMP_off(ref);
3553	SvRV(sv) = SvREFCNT_inc(ref);
3554	SvROK_on(sv);
3555	return sv;
3556	}
3557
3558	#ifdef CRIPPLED_CC
3559	SV *
3560	newRV_noinc(ref)
3561	SV *ref;
3562	{
3563	register SV *sv;
3564
3565	sv = newRV(ref);
3566	SvREFCNT_dec(ref);
3567	return sv;
3568	}
3569	#endif /* CRIPPLED_CC */
3570
3571	/* make an exact duplicate of old */
3572
3573	SV *
3574	newSVsv(old)
3575	register SV *old;
3576	{
3577	register SV *sv;
3578
3579	if (!old)
3580	return Nullsv;
3581	if (SvTYPE(old) == SVTYPEMASK) {
3582	warn("semi-panic: attempt to dup freed string");
3583	return Nullsv;
3584	}
3585	new_SV(sv);
3586	SvANY(sv) = 0;
3587	SvREFCNT(sv) = 1;
3588	SvFLAGS(sv) = 0;
3589	if (SvTEMP(old)) {
3590	SvTEMP_off(old);
3591	sv_setsv(sv,old);
3592	SvTEMP_on(old);
3593	}
3594	else
3595	sv_setsv(sv,old);
3596	return sv;
3597	}
3598
3599	void
3600	sv_reset(s,stash)
3601	register char *s;
3602	HV *stash;
3603	{
3604	register HE *entry;
3605	register GV *gv;
3606	register SV *sv;
3607	register I32 i;
3608	register PMOP *pm;
3609	register I32 max;
3610	char todo[256];
3611
3612	if (!s) { / reset ?? searches */
3613	for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
3614	pm->op_pmflags &= ~PMf_USED;
3615	}
3616	return;
3617	}
3618
3619	/* reset variables */
3620
3621	if (!HvARRAY(stash))
3622	return;
3623
3624	Zero(todo, 256, char);
3625	while (*s) {
3626	i = *s;
3627	if (s[1] == '-') {
3628	s += 2;
3629	}
3630	max = *s++;
3631	for ( ; i <= max; i++) {
3632	todo[i] = 1;
3633	}
3634	for (i = 0; i <= (I32) HvMAX(stash); i++) {
3635	for (entry = HvARRAY(stash)[i];
3636	entry;
3637	entry = HeNEXT(entry)) {
3638	if (!todo[(U8)*HeKEY(entry)])
3639	continue;
3640	gv = (GV*)HeVAL(entry);
3641	sv = GvSV(gv);
3642	(void)SvOK_off(sv);
3643	if (SvTYPE(sv) >= SVt_PV) {
3644	SvCUR_set(sv, 0);
3645	if (SvPVX(sv) != Nullch)
3646	*SvPVX(sv) = '\0';
3647	SvTAINT(sv);
3648	}
3649	if (GvAV(gv)) {
3650	av_clear(GvAV(gv));
3651	}
3652	if (GvHV(gv) && !HvNAME(GvHV(gv))) {
3653	hv_clear(GvHV(gv));
3654	#ifndef VMS /* VMS has no environ array */
3655	if (gv == envgv)
3656	environ[0] = Nullch;
3657	#endif
3658	}
3659	}
3660	}
3661	}
3662	}
3663
3664	IO*
3665	sv_2io(sv)
3666	SV *sv;
3667	{
3668	IO* io;
3669	GV* gv;
3670
3671	switch (SvTYPE(sv)) {
3672	case SVt_PVIO:
3673	io = (IO*)sv;
3674	break;
3675	case SVt_PVGV:
3676	gv = (GV*)sv;
3677	io = GvIO(gv);
3678	if (!io)
3679	croak("Bad filehandle: %s", GvNAME(gv));
3680	break;
3681	default:
3682	if (!SvOK(sv))
3683	croak(no_usym, "filehandle");
3684	if (SvROK(sv))
3685	return sv_2io(SvRV(sv));
3686	gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO);
3687	if (gv)
3688	io = GvIO(gv);
3689	else
3690	io = 0;
3691	if (!io)
3692	croak("Bad filehandle: %s", SvPV(sv,na));
3693	break;
3694	}
3695	return io;
3696	}
3697
3698	CV *
3699	sv_2cv(sv, st, gvp, lref)
3700	SV *sv;
3701	HV **st;
3702	GV **gvp;
3703	I32 lref;
3704	{
3705	GV *gv;
3706	CV *cv;
3707
3708	if (!sv)
3709	return *gvp = Nullgv, Nullcv;
3710	switch (SvTYPE(sv)) {
3711	case SVt_PVCV:
3712	*st = CvSTASH(sv);
3713	*gvp = Nullgv;
3714	return (CV*)sv;
3715	case SVt_PVHV:
3716	case SVt_PVAV:
3717	*gvp = Nullgv;
3718	return Nullcv;
3719	case SVt_PVGV:
3720	gv = (GV*)sv;
3721	*gvp = gv;
3722	*st = GvESTASH(gv);
3723	goto fix_gv;
3724
3725	default:
3726	if (SvGMAGICAL(sv))
3727	mg_get(sv);
3728	if (SvROK(sv)) {
3729	cv = (CV*)SvRV(sv);
3730	if (SvTYPE(cv) != SVt_PVCV)
3731	croak("Not a subroutine reference");
3732	*gvp = Nullgv;
3733	*st = CvSTASH(cv);
3734	return cv;
3735	}
3736	if (isGV(sv))
3737	gv = (GV*)sv;
3738	else
3739	gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV);
3740	*gvp = gv;
3741	if (!gv)
3742	return Nullcv;
3743	*st = GvESTASH(gv);
3744	fix_gv:
3745	if (lref && !GvCVu(gv)) {
3746	SV *tmpsv;
3747	ENTER;
3748	tmpsv = NEWSV(704,0);
3749	gv_efullname3(tmpsv, gv, Nullch);
3750	newSUB(start_subparse(FALSE, 0),
3751	newSVOP(OP_CONST, 0, tmpsv),
3752	Nullop,
3753	Nullop);
3754	LEAVE;
3755	if (!GvCVu(gv))
3756	croak("Unable to create sub named \"%s\"", SvPV(sv,na));
3757	}
3758	return GvCVu(gv);
3759	}
3760	}
3761
3762	#ifndef SvTRUE
3763	I32
3764	SvTRUE(sv)
3765	register SV *sv;
3766	{
3767	if (!sv)
3768	return 0;
3769	if (SvGMAGICAL(sv))
3770	mg_get(sv);
3771	if (SvPOK(sv)) {
3772	register XPV* Xpv;
3773	if ((Xpv = (XPV*)SvANY(sv)) &&
3774	(*Xpv->xpv_pv > '0' \|\|
3775	Xpv->xpv_cur > 1 \|\|
3776	(Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
3777	return 1;
3778	else
3779	return 0;
3780	}
3781	else {
3782	if (SvIOK(sv))
3783	return SvIVX(sv) != 0;
3784	else {
3785	if (SvNOK(sv))
3786	return SvNVX(sv) != 0.0;
3787	else
3788	return sv_2bool(sv);
3789	}
3790	}
3791	}
3792	#endif /* !SvTRUE */
3793
3794	#ifndef SvIV
3795	IV
3796	SvIV(sv)
3797	register SV *sv;
3798	{
3799	if (SvIOK(sv))
3800	return SvIVX(sv);
3801	return sv_2iv(sv);
3802	}
3803	#endif /* !SvIV */
3804
3805	#ifndef SvUV
3806	UV
3807	SvUV(sv)
3808	register SV *sv;
3809	{
3810	if (SvIOK(sv))
3811	return SvUVX(sv);
3812	return sv_2uv(sv);
3813	}
3814	#endif /* !SvUV */
3815
3816	#ifndef SvNV
3817	double
3818	SvNV(sv)
3819	register SV *sv;
3820	{
3821	if (SvNOK(sv))
3822	return SvNVX(sv);
3823	return sv_2nv(sv);
3824	}
3825	#endif /* !SvNV */
3826
3827	#ifdef CRIPPLED_CC
3828	char *
3829	sv_pvn(sv, lp)
3830	SV *sv;
3831	STRLEN *lp;
3832	{
3833	if (SvPOK(sv)) {
3834	*lp = SvCUR(sv);
3835	return SvPVX(sv);
3836	}
3837	return sv_2pv(sv, lp);
3838	}
3839	#endif
3840
3841	char *
3842	sv_pvn_force(sv, lp)
3843	SV *sv;
3844	STRLEN *lp;
3845	{
3846	char *s;
3847
3848	if (SvREADONLY(sv) && curcop != &compiling)
3849	croak(no_modify);
3850
3851	if (SvPOK(sv)) {
3852	*lp = SvCUR(sv);
3853	}
3854	else {
3855	if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
3856	if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) {
3857	sv_unglob(sv);
3858	s = SvPVX(sv);
3859	*lp = SvCUR(sv);
3860	}
3861	else
3862	croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
3863	op_name[op->op_type]);
3864	}
3865	else
3866	s = sv_2pv(sv, lp);
3867	if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
3868	STRLEN len = *lp;
3869
3870	if (SvROK(sv))
3871	sv_unref(sv);
3872	(void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
3873	SvGROW(sv, len + 1);
3874	Move(s,SvPVX(sv),len,char);
3875	SvCUR_set(sv, len);
3876	*SvEND(sv) = '\0';
3877	}
3878	if (!SvPOK(sv)) {
3879	SvPOK_on(sv); /* validate pointer */
3880	SvTAINT(sv);
3881	DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
3882	(unsigned long)sv,SvPVX(sv)));
3883	}
3884	}
3885	return SvPVX(sv);
3886	}
3887
3888	char *
3889	sv_reftype(sv, ob)
3890	SV* sv;
3891	int ob;
3892	{
3893	if (ob && SvOBJECT(sv))
3894	return HvNAME(SvSTASH(sv));
3895	else {
3896	switch (SvTYPE(sv)) {
3897	case SVt_NULL:
3898	case SVt_IV:
3899	case SVt_NV:
3900	case SVt_RV:
3901	case SVt_PV:
3902	case SVt_PVIV:
3903	case SVt_PVNV:
3904	case SVt_PVMG:
3905	case SVt_PVBM:
3906	if (SvROK(sv))
3907	return "REF";
3908	else
3909	return "SCALAR";
3910	case SVt_PVLV: return "LVALUE";
3911	case SVt_PVAV: return "ARRAY";
3912	case SVt_PVHV: return "HASH";
3913	case SVt_PVCV: return "CODE";
3914	case SVt_PVGV: return "GLOB";
3915	case SVt_PVFM: return "FORMLINE";
3916	default: return "UNKNOWN";
3917	}
3918	}
3919	}
3920
3921	int
3922	sv_isobject(sv)
3923	SV *sv;
3924	{
3925	if (!sv)
3926	return 0;
3927	if (SvGMAGICAL(sv))
3928	mg_get(sv);
3929	if (!SvROK(sv))
3930	return 0;
3931	sv = (SV*)SvRV(sv);
3932	if (!SvOBJECT(sv))
3933	return 0;
3934	return 1;
3935	}
3936
3937	int
3938	sv_isa(sv, name)
3939	SV *sv;
3940	char *name;
3941	{
3942	if (!sv)
3943	return 0;
3944	if (SvGMAGICAL(sv))
3945	mg_get(sv);
3946	if (!SvROK(sv))
3947	return 0;
3948	sv = (SV*)SvRV(sv);
3949	if (!SvOBJECT(sv))
3950	return 0;
3951
3952	return strEQ(HvNAME(SvSTASH(sv)), name);
3953	}
3954
3955	SV*
3956	newSVrv(rv, classname)
3957	SV *rv;
3958	char *classname;
3959	{
3960	SV *sv;
3961
3962	new_SV(sv);
3963	SvANY(sv) = 0;
3964	SvREFCNT(sv) = 0;
3965	SvFLAGS(sv) = 0;
3966	sv_upgrade(rv, SVt_RV);
3967	SvRV(rv) = SvREFCNT_inc(sv);
3968	SvROK_on(rv);
3969
3970	if (classname) {
3971	HV* stash = gv_stashpv(classname, TRUE);
3972	(void)sv_bless(rv, stash);
3973	}
3974	return sv;
3975	}
3976
3977	SV*
3978	sv_setref_pv(rv, classname, pv)
3979	SV *rv;
3980	char *classname;
3981	void* pv;
3982	{
3983	if (!pv)
3984	sv_setsv(rv, &sv_undef);
3985	else
3986	sv_setiv(newSVrv(rv,classname), (IV)pv);
3987	return rv;
3988	}
3989
3990	SV*
3991	sv_setref_iv(rv, classname, iv)
3992	SV *rv;
3993	char *classname;
3994	IV iv;
3995	{
3996	sv_setiv(newSVrv(rv,classname), iv);
3997	return rv;
3998	}
3999
4000	SV*
4001	sv_setref_nv(rv, classname, nv)
4002	SV *rv;
4003	char *classname;
4004	double nv;
4005	{
4006	sv_setnv(newSVrv(rv,classname), nv);
4007	return rv;
4008	}
4009
4010	SV*
4011	sv_setref_pvn(rv, classname, pv, n)
4012	SV *rv;
4013	char *classname;
4014	char* pv;
4015	I32 n;
4016	{
4017	sv_setpvn(newSVrv(rv,classname), pv, n);
4018	return rv;
4019	}
4020
4021	SV*
4022	sv_bless(sv,stash)
4023	SV* sv;
4024	HV* stash;
4025	{
4026	SV *ref;
4027	if (!SvROK(sv))
4028	croak("Can't bless non-reference value");
4029	ref = SvRV(sv);
4030	if (SvFLAGS(ref) & (SVs_OBJECT\|SVf_READONLY)) {
4031	if (SvREADONLY(ref))
4032	croak(no_modify);
4033	if (SvOBJECT(ref)) {
4034	if (SvTYPE(ref) != SVt_PVIO)
4035	--sv_objcount;
4036	SvREFCNT_dec(SvSTASH(ref));
4037	}
4038	}
4039	SvOBJECT_on(ref);
4040	if (SvTYPE(ref) != SVt_PVIO)
4041	++sv_objcount;
4042	(void)SvUPGRADE(ref, SVt_PVMG);
4043	SvSTASH(ref) = (HV*)SvREFCNT_inc(stash);
4044
4045	#ifdef OVERLOAD
4046	if (Gv_AMG(stash))
4047	SvAMAGIC_on(sv);
4048	else
4049	SvAMAGIC_off(sv);
4050	#endif /* OVERLOAD */
4051
4052	return sv;
4053	}
4054
4055	static void
4056	sv_unglob(sv)
4057	SV* sv;
4058	{
4059	assert(SvTYPE(sv) == SVt_PVGV);
4060	SvFAKE_off(sv);
4061	if (GvGP(sv))
4062	gp_free((GV*)sv);
4063	sv_unmagic(sv, '*');
4064	Safefree(GvNAME(sv));
4065	GvMULTI_off(sv);
4066	SvFLAGS(sv) &= ~SVTYPEMASK;
4067	SvFLAGS(sv) \|= SVt_PVMG;
4068	}
4069
4070	void
4071	sv_unref(sv)
4072	SV* sv;
4073	{
4074	SV* rv = SvRV(sv);
4075
4076	SvRV(sv) = 0;
4077	SvROK_off(sv);
4078	if (SvREFCNT(rv) != 1 \|\| SvREADONLY(rv))
4079	SvREFCNT_dec(rv);
4080	else
4081	sv_2mortal(rv); /* Schedule for freeing later */
4082	}
4083
4084	void
4085	sv_taint(sv)
4086	SV *sv;
4087	{
4088	sv_magic((sv), Nullsv, 't', Nullch, 0);
4089	}
4090
4091	void
4092	sv_untaint(sv)
4093	SV *sv;
4094	{
4095	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4096	MAGIC *mg = mg_find(sv, 't');
4097	if (mg)
4098	mg->mg_len &= ~1;
4099	}
4100	}
4101
4102	bool
4103	sv_tainted(sv)
4104	SV *sv;
4105	{
4106	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4107	MAGIC *mg = mg_find(sv, 't');
4108	if (mg && ((mg->mg_len & 1) \|\| (mg->mg_len & 2) && mg->mg_obj == sv))
4109	return TRUE;
4110	}
4111	return FALSE;
4112	}
4113
4114	void
4115	sv_setpviv(sv, iv)
4116	SV *sv;
4117	IV iv;
4118	{
4119	STRLEN len;
4120	char buf[TYPE_DIGITS(UV)];
4121	char *ptr = buf + sizeof(buf);
4122	int sign;
4123	UV uv;
4124	char *p;
4125
4126	sv_setpvn(sv, "", 0);
4127	if (iv >= 0) {
4128	uv = iv;
4129	sign = 0;
4130	} else {
4131	uv = -iv;
4132	sign = 1;
4133	}
4134	do {
4135	*--ptr = '0' + (uv % 10);
4136	} while (uv /= 10);
4137	len = (buf + sizeof(buf)) - ptr;
4138	/* taking advantage of SvCUR(sv) == 0 */
4139	SvGROW(sv, sign + len + 1);
4140	p = SvPVX(sv);
4141	if (sign)
4142	*p++ = '-';
4143	memcpy(p, ptr, len);
4144	p += len;
4145	*p = '\0';
4146	SvCUR(sv) = p - SvPVX(sv);
4147	}
4148
4149	#ifdef I_STDARG
4150	void
4151	sv_setpvf(SV sv, const char pat, ...)
4152	#else
4153	/VARARGS0/
4154	void
4155	sv_setpvf(sv, pat, va_alist)
4156	SV *sv;
4157	const char *pat;
4158	va_dcl
4159	#endif
4160	{
4161	va_list args;
4162	#ifdef I_STDARG
4163	va_start(args, pat);
4164	#else
4165	va_start(args);
4166	#endif
4167	sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV*), 0, Null(bool));
4168	va_end(args);
4169	}
4170
4171	#ifdef I_STDARG
4172	void
4173	sv_catpvf(SV sv, const char pat, ...)
4174	#else
4175	/VARARGS0/
4176	void
4177	sv_catpvf(sv, pat, va_alist)
4178	SV *sv;
4179	const char *pat;
4180	va_dcl
4181	#endif
4182	{
4183	va_list args;
4184	#ifdef I_STDARG
4185	va_start(args, pat);
4186	#else
4187	va_start(args);
4188	#endif
4189	sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV*), 0, Null(bool));
4190	va_end(args);
4191	}
4192
4193	void
4194	sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
4195	SV *sv;
4196	const char *pat;
4197	STRLEN patlen;
4198	va_list *args;
4199	SV **svargs;
4200	I32 svmax;
4201	bool *used_locale;
4202	{
4203	sv_setpvn(sv, "", 0);
4204	sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4205	}
4206
4207	void
4208	sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
4209	SV *sv;
4210	const char *pat;
4211	STRLEN patlen;
4212	va_list *args;
4213	SV **svargs;
4214	I32 svmax;
4215	bool *used_locale;
4216	{
4217	char *p;
4218	char *q;
4219	char *patend;
4220	STRLEN origlen;
4221	I32 svix = 0;
4222	static char nullstr[] = "(null)";
4223
4224	/* no matter what, this is a string now */
4225	(void)SvPV_force(sv, origlen);
4226
4227	/* special-case "", "%s", and "%_" */
4228	if (patlen == 0)
4229	return;
4230	if (patlen == 2 && pat[0] == '%') {
4231	switch (pat[1]) {
4232	case 's':
4233	if (args) {
4234	char s = va_arg(args, char*);
4235	sv_catpv(sv, s ? s : nullstr);
4236	}
4237	else if (svix < svmax)
4238	sv_catsv(sv, *svargs);
4239	return;
4240	case '_':
4241	if (args) {
4242	sv_catsv(sv, va_arg(args, SV));
4243	return;
4244	}
4245	/* See comment on '_' below */
4246	break;
4247	}
4248	}
4249
4250	patend = (char*)pat + patlen;
4251	for (p = (char*)pat; p < patend; p = q) {
4252	bool alt = FALSE;
4253	bool left = FALSE;
4254	char fill = ' ';
4255	char plus = 0;
4256	char intsize = 0;
4257	STRLEN width = 0;
4258	STRLEN zeros = 0;
4259	bool has_precis = FALSE;
4260	STRLEN precis = 0;
4261
4262	char esignbuf[4];
4263	STRLEN esignlen = 0;
4264
4265	char *eptr = Nullch;
4266	STRLEN elen = 0;
4267	char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4268
4269	static char *efloatbuf = Nullch;
4270	static STRLEN efloatsize = 0;
4271
4272	char c;
4273	int i;
4274	unsigned base;
4275	IV iv;
4276	UV uv;
4277	double nv;
4278	STRLEN have;
4279	STRLEN need;
4280	STRLEN gap;
4281
4282	for (q = p; q < patend && *q != '%'; ++q) ;
4283	if (q > p) {
4284	sv_catpvn(sv, p, q - p);
4285	p = q;
4286	}
4287	if (q++ >= patend)
4288	break;
4289
4290	/* FLAGS */
4291
4292	while (*q) {
4293	switch (*q) {
4294	case ' ':
4295	case '+':
4296	plus = *q++;
4297	continue;
4298
4299	case '-':
4300	left = TRUE;
4301	q++;
4302	continue;
4303
4304	case '0':
4305	fill = *q++;
4306	continue;
4307
4308	case '#':
4309	alt = TRUE;
4310	q++;
4311	continue;
4312
4313	default:
4314	break;
4315	}
4316	break;
4317	}
4318
4319	/* WIDTH */
4320
4321	switch (*q) {
4322	case '1': case '2': case '3':
4323	case '4': case '5': case '6':
4324	case '7': case '8': case '9':
4325	width = 0;
4326	while (isDIGIT(*q))
4327	width = width * 10 + (*q++ - '0');
4328	break;
4329
4330	case '*':
4331	if (args)
4332	i = va_arg(*args, int);
4333	else
4334	i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4335	left \|= (i < 0);
4336	width = (i < 0) ? -i : i;
4337	q++;
4338	break;
4339	}
4340
4341	/* PRECISION */
4342
4343	if (*q == '.') {
4344	q++;
4345	if (q == '') {
4346	if (args)
4347	i = va_arg(*args, int);
4348	else
4349	i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4350	precis = (i < 0) ? 0 : i;
4351	q++;
4352	}
4353	else {
4354	precis = 0;
4355	while (isDIGIT(*q))
4356	precis = precis * 10 + (*q++ - '0');
4357	}
4358	has_precis = TRUE;
4359	}
4360
4361	/* SIZE */
4362
4363	switch (*q) {
4364	case 'l':
4365	#if 0 /* when quads have better support within Perl */
4366	if (*(q + 1) == 'l') {
4367	intsize = 'q';
4368	q += 2;
4369	break;
4370	}
4371	#endif
4372	/* FALL THROUGH */
4373	case 'h':
4374	case 'V':
4375	intsize = *q++;
4376	break;
4377	}
4378
4379	/* CONVERSION */
4380
4381	switch (c = *q++) {
4382
4383	/* STRINGS */
4384
4385	case '%':
4386	eptr = q - 1;
4387	elen = 1;
4388	goto string;
4389
4390	case 'c':
4391	if (args)
4392	c = va_arg(*args, int);
4393	else
4394	c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4395	eptr = &c;
4396	elen = 1;
4397	goto string;
4398
4399	case 's':
4400	if (args) {
4401	eptr = va_arg(args, char);
4402	if (eptr)
4403	elen = strlen(eptr);
4404	else {
4405	eptr = nullstr;
4406	elen = sizeof nullstr - 1;
4407	}
4408	}
4409	else if (svix < svmax)
4410	eptr = SvPVx(svargs[svix++], elen);
4411	goto string;
4412
4413	case '_':
4414	/*
4415	* The "%_" hack might have to be changed someday,
4416	* if ISO or ANSI decide to use '_' for something.
4417	* So we keep it hidden from users' code.
4418	*/
4419	if (!args)
4420	goto unknown;
4421	eptr = SvPVx(va_arg(args, SV), elen);
4422
4423	string:
4424	if (has_precis && elen > precis)
4425	elen = precis;
4426	break;
4427
4428	/* INTEGERS */
4429
4430	case 'p':
4431	if (args)
4432	uv = (UV)va_arg(args, void);
4433	else
4434	uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4435	base = 16;
4436	goto integer;
4437
4438	case 'D':
4439	intsize = 'l';
4440	/* FALL THROUGH */
4441	case 'd':
4442	case 'i':
4443	if (args) {
4444	switch (intsize) {
4445	case 'h': iv = (short)va_arg(*args, int); break;
4446	default: iv = va_arg(*args, int); break;
4447	case 'l': iv = va_arg(*args, long); break;
4448	case 'V': iv = va_arg(*args, IV); break;
4449	}
4450	}
4451	else {
4452	iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4453	switch (intsize) {
4454	case 'h': iv = (short)iv; break;
4455	default: iv = (int)iv; break;
4456	case 'l': iv = (long)iv; break;
4457	case 'V': break;
4458	}
4459	}
4460	if (iv >= 0) {
4461	uv = iv;
4462	if (plus)
4463	esignbuf[esignlen++] = plus;
4464	}
4465	else {
4466	uv = -iv;
4467	esignbuf[esignlen++] = '-';
4468	}
4469	base = 10;
4470	goto integer;
4471
4472	case 'U':
4473	intsize = 'l';
4474	/* FALL THROUGH */
4475	case 'u':
4476	base = 10;
4477	goto uns_integer;
4478
4479	case 'O':
4480	intsize = 'l';
4481	/* FALL THROUGH */
4482	case 'o':
4483	base = 8;
4484	goto uns_integer;
4485
4486	case 'X':
4487	case 'x':
4488	base = 16;
4489
4490	uns_integer:
4491	if (args) {
4492	switch (intsize) {
4493	case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4494	default: uv = va_arg(*args, unsigned); break;
4495	case 'l': uv = va_arg(*args, unsigned long); break;
4496	case 'V': uv = va_arg(*args, UV); break;
4497	}
4498	}
4499	else {
4500	uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4501	switch (intsize) {
4502	case 'h': uv = (unsigned short)uv; break;
4503	default: uv = (unsigned)uv; break;
4504	case 'l': uv = (unsigned long)uv; break;
4505	case 'V': break;
4506	}
4507	}
4508
4509	integer:
4510	eptr = ebuf + sizeof ebuf;
4511	switch (base) {
4512	unsigned dig;
4513	case 16:
4514	p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4515	do {
4516	dig = uv & 15;
4517	*--eptr = p[dig];
4518	} while (uv >>= 4);
4519	if (alt) {
4520	esignbuf[esignlen++] = '0';
4521	esignbuf[esignlen++] = c; /* 'x' or 'X' */
4522	}
4523	break;
4524	case 8:
4525	do {
4526	dig = uv & 7;
4527	*--eptr = '0' + dig;
4528	} while (uv >>= 3);
4529	if (alt && *eptr != '0')
4530	*--eptr = '0';
4531	break;
4532	default: /* it had better be ten or less */
4533	do {
4534	dig = uv % base;
4535	*--eptr = '0' + dig;
4536	} while (uv /= base);
4537	break;
4538	}
4539	elen = (ebuf + sizeof ebuf) - eptr;
4540	if (has_precis && precis > elen)
4541	zeros = precis - elen;
4542	break;
4543
4544	/* FLOATING POINT */
4545
4546	case 'F':
4547	c = 'f'; /* maybe %F isn't supported here */
4548	/* FALL THROUGH */
4549	case 'e': case 'E':
4550	case 'f':
4551	case 'g': case 'G':
4552
4553	/* This is evil, but floating point is even more evil */
4554
4555	if (args)
4556	nv = va_arg(*args, double);
4557	else
4558	nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
4559
4560	need = 0;
4561	if (c != 'e' && c != 'E') {
4562	i = PERL_INT_MIN;
4563	(void)frexp(nv, &i);
4564	if (i == PERL_INT_MIN)
4565	die("panic: frexp");
4566	if (i > 0)
4567	need = BIT_DIGITS(i);
4568	}
4569	need += has_precis ? precis : 6; /* known default */
4570	if (need < width)
4571	need = width;
4572
4573	need += 20; /* fudge factor */
4574	if (efloatsize < need) {
4575	Safefree(efloatbuf);
4576	efloatsize = need + 20; /* more fudge */
4577	New(906, efloatbuf, efloatsize, char);
4578	}
4579
4580	eptr = ebuf + sizeof ebuf;
4581	*--eptr = '\0';
4582	*--eptr = c;
4583	if (has_precis) {
4584	base = precis;
4585	do { *--eptr = '0' + (base % 10); } while (base /= 10);
4586	*--eptr = '.';
4587	}
4588	if (width) {
4589	base = width;
4590	do { *--eptr = '0' + (base % 10); } while (base /= 10);
4591	}
4592	if (fill == '0')
4593	*--eptr = fill;
4594	if (left)
4595	*--eptr = '-';
4596	if (plus)
4597	*--eptr = plus;
4598	if (alt)
4599	*--eptr = '#';
4600	*--eptr = '%';
4601
4602	(void)sprintf(efloatbuf, eptr, nv);
4603
4604	eptr = efloatbuf;
4605	elen = strlen(efloatbuf);
4606
4607	#ifdef LC_NUMERIC
4608	/*
4609	* User-defined locales may include arbitrary characters.
4610	* And, unfortunately, some system may alloc the "C" locale
4611	* to be overridden by a malicious user.
4612	*/
4613	if (used_locale)
4614	*used_locale = TRUE;
4615	#endif /* LC_NUMERIC */
4616
4617	break;
4618
4619	/* SPECIAL */
4620
4621	case 'n':
4622	i = SvCUR(sv) - origlen;
4623	if (args) {
4624	switch (intsize) {
4625	case 'h': (va_arg(args, short*)) = i; break;
4626	default: (va_arg(args, int*)) = i; break;
4627	case 'l': (va_arg(args, long*)) = i; break;
4628	case 'V': (va_arg(args, IV*)) = i; break;
4629	}
4630	}
4631	else if (svix < svmax)
4632	sv_setuv(svargs[svix++], (UV)i);
4633	continue; /* not "break" */
4634
4635	/* UNKNOWN */
4636
4637	default:
4638	unknown:
4639	if (!args && dowarn &&
4640	(op->op_type == OP_PRTF \|\| op->op_type == OP_SPRINTF)) {
4641	SV *msg = sv_newmortal();
4642	sv_setpvf(msg, "Invalid conversion in %s: ",
4643	(op->op_type == OP_PRTF) ? "printf" : "sprintf");
4644	if (c)
4645	sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
4646	c & 0xFF);
4647	else
4648	sv_catpv(msg, "end of string");
4649	warn("%_", msg); /* yes, this is reentrant */
4650	}
4651
4652	/* output mangled stuff ... */
4653	if (c == '\0')
4654	--q;
4655	eptr = p;
4656	elen = q - p;
4657
4658	/* ... right here, because formatting flags should not apply */
4659	SvGROW(sv, SvCUR(sv) + elen + 1);
4660	p = SvEND(sv);
4661	memcpy(p, eptr, elen);
4662	p += elen;
4663	*p = '\0';
4664	SvCUR(sv) = p - SvPVX(sv);
4665	continue; /* not "break" */
4666	}
4667
4668	have = esignlen + zeros + elen;
4669	need = (have > width ? have : width);
4670	gap = need - have;
4671
4672	SvGROW(sv, SvCUR(sv) + need + 1);
4673	p = SvEND(sv);
4674	if (esignlen && fill == '0') {
4675	for (i = 0; i < esignlen; i++)
4676	*p++ = esignbuf[i];
4677	}
4678	if (gap && !left) {
4679	memset(p, fill, gap);
4680	p += gap;
4681	}
4682	if (esignlen && fill != '0') {
4683	for (i = 0; i < esignlen; i++)
4684	*p++ = esignbuf[i];
4685	}
4686	if (zeros) {
4687	for (i = zeros; i; i--)
4688	*p++ = '0';
4689	}
4690	if (elen) {
4691	memcpy(p, eptr, elen);
4692	p += elen;
4693	}
4694	if (gap && left) {
4695	memset(p, ' ', gap);
4696	p += gap;
4697	}
4698	*p = '\0';
4699	SvCUR(sv) = p - SvPVX(sv);
4700	}
4701	}
4702
4703	#ifdef DEBUGGING
4704	void
4705	sv_dump(sv)
4706	SV* sv;
4707	{
4708	SV *d = sv_newmortal();
4709	char *s;
4710	U32 flags;
4711	U32 type;
4712
4713	if (!sv) {
4714	PerlIO_printf(Perl_debug_log, "SV = 0\n");
4715	return;
4716	}
4717
4718	flags = SvFLAGS(sv);
4719	type = SvTYPE(sv);
4720
4721	sv_setpvf(d, "(0x%lx)\n REFCNT = %ld\n FLAGS = (",
4722	(unsigned long)SvANY(sv), (long)SvREFCNT(sv));
4723	if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,");
4724	if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
4725	if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
4726	if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
4727	if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
4728	if (flags & SVs_GMG) sv_catpv(d, "GMG,");
4729	if (flags & SVs_SMG) sv_catpv(d, "SMG,");
4730	if (flags & SVs_RMG) sv_catpv(d, "RMG,");
4731
4732	if (flags & SVf_IOK) sv_catpv(d, "IOK,");
4733	if (flags & SVf_NOK) sv_catpv(d, "NOK,");
4734	if (flags & SVf_POK) sv_catpv(d, "POK,");
4735	if (flags & SVf_ROK) sv_catpv(d, "ROK,");
4736	if (flags & SVf_OOK) sv_catpv(d, "OOK,");
4737	if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
4738	if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
4739
4740	#ifdef OVERLOAD
4741	if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
4742	#endif /* OVERLOAD */
4743	if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
4744	if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
4745	if (flags & SVp_POK) sv_catpv(d, "pPOK,");
4746	if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,");
4747
4748	switch (type) {
4749	case SVt_PVCV:
4750	case SVt_PVFM:
4751	if (CvANON(sv)) sv_catpv(d, "ANON,");
4752	if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
4753	if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
4754	if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
4755	if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
4756	break;
4757	case SVt_PVHV:
4758	if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
4759	if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
4760	break;
4761	case SVt_PVGV:
4762	if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
4763	if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
4764	if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
4765	if (GvIMPORTED(sv)) {
4766	sv_catpv(d, "IMPORT");
4767	if (GvIMPORTED(sv) == GVf_IMPORTED)
4768	sv_catpv(d, "ALL,");
4769	else {
4770	sv_catpv(d, "(");
4771	if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
4772	if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
4773	if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
4774	if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
4775	sv_catpv(d, " ),");
4776	}
4777	}
4778	}
4779
4780	if (*(SvEND(d) - 1) == ',')
4781	SvPVX(d)[--SvCUR(d)] = '\0';
4782	sv_catpv(d, ")");
4783	s = SvPVX(d);
4784
4785	PerlIO_printf(Perl_debug_log, "SV = ");
4786	switch (type) {
4787	case SVt_NULL:
4788	PerlIO_printf(Perl_debug_log, "NULL%s\n", s);
4789	return;
4790	case SVt_IV:
4791	PerlIO_printf(Perl_debug_log, "IV%s\n", s);
4792	break;
4793	case SVt_NV:
4794	PerlIO_printf(Perl_debug_log, "NV%s\n", s);
4795	break;
4796	case SVt_RV:
4797	PerlIO_printf(Perl_debug_log, "RV%s\n", s);
4798	break;
4799	case SVt_PV:
4800	PerlIO_printf(Perl_debug_log, "PV%s\n", s);
4801	break;
4802	case SVt_PVIV:
4803	PerlIO_printf(Perl_debug_log, "PVIV%s\n", s);
4804	break;
4805	case SVt_PVNV:
4806	PerlIO_printf(Perl_debug_log, "PVNV%s\n", s);
4807	break;
4808	case SVt_PVBM:
4809	PerlIO_printf(Perl_debug_log, "PVBM%s\n", s);
4810	break;
4811	case SVt_PVMG:
4812	PerlIO_printf(Perl_debug_log, "PVMG%s\n", s);
4813	break;
4814	case SVt_PVLV:
4815	PerlIO_printf(Perl_debug_log, "PVLV%s\n", s);
4816	break;
4817	case SVt_PVAV:
4818	PerlIO_printf(Perl_debug_log, "PVAV%s\n", s);
4819	break;
4820	case SVt_PVHV:
4821	PerlIO_printf(Perl_debug_log, "PVHV%s\n", s);
4822	break;
4823	case SVt_PVCV:
4824	PerlIO_printf(Perl_debug_log, "PVCV%s\n", s);
4825	break;
4826	case SVt_PVGV:
4827	PerlIO_printf(Perl_debug_log, "PVGV%s\n", s);
4828	break;
4829	case SVt_PVFM:
4830	PerlIO_printf(Perl_debug_log, "PVFM%s\n", s);
4831	break;
4832	case SVt_PVIO:
4833	PerlIO_printf(Perl_debug_log, "PVIO%s\n", s);
4834	break;
4835	default:
4836	PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s);
4837	return;
4838	}
4839	if (type >= SVt_PVIV \|\| type == SVt_IV)
4840	PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv));
4841	if (type >= SVt_PVNV \|\| type == SVt_NV) {
4842	SET_NUMERIC_STANDARD();
4843	PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
4844	}
4845	if (SvROK(sv)) {
4846	PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
4847	sv_dump(SvRV(sv));
4848	return;
4849	}
4850	if (type < SVt_PV)
4851	return;
4852	if (type <= SVt_PVLV) {
4853	if (SvPVX(sv))
4854	PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n",
4855	(long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv));
4856	else
4857	PerlIO_printf(Perl_debug_log, " PV = 0\n");
4858	}
4859	if (type >= SVt_PVMG) {
4860	if (SvMAGIC(sv)) {
4861	PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
4862	}
4863	if (SvSTASH(sv))
4864	PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
4865	}
4866	switch (type) {
4867	case SVt_PVLV:
4868	PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv));
4869	PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv));
4870	PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv));
4871	PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv));
4872	sv_dump(LvTARG(sv));
4873	break;
4874	case SVt_PVAV:
4875	PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
4876	PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
4877	PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv));
4878	PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv));
4879	PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
4880	flags = AvFLAGS(sv);
4881	sv_setpv(d, "");
4882	if (flags & AVf_REAL) sv_catpv(d, ",REAL");
4883	if (flags & AVf_REIFY) sv_catpv(d, ",REIFY");
4884	if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
4885	PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n",
4886	SvCUR(d) ? SvPVX(d) + 1 : "");
4887	break;
4888	case SVt_PVHV:
4889	PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));
4890	PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv));
4891	PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv));
4892	PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv));
4893	PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv));
4894	PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv));
4895	if (HvPMROOT(sv))
4896	PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
4897	if (HvNAME(sv))
4898	PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
4899	break;
4900	case SVt_PVCV:
4901	if (SvPOK(sv))
4902	PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na));
4903	/* FALL THROUGH */
4904	case SVt_PVFM:
4905	PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv));
4906	PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv));
4907	PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv));
4908	PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv));
4909	PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
4910	PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv));
4911	if (CvGV(sv) && GvNAME(CvGV(sv))) {
4912	PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv)));
4913	} else {
4914	PerlIO_printf(Perl_debug_log, "\n");
4915	}
4916	PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
4917	PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));
4918	PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
4919	PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
4920	if (type == SVt_PVFM)
4921	PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
4922	break;
4923	case SVt_PVGV:
4924	PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv));
4925	PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv));
4926	PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv)));
4927	PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv));
4928	PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv));
4929	PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv));
4930	PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv));
4931	PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv));
4932	PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv));
4933	PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv));
4934	PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv));
4935	PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
4936	PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
4937	PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv));
4938	PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv));
4939	PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv));
4940	break;
4941	case SVt_PVIO:
4942	PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv));
4943	PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv));
4944	PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv));
4945	PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv));
4946	PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv));
4947	PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
4948	PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
4949	PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
4950	PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
4951	PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
4952	PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
4953	PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
4954	PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
4955	PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
4956	PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv));
4957	PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
4958	break;
4959	}
4960	}
4961	#else
4962	void
4963	sv_dump(sv)
4964	SV* sv;
4965	{
4966	}
4967	#endif

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

Download in other formats: