Context Navigation

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

Visit:

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

Line
1	/* util.c
2	*
3	* Copyright (c) 1991-2000, Larry Wall
4	*
5	* You may distribute under the terms of either the GNU General Public
6	* License or the Artistic License, as specified in the README file.
7	*
8	*/
9
10	/*
11	* "Very useful, no doubt, that was to Saruman; yet it seems that he was
12	* not content." --Gandalf
13	*/
14
15	#include "EXTERN.h"
16	#define PERL_IN_UTIL_C
17	#include "perl.h"
18
19	#if !defined(NSIG) \|\| defined(M_UNIX) \|\| defined(M_XENIX)
20	#include <signal.h>
21	#endif
22
23	#ifndef SIG_ERR
24	# define SIG_ERR ((Sighandler_t) -1)
25	#endif
26
27	/* XXX If this causes problems, set i_unistd=undef in the hint file. */
28	#ifdef I_UNISTD
29	# include <unistd.h>
30	#endif
31
32	#ifdef I_VFORK
33	# include <vfork.h>
34	#endif
35
36	/* Put this after #includes because fork and vfork prototypes may
37	conflict.
38	*/
39	#ifndef HAS_VFORK
40	# define vfork fork
41	#endif
42
43	#ifdef I_SYS_WAIT
44	# include <sys/wait.h>
45	#endif
46
47	#ifdef I_LOCALE
48	# include <locale.h>
49	#endif
50
51	#define FLUSH
52
53	#ifdef LEAKTEST
54
55	long xcount[MAXXCOUNT];
56	long lastxcount[MAXXCOUNT];
57	long xycount[MAXXCOUNT][MAXYCOUNT];
58	long lastxycount[MAXXCOUNT][MAXYCOUNT];
59
60	#endif
61
62	#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
63	# define FD_CLOEXEC 1 /* NeXT needs this */
64	#endif
65
66	/* paranoid version of system's malloc() */
67
68	/* NOTE: Do not call the next three routines directly. Use the macros
69	* in handy.h, so that we can easily redefine everything to do tracking of
70	* allocated hunks back to the original New to track down any memory leaks.
71	* XXX This advice seems to be widely ignored :-( --AD August 1996.
72	*/
73
74	Malloc_t
75	Perl_safesysmalloc(MEM_SIZE size)
76	{
77	dTHX;
78	Malloc_t ptr;
79	#ifdef HAS_64K_LIMIT
80	if (size > 0xffff) {
81	PerlIO_printf(Perl_error_log,
82	"Allocation too large: %lx\n", size) FLUSH;
83	my_exit(1);
84	}
85	#endif /* HAS_64K_LIMIT */
86	#ifdef DEBUGGING
87	if ((long)size < 0)
88	Perl_croak_nocontext("panic: malloc");
89	#endif
90	ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
91	PERL_ALLOC_CHECK(ptr);
92	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
93	if (ptr != Nullch)
94	return ptr;
95	else if (PL_nomemok)
96	return Nullch;
97	else {
98	PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
99	my_exit(1);
100	return Nullch;
101	}
102	/NOTREACHED/
103	}
104
105	/* paranoid version of system's realloc() */
106
107	Malloc_t
108	Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
109	{
110	dTHX;
111	Malloc_t ptr;
112	#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
113	Malloc_t PerlMem_realloc();
114	#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
115
116	#ifdef HAS_64K_LIMIT
117	if (size > 0xffff) {
118	PerlIO_printf(Perl_error_log,
119	"Reallocation too large: %lx\n", size) FLUSH;
120	my_exit(1);
121	}
122	#endif /* HAS_64K_LIMIT */
123	if (!size) {
124	safesysfree(where);
125	return NULL;
126	}
127
128	if (!where)
129	return safesysmalloc(size);
130	#ifdef DEBUGGING
131	if ((long)size < 0)
132	Perl_croak_nocontext("panic: realloc");
133	#endif
134	ptr = PerlMem_realloc(where,size);
135	PERL_ALLOC_CHECK(ptr);
136
137	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
138	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
139
140	if (ptr != Nullch)
141	return ptr;
142	else if (PL_nomemok)
143	return Nullch;
144	else {
145	PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
146	my_exit(1);
147	return Nullch;
148	}
149	/NOTREACHED/
150	}
151
152	/* safe version of system's free() */
153
154	Free_t
155	Perl_safesysfree(Malloc_t where)
156	{
157	#ifdef PERL_IMPLICIT_SYS
158	dTHX;
159	#endif
160	DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
161	if (where) {
162	/SUPPRESS 701/
163	PerlMem_free(where);
164	}
165	}
166
167	/* safe version of system's calloc() */
168
169	Malloc_t
170	Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
171	{
172	dTHX;
173	Malloc_t ptr;
174
175	#ifdef HAS_64K_LIMIT
176	if (size * count > 0xffff) {
177	PerlIO_printf(Perl_error_log,
178	"Allocation too large: %lx\n", size * count) FLUSH;
179	my_exit(1);
180	}
181	#endif /* HAS_64K_LIMIT */
182	#ifdef DEBUGGING
183	if ((long)size < 0 \|\| (long)count < 0)
184	Perl_croak_nocontext("panic: calloc");
185	#endif
186	size *= count;
187	ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
188	PERL_ALLOC_CHECK(ptr);
189	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
190	if (ptr != Nullch) {
191	memset((void*)ptr, 0, size);
192	return ptr;
193	}
194	else if (PL_nomemok)
195	return Nullch;
196	else {
197	PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
198	my_exit(1);
199	return Nullch;
200	}
201	/NOTREACHED/
202	}
203
204	#ifdef LEAKTEST
205
206	struct mem_test_strut {
207	union {
208	long type;
209	char c[2];
210	} u;
211	long size;
212	};
213
214	# define ALIGN sizeof(struct mem_test_strut)
215
216	# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
217	# define typeof_chunk(ch) \
218	(((struct mem_test_strut) (ch))->u.c[0] + ((struct mem_test_strut) (ch))->u.c[1]*100)
219	# define set_typeof_chunk(ch,t) \
220	(((struct mem_test_strut) (ch))->u.c[0] = t % 100, ((struct mem_test_strut) (ch))->u.c[1] = t / 100)
221	#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
222	? MAXYCOUNT - 1 \
223	: ( (size) > 40 \
224	? ((size) - 1)/8 + 5 \
225	: ((size) - 1)/4))
226
227	Malloc_t
228	Perl_safexmalloc(I32 x, MEM_SIZE size)
229	{
230	register char* where = (char*)safemalloc(size + ALIGN);
231
232	xcount[x] += size;
233	xycount[x][SIZE_TO_Y(size)]++;
234	set_typeof_chunk(where, x);
235	sizeof_chunk(where) = size;
236	return (Malloc_t)(where + ALIGN);
237	}
238
239	Malloc_t
240	Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
241	{
242	char where = (char)wh;
243
244	if (!wh)
245	return safexmalloc(0,size);
246
247	{
248	MEM_SIZE old = sizeof_chunk(where - ALIGN);
249	int t = typeof_chunk(where - ALIGN);
250	register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
251
252	xycount[t][SIZE_TO_Y(old)]--;
253	xycount[t][SIZE_TO_Y(size)]++;
254	xcount[t] += size - old;
255	sizeof_chunk(new) = size;
256	return (Malloc_t)(new + ALIGN);
257	}
258	}
259
260	void
261	Perl_safexfree(Malloc_t wh)
262	{
263	I32 x;
264	char where = (char)wh;
265	MEM_SIZE size;
266
267	if (!where)
268	return;
269	where -= ALIGN;
270	size = sizeof_chunk(where);
271	x = where[0] + 100 * where[1];
272	xcount[x] -= size;
273	xycount[x][SIZE_TO_Y(size)]--;
274	safefree(where);
275	}
276
277	Malloc_t
278	Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
279	{
280	register char * where = (char)safexmalloc(x, size count + ALIGN);
281	xcount[x] += size;
282	xycount[x][SIZE_TO_Y(size)]++;
283	memset((void)(where + ALIGN), 0, size count);
284	set_typeof_chunk(where, x);
285	sizeof_chunk(where) = size;
286	return (Malloc_t)(where + ALIGN);
287	}
288
289	STATIC void
290	S_xstat(pTHX_ int flag)
291	{
292	register I32 i, j, total = 0;
293	I32 subtot[MAXYCOUNT];
294
295	for (j = 0; j < MAXYCOUNT; j++) {
296	subtot[j] = 0;
297	}
298
299	PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
300	for (i = 0; i < MAXXCOUNT; i++) {
301	total += xcount[i];
302	for (j = 0; j < MAXYCOUNT; j++) {
303	subtot[j] += xycount[i][j];
304	}
305	if (flag == 0
306	? xcount[i] /* Have something */
307	: (flag == 2
308	? xcount[i] != lastxcount[i] /* Changed */
309	: xcount[i] > lastxcount[i])) { /* Growed */
310	PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
311	flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
312	lastxcount[i] = xcount[i];
313	for (j = 0; j < MAXYCOUNT; j++) {
314	if ( flag == 0
315	? xycount[i][j] /* Have something */
316	: (flag == 2
317	? xycount[i][j] != lastxycount[i][j] /* Changed */
318	: xycount[i][j] > lastxycount[i][j])) { /* Growed */
319	PerlIO_printf(Perl_debug_log,"%3ld ",
320	flag == 2
321	? xycount[i][j] - lastxycount[i][j]
322	: xycount[i][j]);
323	lastxycount[i][j] = xycount[i][j];
324	} else {
325	PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]);
326	}
327	}
328	PerlIO_printf(Perl_debug_log, "\n");
329	}
330	}
331	if (flag != 2) {
332	PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
333	for (j = 0; j < MAXYCOUNT; j++) {
334	if (subtot[j]) {
335	PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
336	} else {
337	PerlIO_printf(Perl_debug_log, " . ");
338	}
339	}
340	PerlIO_printf(Perl_debug_log, "\n");
341	}
342	}
343
344	#endif /* LEAKTEST */
345
346	/* copy a string up to some (non-backslashed) delimiter, if any */
347
348	char *
349	Perl_delimcpy(pTHX_ register char to, register char toend, register char from, register char fromend, register int delim, I32 *retlen)
350	{
351	register I32 tolen;
352	for (tolen = 0; from < fromend; from++, tolen++) {
353	if (*from == '\\') {
354	if (from[1] == delim)
355	from++;
356	else {
357	if (to < toend)
358	to++ = from;
359	tolen++;
360	from++;
361	}
362	}
363	else if (*from == delim)
364	break;
365	if (to < toend)
366	to++ = from;
367	}
368	if (to < toend)
369	*to = '\0';
370	*retlen = tolen;
371	return from;
372	}
373
374	/* return ptr to little string in big string, NULL if not found */
375	/* This routine was donated by Corey Satten. */
376
377	char *
378	Perl_instr(pTHX_ register const char big, register const char little)
379	{
380	register const char s, x;
381	register I32 first;
382
383	if (!little)
384	return (char*)big;
385	first = *little++;
386	if (!first)
387	return (char*)big;
388	while (*big) {
389	if (*big++ != first)
390	continue;
391	for (x=big,s=little; s; /*/ ) {
392	if (!*x)
393	return Nullch;
394	if (s++ != x++) {
395	s--;
396	break;
397	}
398	}
399	if (!*s)
400	return (char*)(big-1);
401	}
402	return Nullch;
403	}
404
405	/* same as instr but allow embedded nulls */
406
407	char *
408	Perl_ninstr(pTHX_ register const char big, register const char bigend, const char little, const char lend)
409	{
410	register const char s, x;
411	register I32 first = *little;
412	register const char *littleend = lend;
413
414	if (!first && little >= littleend)
415	return (char*)big;
416	if (bigend - big < littleend - little)
417	return Nullch;
418	bigend -= littleend - little++;
419	while (big <= bigend) {
420	if (*big++ != first)
421	continue;
422	for (x=big,s=little; s < littleend; /**/ ) {
423	if (s++ != x++) {
424	s--;
425	break;
426	}
427	}
428	if (s >= littleend)
429	return (char*)(big-1);
430	}
431	return Nullch;
432	}
433
434	/* reverse of the above--find last substring */
435
436	char *
437	Perl_rninstr(pTHX_ register const char big, const char bigend, const char little, const char lend)
438	{
439	register const char *bigbeg;
440	register const char s, x;
441	register I32 first = *little;
442	register const char *littleend = lend;
443
444	if (!first && little >= littleend)
445	return (char*)bigend;
446	bigbeg = big;
447	big = bigend - (littleend - little++);
448	while (big >= bigbeg) {
449	if (*big-- != first)
450	continue;
451	for (x=big+2,s=little; s < littleend; /**/ ) {
452	if (s++ != x++) {
453	s--;
454	break;
455	}
456	}
457	if (s >= littleend)
458	return (char*)(big+1);
459	}
460	return Nullch;
461	}
462
463	/*
464	* Set up for a new ctype locale.
465	*/
466	void
467	Perl_new_ctype(pTHX_ const char *newctype)
468	{
469	#ifdef USE_LOCALE_CTYPE
470
471	int i;
472
473	for (i = 0; i < 256; i++) {
474	if (isUPPER_LC(i))
475	PL_fold_locale[i] = toLOWER_LC(i);
476	else if (isLOWER_LC(i))
477	PL_fold_locale[i] = toUPPER_LC(i);
478	else
479	PL_fold_locale[i] = i;
480	}
481
482	#endif /* USE_LOCALE_CTYPE */
483	}
484
485	/*
486	* Set up for a new collation locale.
487	*/
488	void
489	Perl_new_collate(pTHX_ const char *newcoll)
490	{
491	#ifdef USE_LOCALE_COLLATE
492
493	if (! newcoll) {
494	if (PL_collation_name) {
495	++PL_collation_ix;
496	Safefree(PL_collation_name);
497	PL_collation_name = NULL;
498	PL_collation_standard = TRUE;
499	PL_collxfrm_base = 0;
500	PL_collxfrm_mult = 2;
501	}
502	return;
503	}
504
505	if (! PL_collation_name \|\| strNE(PL_collation_name, newcoll)) {
506	++PL_collation_ix;
507	Safefree(PL_collation_name);
508	PL_collation_name = savepv(newcoll);
509	PL_collation_standard = (strEQ(newcoll, "C") \|\| strEQ(newcoll, "POSIX"));
510
511	{
512	/* 2: at most so many chars ('a', 'b'). */
513	/* 50: surely no system expands a char more. */
514	#define XFRMBUFSIZE (2 * 50)
515	char xbuf[XFRMBUFSIZE];
516	Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
517	Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
518	SSize_t mult = fb - fa;
519	if (mult < 1)
520	Perl_croak(aTHX_ "strxfrm() gets absurd");
521	PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
522	PL_collxfrm_mult = mult;
523	}
524	}
525
526	#endif /* USE_LOCALE_COLLATE */
527	}
528
529	void
530	Perl_set_numeric_radix(pTHX)
531	{
532	#ifdef USE_LOCALE_NUMERIC
533	# ifdef HAS_LOCALECONV
534	struct lconv* lc;
535
536	lc = localeconv();
537	if (lc && lc->decimal_point)
538	/* We assume that decimal separator aka the radix
539	* character is always a single character. If it
540	* ever is a string, this needs to be rethunk. */
541	PL_numeric_radix = *lc->decimal_point;
542	else
543	PL_numeric_radix = 0;
544	# endif /* HAS_LOCALECONV */
545	#endif /* USE_LOCALE_NUMERIC */
546	}
547
548	/*
549	* Set up for a new numeric locale.
550	*/
551	void
552	Perl_new_numeric(pTHX_ const char *newnum)
553	{
554	#ifdef USE_LOCALE_NUMERIC
555
556	if (! newnum) {
557	if (PL_numeric_name) {
558	Safefree(PL_numeric_name);
559	PL_numeric_name = NULL;
560	PL_numeric_standard = TRUE;
561	PL_numeric_local = TRUE;
562	}
563	return;
564	}
565
566	if (! PL_numeric_name \|\| strNE(PL_numeric_name, newnum)) {
567	Safefree(PL_numeric_name);
568	PL_numeric_name = savepv(newnum);
569	PL_numeric_standard = (strEQ(newnum, "C") \|\| strEQ(newnum, "POSIX"));
570	PL_numeric_local = TRUE;
571	set_numeric_radix();
572	}
573
574	#endif /* USE_LOCALE_NUMERIC */
575	}
576
577	void
578	Perl_set_numeric_standard(pTHX)
579	{
580	#ifdef USE_LOCALE_NUMERIC
581
582	if (! PL_numeric_standard) {
583	setlocale(LC_NUMERIC, "C");
584	PL_numeric_standard = TRUE;
585	PL_numeric_local = FALSE;
586	}
587
588	#endif /* USE_LOCALE_NUMERIC */
589	}
590
591	void
592	Perl_set_numeric_local(pTHX)
593	{
594	#ifdef USE_LOCALE_NUMERIC
595
596	if (! PL_numeric_local) {
597	setlocale(LC_NUMERIC, PL_numeric_name);
598	PL_numeric_standard = FALSE;
599	PL_numeric_local = TRUE;
600	set_numeric_radix();
601	}
602
603	#endif /* USE_LOCALE_NUMERIC */
604	}
605
606	/*
607	* Initialize locale awareness.
608	*/
609	int
610	Perl_init_i18nl10n(pTHX_ int printwarn)
611	{
612	int ok = 1;
613	/* returns
614	* 1 = set ok or not applicable,
615	* 0 = fallback to C locale,
616	* -1 = fallback to C locale failed
617	*/
618
619	#ifdef USE_LOCALE
620
621	#ifdef USE_LOCALE_CTYPE
622	char *curctype = NULL;
623	#endif /* USE_LOCALE_CTYPE */
624	#ifdef USE_LOCALE_COLLATE
625	char *curcoll = NULL;
626	#endif /* USE_LOCALE_COLLATE */
627	#ifdef USE_LOCALE_NUMERIC
628	char *curnum = NULL;
629	#endif /* USE_LOCALE_NUMERIC */
630	#ifdef __GLIBC__
631	char *language = PerlEnv_getenv("LANGUAGE");
632	#endif
633	char *lc_all = PerlEnv_getenv("LC_ALL");
634	char *lang = PerlEnv_getenv("LANG");
635	bool setlocale_failure = FALSE;
636
637	#ifdef LOCALE_ENVIRON_REQUIRED
638
639	/*
640	* Ultrix setlocale(..., "") fails if there are no environment
641	* variables from which to get a locale name.
642	*/
643
644	bool done = FALSE;
645
646	#ifdef LC_ALL
647	if (lang) {
648	if (setlocale(LC_ALL, ""))
649	done = TRUE;
650	else
651	setlocale_failure = TRUE;
652	}
653	if (!setlocale_failure) {
654	#ifdef USE_LOCALE_CTYPE
655	if (! (curctype =
656	setlocale(LC_CTYPE,
657	(!done && (lang \|\| PerlEnv_getenv("LC_CTYPE")))
658	? "" : Nullch)))
659	setlocale_failure = TRUE;
660	#endif /* USE_LOCALE_CTYPE */
661	#ifdef USE_LOCALE_COLLATE
662	if (! (curcoll =
663	setlocale(LC_COLLATE,
664	(!done && (lang \|\| PerlEnv_getenv("LC_COLLATE")))
665	? "" : Nullch)))
666	setlocale_failure = TRUE;
667	#endif /* USE_LOCALE_COLLATE */
668	#ifdef USE_LOCALE_NUMERIC
669	if (! (curnum =
670	setlocale(LC_NUMERIC,
671	(!done && (lang \|\| PerlEnv_getenv("LC_NUMERIC")))
672	? "" : Nullch)))
673	setlocale_failure = TRUE;
674	#endif /* USE_LOCALE_NUMERIC */
675	}
676
677	#endif /* LC_ALL */
678
679	#endif /* !LOCALE_ENVIRON_REQUIRED */
680
681	#ifdef LC_ALL
682	if (! setlocale(LC_ALL, ""))
683	setlocale_failure = TRUE;
684	#endif /* LC_ALL */
685
686	if (!setlocale_failure) {
687	#ifdef USE_LOCALE_CTYPE
688	if (! (curctype = setlocale(LC_CTYPE, "")))
689	setlocale_failure = TRUE;
690	#endif /* USE_LOCALE_CTYPE */
691	#ifdef USE_LOCALE_COLLATE
692	if (! (curcoll = setlocale(LC_COLLATE, "")))
693	setlocale_failure = TRUE;
694	#endif /* USE_LOCALE_COLLATE */
695	#ifdef USE_LOCALE_NUMERIC
696	if (! (curnum = setlocale(LC_NUMERIC, "")))
697	setlocale_failure = TRUE;
698	#endif /* USE_LOCALE_NUMERIC */
699	}
700
701	if (setlocale_failure) {
702	char *p;
703	bool locwarn = (printwarn > 1 \|\|
704	(printwarn &&
705	(!(p = PerlEnv_getenv("PERL_BADLANG")) \|\| atoi(p))));
706
707	if (locwarn) {
708	#ifdef LC_ALL
709
710	PerlIO_printf(Perl_error_log,
711	"perl: warning: Setting locale failed.\n");
712
713	#else /* !LC_ALL */
714
715	PerlIO_printf(Perl_error_log,
716	"perl: warning: Setting locale failed for the categories:\n\t");
717	#ifdef USE_LOCALE_CTYPE
718	if (! curctype)
719	PerlIO_printf(Perl_error_log, "LC_CTYPE ");
720	#endif /* USE_LOCALE_CTYPE */
721	#ifdef USE_LOCALE_COLLATE
722	if (! curcoll)
723	PerlIO_printf(Perl_error_log, "LC_COLLATE ");
724	#endif /* USE_LOCALE_COLLATE */
725	#ifdef USE_LOCALE_NUMERIC
726	if (! curnum)
727	PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
728	#endif /* USE_LOCALE_NUMERIC */
729	PerlIO_printf(Perl_error_log, "\n");
730
731	#endif /* LC_ALL */
732
733	PerlIO_printf(Perl_error_log,
734	"perl: warning: Please check that your locale settings:\n");
735
736	#ifdef __GLIBC__
737	PerlIO_printf(Perl_error_log,
738	"\tLANGUAGE = %c%s%c,\n",
739	language ? '"' : '(',
740	language ? language : "unset",
741	language ? '"' : ')');
742	#endif
743
744	PerlIO_printf(Perl_error_log,
745	"\tLC_ALL = %c%s%c,\n",
746	lc_all ? '"' : '(',
747	lc_all ? lc_all : "unset",
748	lc_all ? '"' : ')');
749
750	{
751	char **e;
752	for (e = environ; *e; e++) {
753	if (strnEQ(*e, "LC_", 3)
754	&& strnNE(*e, "LC_ALL=", 7)
755	&& (p = strchr(*e, '=')))
756	PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
757	(int)(p - e), e, p + 1);
758	}
759	}
760
761	PerlIO_printf(Perl_error_log,
762	"\tLANG = %c%s%c\n",
763	lang ? '"' : '(',
764	lang ? lang : "unset",
765	lang ? '"' : ')');
766
767	PerlIO_printf(Perl_error_log,
768	" are supported and installed on your system.\n");
769	}
770
771	#ifdef LC_ALL
772
773	if (setlocale(LC_ALL, "C")) {
774	if (locwarn)
775	PerlIO_printf(Perl_error_log,
776	"perl: warning: Falling back to the standard locale (\"C\").\n");
777	ok = 0;
778	}
779	else {
780	if (locwarn)
781	PerlIO_printf(Perl_error_log,
782	"perl: warning: Failed to fall back to the standard locale (\"C\").\n");
783	ok = -1;
784	}
785
786	#else /* ! LC_ALL */
787
788	if (0
789	#ifdef USE_LOCALE_CTYPE
790	\|\| !(curctype \|\| setlocale(LC_CTYPE, "C"))
791	#endif /* USE_LOCALE_CTYPE */
792	#ifdef USE_LOCALE_COLLATE
793	\|\| !(curcoll \|\| setlocale(LC_COLLATE, "C"))
794	#endif /* USE_LOCALE_COLLATE */
795	#ifdef USE_LOCALE_NUMERIC
796	\|\| !(curnum \|\| setlocale(LC_NUMERIC, "C"))
797	#endif /* USE_LOCALE_NUMERIC */
798	)
799	{
800	if (locwarn)
801	PerlIO_printf(Perl_error_log,
802	"perl: warning: Cannot fall back to the standard locale (\"C\").\n");
803	ok = -1;
804	}
805
806	#endif /* ! LC_ALL */
807
808	#ifdef USE_LOCALE_CTYPE
809	curctype = setlocale(LC_CTYPE, Nullch);
810	#endif /* USE_LOCALE_CTYPE */
811	#ifdef USE_LOCALE_COLLATE
812	curcoll = setlocale(LC_COLLATE, Nullch);
813	#endif /* USE_LOCALE_COLLATE */
814	#ifdef USE_LOCALE_NUMERIC
815	curnum = setlocale(LC_NUMERIC, Nullch);
816	#endif /* USE_LOCALE_NUMERIC */
817	}
818
819	#ifdef USE_LOCALE_CTYPE
820	new_ctype(curctype);
821	#endif /* USE_LOCALE_CTYPE */
822
823	#ifdef USE_LOCALE_COLLATE
824	new_collate(curcoll);
825	#endif /* USE_LOCALE_COLLATE */
826
827	#ifdef USE_LOCALE_NUMERIC
828	new_numeric(curnum);
829	#endif /* USE_LOCALE_NUMERIC */
830
831	#endif /* USE_LOCALE */
832
833	return ok;
834	}
835
836	/* Backwards compatibility. */
837	int
838	Perl_init_i18nl14n(pTHX_ int printwarn)
839	{
840	return init_i18nl10n(printwarn);
841	}
842
843	#ifdef USE_LOCALE_COLLATE
844
845	/*
846	* mem_collxfrm() is a bit like strxfrm() but with two important
847	* differences. First, it handles embedded NULs. Second, it allocates
848	* a bit more memory than needed for the transformed data itself.
849	* The real transformed data begins at offset sizeof(collationix).
850	* Please see sv_collxfrm() to see how this is used.
851	*/
852	char *
853	Perl_mem_collxfrm(pTHX_ const char s, STRLEN len, STRLEN xlen)
854	{
855	char *xbuf;
856	STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
857
858	/* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
859	/* the +1 is for the terminating NUL. */
860
861	xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
862	New(171, xbuf, xAlloc, char);
863	if (! xbuf)
864	goto bad;
865
866	(U32)xbuf = PL_collation_ix;
867	xout = sizeof(PL_collation_ix);
868	for (xin = 0; xin < len; ) {
869	SSize_t xused;
870
871	for (;;) {
872	xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
873	if (xused == -1)
874	goto bad;
875	if (xused < xAlloc - xout)
876	break;
877	xAlloc = (2 * xAlloc) + 1;
878	Renew(xbuf, xAlloc, char);
879	if (! xbuf)
880	goto bad;
881	}
882
883	xin += strlen(s + xin) + 1;
884	xout += xused;
885
886	/* Embedded NULs are understood but silently skipped
887	* because they make no sense in locale collation. */
888	}
889
890	xbuf[xout] = '\0';
891	*xlen = xout - sizeof(PL_collation_ix);
892	return xbuf;
893
894	bad:
895	Safefree(xbuf);
896	*xlen = 0;
897	return NULL;
898	}
899
900	#endif /* USE_LOCALE_COLLATE */
901
902	#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
903
904	/* As a space optimization, we do not compile tables for strings of length
905	0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
906	special-cased in fbm_instr().
907
908	If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
909
910	/*
911	=for apidoc fbm_compile
912
913	Analyses the string in order to make fast searches on it using fbm_instr()
914	-- the Boyer-Moore algorithm.
915
916	=cut
917	*/
918
919	void
920	Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
921	{
922	register U8 *s;
923	register U8 *table;
924	register U32 i;
925	STRLEN len;
926	I32 rarest = 0;
927	U32 frequency = 256;
928
929	if (flags & FBMcf_TAIL)
930	sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
931	s = (U8*)SvPV_force(sv, len);
932	(void)SvUPGRADE(sv, SVt_PVBM);
933	if (len == 0) /* TAIL might be on on a zero-length string. */
934	return;
935	if (len > 2) {
936	U8 mlen;
937	unsigned char *sb;
938
939	if (len > 255)
940	mlen = 255;
941	else
942	mlen = (U8)len;
943	Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
944	table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
945	s = table - 1 - FBM_TABLE_OFFSET; /* last char */
946	memset((void*)table, mlen, 256);
947	table[-1] = (U8)flags;
948	i = 0;
949	sb = s - mlen + 1; /* first char (maybe) */
950	while (s >= sb) {
951	if (table[*s] == mlen)
952	table[*s] = (U8)i;
953	s--, i++;
954	}
955	}
956	sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
957	SvVALID_on(sv);
958
959	s = (unsigned char)(SvPVX(sv)); / deeper magic */
960	for (i = 0; i < len; i++) {
961	if (PL_freq[s[i]] < frequency) {
962	rarest = i;
963	frequency = PL_freq[s[i]];
964	}
965	}
966	BmRARE(sv) = s[rarest];
967	BmPREVIOUS(sv) = rarest;
968	BmUSEFUL(sv) = 100; /* Initial value */
969	if (flags & FBMcf_TAIL)
970	SvTAIL_on(sv);
971	DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
972	BmRARE(sv),BmPREVIOUS(sv)));
973	}
974
975	/* If SvTAIL(littlestr), it has a fake '\n' at end. */
976	/* If SvTAIL is actually due to \Z or \z, this gives false positives
977	if multiline */
978
979	/*
980	=for apidoc fbm_instr
981
982	Returns the location of the SV in the string delimited by C<str> and
983	C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
984	does not have to be fbm_compiled, but the search will not be as fast
985	then.
986
987	=cut
988	*/
989
990	char *
991	Perl_fbm_instr(pTHX_ unsigned char big, register unsigned char bigend, SV *littlestr, U32 flags)
992	{
993	register unsigned char *s;
994	STRLEN l;
995	register unsigned char little = (unsigned char )SvPV(littlestr,l);
996	register STRLEN littlelen = l;
997	register I32 multiline = flags & FBMrf_MULTILINE;
998
999	if (bigend - big < littlelen) {
1000	if ( SvTAIL(littlestr)
1001	&& (bigend - big == littlelen - 1)
1002	&& (littlelen == 1
1003	\|\| (big == little && memEQ(big, little, littlelen - 1))))
1004	return (char*)big;
1005	return Nullch;
1006	}
1007
1008	if (littlelen <= 2) { /* Special-cased */
1009
1010	if (littlelen == 1) {
1011	if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
1012	/* Know that bigend != big. */
1013	if (bigend[-1] == '\n')
1014	return (char *)(bigend - 1);
1015	return (char *) bigend;
1016	}
1017	s = big;
1018	while (s < bigend) {
1019	if (s == little)
1020	return (char *)s;
1021	s++;
1022	}
1023	if (SvTAIL(littlestr))
1024	return (char *) bigend;
1025	return Nullch;
1026	}
1027	if (!littlelen)
1028	return (char)big; / Cannot be SvTAIL! */
1029
1030	/* littlelen is 2 */
1031	if (SvTAIL(littlestr) && !multiline) {
1032	if (bigend[-1] == '\n' && bigend[-2] == *little)
1033	return (char*)bigend - 2;
1034	if (bigend[-1] == *little)
1035	return (char*)bigend - 1;
1036	return Nullch;
1037	}
1038	{
1039	/* This should be better than FBM if c1 == c2, and almost
1040	as good otherwise: maybe better since we do less indirection.
1041	And we save a lot of memory by caching no table. */
1042	register unsigned char c1 = little[0];
1043	register unsigned char c2 = little[1];
1044
1045	s = big + 1;
1046	bigend--;
1047	if (c1 != c2) {
1048	while (s <= bigend) {
1049	if (s[0] == c2) {
1050	if (s[-1] == c1)
1051	return (char*)s - 1;
1052	s += 2;
1053	continue;
1054	}
1055	next_chars:
1056	if (s[0] == c1) {
1057	if (s == bigend)
1058	goto check_1char_anchor;
1059	if (s[1] == c2)
1060	return (char*)s;
1061	else {
1062	s++;
1063	goto next_chars;
1064	}
1065	}
1066	else
1067	s += 2;
1068	}
1069	goto check_1char_anchor;
1070	}
1071	/* Now c1 == c2 */
1072	while (s <= bigend) {
1073	if (s[0] == c1) {
1074	if (s[-1] == c1)
1075	return (char*)s - 1;
1076	if (s == bigend)
1077	goto check_1char_anchor;
1078	if (s[1] == c1)
1079	return (char*)s;
1080	s += 3;
1081	}
1082	else
1083	s += 2;
1084	}
1085	}
1086	check_1char_anchor: /* One char and anchor! */
1087	if (SvTAIL(littlestr) && (bigend == little))
1088	return (char )bigend; / bigend is already decremented. */
1089	return Nullch;
1090	}
1091	if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
1092	s = bigend - littlelen;
1093	if (s >= big && bigend[-1] == '\n' && s == little
1094	/* Automatically of length > 2 */
1095	&& memEQ((char)s + 1, (char)little + 1, littlelen - 2))
1096	{
1097	return (char)s; / how sweet it is */
1098	}
1099	if (s[1] == *little
1100	&& memEQ((char)s + 2, (char)little + 1, littlelen - 2))
1101	{
1102	return (char)s + 1; / how sweet it is */
1103	}
1104	return Nullch;
1105	}
1106	if (SvTYPE(littlestr) != SVt_PVBM \|\| !SvVALID(littlestr)) {
1107	char b = ninstr((char)big,(char*)bigend,
1108	(char)little, (char)little + littlelen);
1109
1110	if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
1111	/* Chop \n from littlestr: */
1112	s = bigend - littlelen + 1;
1113	if (s == little
1114	&& memEQ((char)s + 1, (char)little + 1, littlelen - 2))
1115	{
1116	return (char*)s;
1117	}
1118	return Nullch;
1119	}
1120	return b;
1121	}
1122
1123	{ /* Do actual FBM. */
1124	register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
1125	register unsigned char *oldlittle;
1126
1127	if (littlelen > bigend - big)
1128	return Nullch;
1129	--littlelen; /* Last char found by table lookup */
1130
1131	s = big + littlelen;
1132	little += littlelen; /* last char */
1133	oldlittle = little;
1134	if (s < bigend) {
1135	register I32 tmp;
1136
1137	top2:
1138	/SUPPRESS 560/
1139	if ((tmp = table[*s])) {
1140	#ifdef POINTERRIGOR
1141	if (bigend - s > tmp) {
1142	s += tmp;
1143	goto top2;
1144	}
1145	s += tmp;
1146	#else
1147	if ((s += tmp) < bigend)
1148	goto top2;
1149	#endif
1150	goto check_end;
1151	}
1152	else { /* less expensive than calling strncmp() */
1153	register unsigned char *olds = s;
1154
1155	tmp = littlelen;
1156
1157	while (tmp--) {
1158	if (--s == --little)
1159	continue;
1160	s = olds + 1; /* here we pay the price for failure */
1161	little = oldlittle;
1162	if (s < bigend) /* fake up continue to outer loop */
1163	goto top2;
1164	goto check_end;
1165	}
1166	return (char *)s;
1167	}
1168	}
1169	check_end:
1170	if ( s == bigend && (table[-1] & FBMcf_TAIL)
1171	&& memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) )
1172	return (char*)bigend - littlelen;
1173	return Nullch;
1174	}
1175	}
1176
1177	/* start_shift, end_shift are positive quantities which give offsets
1178	of ends of some substring of bigstr.
1179	If `last' we want the last occurence.
1180	old_posp is the way of communication between consequent calls if
1181	the next call needs to find the .
1182	The initial *old_posp should be -1.
1183
1184	Note that we take into account SvTAIL, so one can get extra
1185	optimizations if _ALL flag is set.
1186	*/
1187
1188	/* If SvTAIL is actually due to \Z or \z, this gives false positives
1189	if PL_multiline. In fact if !PL_multiline the autoritative answer
1190	is not supported yet. */
1191
1192	char *
1193	Perl_screaminstr(pTHX_ SV bigstr, SV littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
1194	{
1195	dTHR;
1196	register unsigned char s, x;
1197	register unsigned char *big;
1198	register I32 pos;
1199	register I32 previous;
1200	register I32 first;
1201	register unsigned char *little;
1202	register I32 stop_pos;
1203	register unsigned char *littleend;
1204	I32 found = 0;
1205
1206	if (*old_posp == -1
1207	? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
1208	: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
1209	cant_find:
1210	if ( BmRARE(littlestr) == '\n'
1211	&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
1212	little = (unsigned char *)(SvPVX(littlestr));
1213	littleend = little + SvCUR(littlestr);
1214	first = *little++;
1215	goto check_tail;
1216	}
1217	return Nullch;
1218	}
1219
1220	little = (unsigned char *)(SvPVX(littlestr));
1221	littleend = little + SvCUR(littlestr);
1222	first = *little++;
1223	/* The value of pos we can start at: */
1224	previous = BmPREVIOUS(littlestr);
1225	big = (unsigned char *)(SvPVX(bigstr));
1226	/* The value of pos we can stop at: */
1227	stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
1228	if (previous + start_shift > stop_pos) {
1229	if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
1230	goto check_tail;
1231	return Nullch;
1232	}
1233	while (pos < previous + start_shift) {
1234	if (!(pos += PL_screamnext[pos]))
1235	goto cant_find;
1236	}
1237	#ifdef POINTERRIGOR
1238	do {
1239	if (pos >= stop_pos) break;
1240	if (big[pos-previous] != first)
1241	continue;
1242	for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
1243	if (s++ != x++) {
1244	s--;
1245	break;
1246	}
1247	}
1248	if (s == littleend) {
1249	*old_posp = pos;
1250	if (!last) return (char *)(big+pos-previous);
1251	found = 1;
1252	}
1253	} while ( pos += PL_screamnext[pos] );
1254	return (last && found) ? (char )(big+(old_posp)-previous) : Nullch;
1255	#else /* !POINTERRIGOR */
1256	big -= previous;
1257	do {
1258	if (pos >= stop_pos) break;
1259	if (big[pos] != first)
1260	continue;
1261	for (x=big+pos+1,s=little; s < littleend; /**/ ) {
1262	if (s++ != x++) {
1263	s--;
1264	break;
1265	}
1266	}
1267	if (s == littleend) {
1268	*old_posp = pos;
1269	if (!last) return (char *)(big+pos);
1270	found = 1;
1271	}
1272	} while ( pos += PL_screamnext[pos] );
1273	if (last && found)
1274	return (char )(big+(old_posp));
1275	#endif /* POINTERRIGOR */
1276	check_tail:
1277	if (!SvTAIL(littlestr) \|\| (end_shift > 0))
1278	return Nullch;
1279	/* Ignore the trailing "\n". This code is not microoptimized */
1280	big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
1281	stop_pos = littleend - little; /* Actual littlestr len */
1282	if (stop_pos == 0)
1283	return (char*)big;
1284	big -= stop_pos;
1285	if (*big == first
1286	&& ((stop_pos == 1) \|\| memEQ(big + 1, little, stop_pos - 1)))
1287	return (char*)big;
1288	return Nullch;
1289	}
1290
1291	I32
1292	Perl_ibcmp(pTHX_ const char s1, const char s2, register I32 len)
1293	{
1294	register U8 a = (U8 )s1;
1295	register U8 b = (U8 )s2;
1296	while (len--) {
1297	if (a != b && a != PL_fold[b])
1298	return 1;
1299	a++,b++;
1300	}
1301	return 0;
1302	}
1303
1304	I32
1305	Perl_ibcmp_locale(pTHX_ const char s1, const char s2, register I32 len)
1306	{
1307	register U8 a = (U8 )s1;
1308	register U8 b = (U8 )s2;
1309	while (len--) {
1310	if (a != b && a != PL_fold_locale[b])
1311	return 1;
1312	a++,b++;
1313	}
1314	return 0;
1315	}
1316
1317	/* copy a string to a safe spot */
1318
1319	/*
1320	=for apidoc savepv
1321
1322	Copy a string to a safe spot. This does not use an SV.
1323
1324	=cut
1325	*/
1326
1327	char *
1328	Perl_savepv(pTHX_ const char *sv)
1329	{
1330	register char *newaddr;
1331
1332	New(902,newaddr,strlen(sv)+1,char);
1333	(void)strcpy(newaddr,sv);
1334	return newaddr;
1335	}
1336
1337	/* same thing but with a known length */
1338
1339	/*
1340	=for apidoc savepvn
1341
1342	Copy a string to a safe spot. The C<len> indicates number of bytes to
1343	copy. This does not use an SV.
1344
1345	=cut
1346	*/
1347
1348	char *
1349	Perl_savepvn(pTHX_ const char *sv, register I32 len)
1350	{
1351	register char *newaddr;
1352
1353	New(903,newaddr,len+1,char);
1354	Copy(sv,newaddr,len,char); /* might not be null terminated */
1355	newaddr[len] = '\0'; /* is now */
1356	return newaddr;
1357	}
1358
1359	/* the SV for Perl_form() and mess() is not kept in an arena */
1360
1361	STATIC SV *
1362	S_mess_alloc(pTHX)
1363	{
1364	dTHR;
1365	SV *sv;
1366	XPVMG *any;
1367
1368	if (!PL_dirty)
1369	return sv_2mortal(newSVpvn("",0));
1370
1371	if (PL_mess_sv)
1372	return PL_mess_sv;
1373
1374	/* Create as PVMG now, to avoid any upgrading later */
1375	New(905, sv, 1, SV);
1376	Newz(905, any, 1, XPVMG);
1377	SvFLAGS(sv) = SVt_PVMG;
1378	SvANY(sv) = (void*)any;
1379	SvREFCNT(sv) = 1 << 30; /* practically infinite */
1380	PL_mess_sv = sv;
1381	return sv;
1382	}
1383
1384	#if defined(PERL_IMPLICIT_CONTEXT)
1385	char *
1386	Perl_form_nocontext(const char* pat, ...)
1387	{
1388	dTHX;
1389	char *retval;
1390	va_list args;
1391	va_start(args, pat);
1392	retval = vform(pat, &args);
1393	va_end(args);
1394	return retval;
1395	}
1396	#endif /* PERL_IMPLICIT_CONTEXT */
1397
1398	char *
1399	Perl_form(pTHX_ const char* pat, ...)
1400	{
1401	char *retval;
1402	va_list args;
1403	va_start(args, pat);
1404	retval = vform(pat, &args);
1405	va_end(args);
1406	return retval;
1407	}
1408
1409	char *
1410	Perl_vform(pTHX_ const char pat, va_list args)
1411	{
1412	SV *sv = mess_alloc();
1413	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
1414	return SvPVX(sv);
1415	}
1416
1417	#if defined(PERL_IMPLICIT_CONTEXT)
1418	SV *
1419	Perl_mess_nocontext(const char *pat, ...)
1420	{
1421	dTHX;
1422	SV *retval;
1423	va_list args;
1424	va_start(args, pat);
1425	retval = vmess(pat, &args);
1426	va_end(args);
1427	return retval;
1428	}
1429	#endif /* PERL_IMPLICIT_CONTEXT */
1430
1431	SV *
1432	Perl_mess(pTHX_ const char *pat, ...)
1433	{
1434	SV *retval;
1435	va_list args;
1436	va_start(args, pat);
1437	retval = vmess(pat, &args);
1438	va_end(args);
1439	return retval;
1440	}
1441
1442	SV *
1443	Perl_vmess(pTHX_ const char pat, va_list args)
1444	{
1445	SV *sv = mess_alloc();
1446	static char dgd[] = " during global destruction.\n";
1447
1448	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
1449	if (!SvCUR(sv) \|\| *(SvEND(sv) - 1) != '\n') {
1450	dTHR;
1451	if (CopLINE(PL_curcop))
1452	Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1453	CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
1454	if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1455	bool line_mode = (RsSIMPLE(PL_rs) &&
1456	SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1457	Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1458	PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1459	line_mode ? "line" : "chunk",
1460	(IV)IoLINES(GvIOp(PL_last_in_gv)));
1461	}
1462	#ifdef USE_THREADS
1463	if (thr->tid)
1464	Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1465	#endif
1466	sv_catpv(sv, PL_dirty ? dgd : ".\n");
1467	}
1468	return sv;
1469	}
1470
1471	OP *
1472	Perl_vdie(pTHX_ const char* pat, va_list *args)
1473	{
1474	dTHR;
1475	char *message;
1476	int was_in_eval = PL_in_eval;
1477	HV *stash;
1478	GV *gv;
1479	CV *cv;
1480	SV *msv;
1481	STRLEN msglen;
1482
1483	DEBUG_S(PerlIO_printf(Perl_debug_log,
1484	"%p: die: curstack = %p, mainstack = %p\n",
1485	thr, PL_curstack, PL_mainstack));
1486
1487	if (pat) {
1488	msv = vmess(pat, args);
1489	if (PL_errors && SvCUR(PL_errors)) {
1490	sv_catsv(PL_errors, msv);
1491	message = SvPV(PL_errors, msglen);
1492	SvCUR_set(PL_errors, 0);
1493	}
1494	else
1495	message = SvPV(msv,msglen);
1496	}
1497	else {
1498	message = Nullch;
1499	msglen = 0;
1500	}
1501
1502	DEBUG_S(PerlIO_printf(Perl_debug_log,
1503	"%p: die: message = %s\ndiehook = %p\n",
1504	thr, message, PL_diehook));
1505	if (PL_diehook) {
1506	/* sv_2cv might call Perl_croak() */
1507	SV *olddiehook = PL_diehook;
1508	ENTER;
1509	SAVESPTR(PL_diehook);
1510	PL_diehook = Nullsv;
1511	cv = sv_2cv(olddiehook, &stash, &gv, 0);
1512	LEAVE;
1513	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1514	dSP;
1515	SV *msg;
1516
1517	ENTER;
1518	save_re_context();
1519	if (message) {
1520	msg = newSVpvn(message, msglen);
1521	SvREADONLY_on(msg);
1522	SAVEFREESV(msg);
1523	}
1524	else {
1525	msg = ERRSV;
1526	}
1527
1528	PUSHSTACKi(PERLSI_DIEHOOK);
1529	PUSHMARK(SP);
1530	XPUSHs(msg);
1531	PUTBACK;
1532	call_sv((SV*)cv, G_DISCARD);
1533	POPSTACK;
1534	LEAVE;
1535	}
1536	}
1537
1538	PL_restartop = die_where(message, msglen);
1539	DEBUG_S(PerlIO_printf(Perl_debug_log,
1540	"%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1541	thr, PL_restartop, was_in_eval, PL_top_env));
1542	if ((!PL_restartop && was_in_eval) \|\| PL_top_env->je_prev)
1543	JMPENV_JUMP(3);
1544	return PL_restartop;
1545	}
1546
1547	#if defined(PERL_IMPLICIT_CONTEXT)
1548	OP *
1549	Perl_die_nocontext(const char* pat, ...)
1550	{
1551	dTHX;
1552	OP *o;
1553	va_list args;
1554	va_start(args, pat);
1555	o = vdie(pat, &args);
1556	va_end(args);
1557	return o;
1558	}
1559	#endif /* PERL_IMPLICIT_CONTEXT */
1560
1561	OP *
1562	Perl_die(pTHX_ const char* pat, ...)
1563	{
1564	OP *o;
1565	va_list args;
1566	va_start(args, pat);
1567	o = vdie(pat, &args);
1568	va_end(args);
1569	return o;
1570	}
1571
1572	void
1573	Perl_vcroak(pTHX_ const char* pat, va_list *args)
1574	{
1575	dTHR;
1576	char *message;
1577	HV *stash;
1578	GV *gv;
1579	CV *cv;
1580	SV *msv;
1581	STRLEN msglen;
1582
1583	msv = vmess(pat, args);
1584	if (PL_errors && SvCUR(PL_errors)) {
1585	sv_catsv(PL_errors, msv);
1586	message = SvPV(PL_errors, msglen);
1587	SvCUR_set(PL_errors, 0);
1588	}
1589	else
1590	message = SvPV(msv,msglen);
1591
1592	DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1593	PTR2UV(thr), message));
1594
1595	if (PL_diehook) {
1596	/* sv_2cv might call Perl_croak() */
1597	SV *olddiehook = PL_diehook;
1598	ENTER;
1599	SAVESPTR(PL_diehook);
1600	PL_diehook = Nullsv;
1601	cv = sv_2cv(olddiehook, &stash, &gv, 0);
1602	LEAVE;
1603	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1604	dSP;
1605	SV *msg;
1606
1607	ENTER;
1608	save_re_context();
1609	msg = newSVpvn(message, msglen);
1610	SvREADONLY_on(msg);
1611	SAVEFREESV(msg);
1612
1613	PUSHSTACKi(PERLSI_DIEHOOK);
1614	PUSHMARK(SP);
1615	XPUSHs(msg);
1616	PUTBACK;
1617	call_sv((SV*)cv, G_DISCARD);
1618	POPSTACK;
1619	LEAVE;
1620	}
1621	}
1622	if (PL_in_eval) {
1623	PL_restartop = die_where(message, msglen);
1624	JMPENV_JUMP(3);
1625	}
1626	{
1627	#ifdef USE_SFIO
1628	/* SFIO can really mess with your errno */
1629	int e = errno;
1630	#endif
1631	PerlIO *serr = Perl_error_log;
1632
1633	PerlIO_write(serr, message, msglen);
1634	(void)PerlIO_flush(serr);
1635	#ifdef USE_SFIO
1636	errno = e;
1637	#endif
1638	}
1639	my_failure_exit();
1640	}
1641
1642	#if defined(PERL_IMPLICIT_CONTEXT)
1643	void
1644	Perl_croak_nocontext(const char *pat, ...)
1645	{
1646	dTHX;
1647	va_list args;
1648	va_start(args, pat);
1649	vcroak(pat, &args);
1650	/* NOTREACHED */
1651	va_end(args);
1652	}
1653	#endif /* PERL_IMPLICIT_CONTEXT */
1654
1655	/*
1656	=for apidoc croak
1657
1658	This is the XSUB-writer's interface to Perl's C<die> function. Use this
1659	function the same way you use the C C<printf> function. See
1660	C<warn>.
1661
1662	=cut
1663	*/
1664
1665	void
1666	Perl_croak(pTHX_ const char *pat, ...)
1667	{
1668	va_list args;
1669	va_start(args, pat);
1670	vcroak(pat, &args);
1671	/* NOTREACHED */
1672	va_end(args);
1673	}
1674
1675	void
1676	Perl_vwarn(pTHX_ const char* pat, va_list *args)
1677	{
1678	char *message;
1679	HV *stash;
1680	GV *gv;
1681	CV *cv;
1682	SV *msv;
1683	STRLEN msglen;
1684
1685	msv = vmess(pat, args);
1686	message = SvPV(msv, msglen);
1687
1688	if (PL_warnhook) {
1689	/* sv_2cv might call Perl_warn() */
1690	dTHR;
1691	SV *oldwarnhook = PL_warnhook;
1692	ENTER;
1693	SAVESPTR(PL_warnhook);
1694	PL_warnhook = Nullsv;
1695	cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1696	LEAVE;
1697	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1698	dSP;
1699	SV *msg;
1700
1701	ENTER;
1702	save_re_context();
1703	msg = newSVpvn(message, msglen);
1704	SvREADONLY_on(msg);
1705	SAVEFREESV(msg);
1706
1707	PUSHSTACKi(PERLSI_WARNHOOK);
1708	PUSHMARK(SP);
1709	XPUSHs(msg);
1710	PUTBACK;
1711	call_sv((SV*)cv, G_DISCARD);
1712	POPSTACK;
1713	LEAVE;
1714	return;
1715	}
1716	}
1717	{
1718	PerlIO *serr = Perl_error_log;
1719
1720	PerlIO_write(serr, message, msglen);
1721	#ifdef LEAKTEST
1722	DEBUG_L(*message == '!'
1723	? (xstat(message[1]=='!'
1724	? (message[2]=='!' ? 2 : 1)
1725	: 0)
1726	, 0)
1727	: 0);
1728	#endif
1729	(void)PerlIO_flush(serr);
1730	}
1731	}
1732
1733	#if defined(PERL_IMPLICIT_CONTEXT)
1734	void
1735	Perl_warn_nocontext(const char *pat, ...)
1736	{
1737	dTHX;
1738	va_list args;
1739	va_start(args, pat);
1740	vwarn(pat, &args);
1741	va_end(args);
1742	}
1743	#endif /* PERL_IMPLICIT_CONTEXT */
1744
1745	/*
1746	=for apidoc warn
1747
1748	This is the XSUB-writer's interface to Perl's C<warn> function. Use this
1749	function the same way you use the C C<printf> function. See
1750	C<croak>.
1751
1752	=cut
1753	*/
1754
1755	void
1756	Perl_warn(pTHX_ const char *pat, ...)
1757	{
1758	va_list args;
1759	va_start(args, pat);
1760	vwarn(pat, &args);
1761	va_end(args);
1762	}
1763
1764	#if defined(PERL_IMPLICIT_CONTEXT)
1765	void
1766	Perl_warner_nocontext(U32 err, const char *pat, ...)
1767	{
1768	dTHX;
1769	va_list args;
1770	va_start(args, pat);
1771	vwarner(err, pat, &args);
1772	va_end(args);
1773	}
1774	#endif /* PERL_IMPLICIT_CONTEXT */
1775
1776	void
1777	Perl_warner(pTHX_ U32 err, const char* pat,...)
1778	{
1779	va_list args;
1780	va_start(args, pat);
1781	vwarner(err, pat, &args);
1782	va_end(args);
1783	}
1784
1785	void
1786	Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1787	{
1788	dTHR;
1789	char *message;
1790	HV *stash;
1791	GV *gv;
1792	CV *cv;
1793	SV *msv;
1794	STRLEN msglen;
1795
1796	msv = vmess(pat, args);
1797	message = SvPV(msv, msglen);
1798
1799	if (ckDEAD(err)) {
1800	#ifdef USE_THREADS
1801	DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1802	#endif /* USE_THREADS */
1803	if (PL_diehook) {
1804	/* sv_2cv might call Perl_croak() */
1805	SV *olddiehook = PL_diehook;
1806	ENTER;
1807	SAVESPTR(PL_diehook);
1808	PL_diehook = Nullsv;
1809	cv = sv_2cv(olddiehook, &stash, &gv, 0);
1810	LEAVE;
1811	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1812	dSP;
1813	SV *msg;
1814
1815	ENTER;
1816	save_re_context();
1817	msg = newSVpvn(message, msglen);
1818	SvREADONLY_on(msg);
1819	SAVEFREESV(msg);
1820
1821	PUSHSTACKi(PERLSI_DIEHOOK);
1822	PUSHMARK(sp);
1823	XPUSHs(msg);
1824	PUTBACK;
1825	call_sv((SV*)cv, G_DISCARD);
1826	POPSTACK;
1827	LEAVE;
1828	}
1829	}
1830	if (PL_in_eval) {
1831	PL_restartop = die_where(message, msglen);
1832	JMPENV_JUMP(3);
1833	}
1834	{
1835	PerlIO *serr = Perl_error_log;
1836	PerlIO_write(serr, message, msglen);
1837	(void)PerlIO_flush(serr);
1838	}
1839	my_failure_exit();
1840
1841	}
1842	else {
1843	if (PL_warnhook) {
1844	/* sv_2cv might call Perl_warn() */
1845	dTHR;
1846	SV *oldwarnhook = PL_warnhook;
1847	ENTER;
1848	SAVESPTR(PL_warnhook);
1849	PL_warnhook = Nullsv;
1850	cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1851	LEAVE;
1852	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1853	dSP;
1854	SV *msg;
1855
1856	ENTER;
1857	save_re_context();
1858	msg = newSVpvn(message, msglen);
1859	SvREADONLY_on(msg);
1860	SAVEFREESV(msg);
1861
1862	PUSHSTACKi(PERLSI_WARNHOOK);
1863	PUSHMARK(sp);
1864	XPUSHs(msg);
1865	PUTBACK;
1866	call_sv((SV*)cv, G_DISCARD);
1867	POPSTACK;
1868	LEAVE;
1869	return;
1870	}
1871	}
1872	{
1873	PerlIO *serr = Perl_error_log;
1874	PerlIO_write(serr, message, msglen);
1875	#ifdef LEAKTEST
1876	DEBUG_L(xstat());
1877	#endif
1878	(void)PerlIO_flush(serr);
1879	}
1880	}
1881	}
1882
1883	#ifndef VMS /* VMS' my_setenv() is in VMS.c */
1884	#if !defined(WIN32) && !defined(__CYGWIN__)
1885	void
1886	Perl_my_setenv(pTHX_ char nam, char val)
1887	{
1888	#ifndef PERL_USE_SAFE_PUTENV
1889	/* most putenv()s leak, so we manipulate environ directly */
1890	register I32 i=setenv_getix(nam); /* where does it go? */
1891
1892	if (environ == PL_origenviron) { /* need we copy environment? */
1893	I32 j;
1894	I32 max;
1895	char **tmpenv;
1896
1897	/SUPPRESS 530/
1898	for (max = i; environ[max]; max++) ;
1899	tmpenv = (char*)safesysmalloc((max+2) sizeof(char*));
1900	for (j=0; j<max; j++) { /* copy environment */
1901	tmpenv[j] = (char)safesysmalloc((strlen(environ[j])+1)sizeof(char));
1902	strcpy(tmpenv[j], environ[j]);
1903	}
1904	tmpenv[max] = Nullch;
1905	environ = tmpenv; /* tell exec where it is now */
1906	}
1907	if (!val) {
1908	safesysfree(environ[i]);
1909	while (environ[i]) {
1910	environ[i] = environ[i+1];
1911	i++;
1912	}
1913	return;
1914	}
1915	if (!environ[i]) { /* does not exist yet */
1916	environ = (char*)safesysrealloc(environ, (i+2) sizeof(char*));
1917	environ[i+1] = Nullch; /* make sure it's null terminated */
1918	}
1919	else
1920	safesysfree(environ[i]);
1921	environ[i] = (char)safesysmalloc((strlen(nam)+strlen(val)+2) sizeof(char));
1922
1923	(void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
1924
1925	#else /* PERL_USE_SAFE_PUTENV */
1926	char *new_env;
1927
1928	new_env = (char)safesysmalloc((strlen(nam) + strlen(val) + 2) sizeof(char));
1929	(void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
1930	(void)putenv(new_env);
1931	#endif /* PERL_USE_SAFE_PUTENV */
1932	}
1933
1934	#else /* WIN32 \|\| __CYGWIN__ */
1935	#if defined(__CYGWIN__)
1936	/*
1937	* Save environ of perl.exe, currently Cygwin links in separate environ's
1938	* for each exe/dll. Probably should be a member of impure_ptr.
1939	*/
1940	static char ***Perl_main_environ;
1941
1942	EXTERN_C void
1943	Perl_my_setenv_init(char ***penviron)
1944	{
1945	Perl_main_environ = penviron;
1946	}
1947
1948	void
1949	Perl_my_setenv(pTHX_ char nam, char val)
1950	{
1951	/* You can not directly manipulate the environ[] array because
1952	* the routines do some additional work that syncs the Cygwin
1953	* environment with the Windows environment.
1954	*/
1955	char *oldstr = environ[setenv_getix(nam)];
1956
1957	if (!val) {
1958	if (!oldstr)
1959	return;
1960	unsetenv(nam);
1961	safesysfree(oldstr);
1962	return;
1963	}
1964	setenv(nam, val, 1);
1965	environ = Perl_main_environ; / environ realloc can occur in setenv */
1966	if(oldstr && environ[setenv_getix(nam)] != oldstr)
1967	safesysfree(oldstr);
1968	}
1969	#else /* if WIN32 */
1970
1971	void
1972	Perl_my_setenv(pTHX_ char nam,char val)
1973	{
1974
1975	#ifdef USE_WIN32_RTL_ENV
1976
1977	register char *envstr;
1978	STRLEN namlen = strlen(nam);
1979	STRLEN vallen;
1980	char *oldstr = environ[setenv_getix(nam)];
1981
1982	/* putenv() has totally broken semantics in both the Borland
1983	* and Microsoft CRTLs. They either store the passed pointer in
1984	* the environment without making a copy, or make a copy and don't
1985	* free it. And on top of that, they dont free() old entries that
1986	* are being replaced/deleted. This means the caller must
1987	* free any old entries somehow, or we end up with a memory
1988	* leak every time my_setenv() is called. One might think
1989	* one could directly manipulate environ[], like the UNIX code
1990	* above, but direct changes to environ are not allowed when
1991	* calling putenv(), since the RTLs maintain an internal
1992	* copy of environ[]. Bad, bad, bad stink.
1993	* GSAR 97-06-07
1994	*/
1995
1996	if (!val) {
1997	if (!oldstr)
1998	return;
1999	val = "";
2000	vallen = 0;
2001	}
2002	else
2003	vallen = strlen(val);
2004	envstr = (char)safesysmalloc((namlen + vallen + 3) sizeof(char));
2005	(void)sprintf(envstr,"%s=%s",nam,val);
2006	(void)PerlEnv_putenv(envstr);
2007	if (oldstr)
2008	safesysfree(oldstr);
2009	#ifdef _MSC_VER
2010	safesysfree(envstr); /* MSVCRT leaks without this */
2011	#endif
2012
2013	#else /* !USE_WIN32_RTL_ENV */
2014
2015	register char *envstr;
2016	STRLEN len = strlen(nam) + 3;
2017	if (!val) {
2018	val = "";
2019	}
2020	len += strlen(val);
2021	New(904, envstr, len, char);
2022	(void)sprintf(envstr,"%s=%s",nam,val);
2023	(void)PerlEnv_putenv(envstr);
2024	Safefree(envstr);
2025
2026	#endif
2027	}
2028
2029	#endif /* WIN32 */
2030	#endif
2031
2032	I32
2033	Perl_setenv_getix(pTHX_ char *nam)
2034	{
2035	register I32 i, len = strlen(nam);
2036
2037	for (i = 0; environ[i]; i++) {
2038	if (
2039	#ifdef WIN32
2040	strnicmp(environ[i],nam,len) == 0
2041	#else
2042	strnEQ(environ[i],nam,len)
2043	#endif
2044	&& environ[i][len] == '=')
2045	break; /* strnEQ must come first to avoid */
2046	} /* potential SEGV's */
2047	return i;
2048	}
2049
2050	#endif /* !VMS */
2051
2052	#ifdef UNLINK_ALL_VERSIONS
2053	I32
2054	Perl_unlnk(pTHX_ char f) / unlink all versions of a file */
2055	{
2056	I32 i;
2057
2058	for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
2059	return i ? 0 : -1;
2060	}
2061	#endif
2062
2063	/* this is a drop-in replacement for bcopy() */
2064	#if !defined(HAS_BCOPY) \|\| !defined(HAS_SAFE_BCOPY)
2065	char *
2066	Perl_my_bcopy(register const char from,register char to,register I32 len)
2067	{
2068	char *retval = to;
2069
2070	if (from - to >= 0) {
2071	while (len--)
2072	to++ = from++;
2073	}
2074	else {
2075	to += len;
2076	from += len;
2077	while (len--)
2078	(--to) = (--from);
2079	}
2080	return retval;
2081	}
2082	#endif
2083
2084	/* this is a drop-in replacement for memset() */
2085	#ifndef HAS_MEMSET
2086	void *
2087	Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2088	{
2089	char *retval = loc;
2090
2091	while (len--)
2092	*loc++ = ch;
2093	return retval;
2094	}
2095	#endif
2096
2097	/* this is a drop-in replacement for bzero() */
2098	#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2099	char *
2100	Perl_my_bzero(register char *loc, register I32 len)
2101	{
2102	char *retval = loc;
2103
2104	while (len--)
2105	*loc++ = 0;
2106	return retval;
2107	}
2108	#endif
2109
2110	/* this is a drop-in replacement for memcmp() */
2111	#if !defined(HAS_MEMCMP) \|\| !defined(HAS_SANE_MEMCMP)
2112	I32
2113	Perl_my_memcmp(const char s1, const char s2, register I32 len)
2114	{
2115	register U8 a = (U8 )s1;
2116	register U8 b = (U8 )s2;
2117	register I32 tmp;
2118
2119	while (len--) {
2120	if (tmp = a++ - b++)
2121	return tmp;
2122	}
2123	return 0;
2124	}
2125	#endif /* !HAS_MEMCMP \|\| !HAS_SANE_MEMCMP */
2126
2127	#ifndef HAS_VPRINTF
2128
2129	#ifdef USE_CHAR_VSPRINTF
2130	char *
2131	#else
2132	int
2133	#endif
2134	vsprintf(char dest, const char pat, char *args)
2135	{
2136	FILE fakebuf;
2137
2138	fakebuf._ptr = dest;
2139	fakebuf._cnt = 32767;
2140	#ifndef _IOSTRG
2141	#define _IOSTRG 0
2142	#endif
2143	fakebuf._flag = _IOWRT\|_IOSTRG;
2144	_doprnt(pat, args, &fakebuf); /* what a kludge */
2145	(void)putc('\0', &fakebuf);
2146	#ifdef USE_CHAR_VSPRINTF
2147	return(dest);
2148	#else
2149	return 0; /* perl doesn't use return value */
2150	#endif
2151	}
2152
2153	#endif /* HAS_VPRINTF */
2154
2155	#ifdef MYSWAP
2156	#if BYTEORDER != 0x4321
2157	short
2158	Perl_my_swap(pTHX_ short s)
2159	{
2160	#if (BYTEORDER & 1) == 0
2161	short result;
2162
2163	result = ((s & 255) << 8) + ((s >> 8) & 255);
2164	return result;
2165	#else
2166	return s;
2167	#endif
2168	}
2169
2170	long
2171	Perl_my_htonl(pTHX_ long l)
2172	{
2173	union {
2174	long result;
2175	char c[sizeof(long)];
2176	} u;
2177
2178	#if BYTEORDER == 0x1234
2179	u.c[0] = (l >> 24) & 255;
2180	u.c[1] = (l >> 16) & 255;
2181	u.c[2] = (l >> 8) & 255;
2182	u.c[3] = l & 255;
2183	return u.result;
2184	#else
2185	#if ((BYTEORDER - 0x1111) & 0x444) \|\| !(BYTEORDER & 0xf)
2186	Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2187	#else
2188	register I32 o;
2189	register I32 s;
2190
2191	for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2192	u.c[o & 0xf] = (l >> s) & 255;
2193	}
2194	return u.result;
2195	#endif
2196	#endif
2197	}
2198
2199	long
2200	Perl_my_ntohl(pTHX_ long l)
2201	{
2202	union {
2203	long l;
2204	char c[sizeof(long)];
2205	} u;
2206
2207	#if BYTEORDER == 0x1234
2208	u.c[0] = (l >> 24) & 255;
2209	u.c[1] = (l >> 16) & 255;
2210	u.c[2] = (l >> 8) & 255;
2211	u.c[3] = l & 255;
2212	return u.l;
2213	#else
2214	#if ((BYTEORDER - 0x1111) & 0x444) \|\| !(BYTEORDER & 0xf)
2215	Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2216	#else
2217	register I32 o;
2218	register I32 s;
2219
2220	u.l = l;
2221	l = 0;
2222	for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2223	l \|= (u.c[o & 0xf] & 255) << s;
2224	}
2225	return l;
2226	#endif
2227	#endif
2228	}
2229
2230	#endif /* BYTEORDER != 0x4321 */
2231	#endif /* MYSWAP */
2232
2233	/*
2234	* Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2235	* If these functions are defined,
2236	* the BYTEORDER is neither 0x1234 nor 0x4321.
2237	* However, this is not assumed.
2238	* -DWS
2239	*/
2240
2241	#define HTOV(name,type) \
2242	type \
2243	name (register type n) \
2244	{ \
2245	union { \
2246	type value; \
2247	char c[sizeof(type)]; \
2248	} u; \
2249	register I32 i; \
2250	register I32 s; \
2251	for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
2252	u.c[i] = (n >> s) & 0xFF; \
2253	} \
2254	return u.value; \
2255	}
2256
2257	#define VTOH(name,type) \
2258	type \
2259	name (register type n) \
2260	{ \
2261	union { \
2262	type value; \
2263	char c[sizeof(type)]; \
2264	} u; \
2265	register I32 i; \
2266	register I32 s; \
2267	u.value = n; \
2268	n = 0; \
2269	for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
2270	n += (u.c[i] & 0xFF) << s; \
2271	} \
2272	return n; \
2273	}
2274
2275	#if defined(HAS_HTOVS) && !defined(htovs)
2276	HTOV(htovs,short)
2277	#endif
2278	#if defined(HAS_HTOVL) && !defined(htovl)
2279	HTOV(htovl,long)
2280	#endif
2281	#if defined(HAS_VTOHS) && !defined(vtohs)
2282	VTOH(vtohs,short)
2283	#endif
2284	#if defined(HAS_VTOHL) && !defined(vtohl)
2285	VTOH(vtohl,long)
2286	#endif
2287
2288	/* VMS' my_popen() is in VMS.c, same with OS/2. */
2289	#if (!defined(DOSISH) \|\| defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2290	PerlIO *
2291	Perl_my_popen(pTHX_ char cmd, char mode)
2292	{
2293	int p[2];
2294	register I32 This, that;
2295	register Pid_t pid;
2296	SV *sv;
2297	I32 doexec = strNE(cmd,"-");
2298	I32 did_pipes = 0;
2299	int pp[2];
2300
2301	PERL_FLUSHALL_FOR_CHILD;
2302	#ifdef OS2
2303	if (doexec) {
2304	return my_syspopen(cmd,mode);
2305	}
2306	#endif
2307	This = (*mode == 'w');
2308	that = !This;
2309	if (doexec && PL_tainting) {
2310	taint_env();
2311	taint_proper("Insecure %s%s", "EXEC");
2312	}
2313	if (PerlProc_pipe(p) < 0)
2314	return Nullfp;
2315	if (doexec && PerlProc_pipe(pp) >= 0)
2316	did_pipes = 1;
2317	while ((pid = (doexec?vfork():fork())) < 0) {
2318	if (errno != EAGAIN) {
2319	PerlLIO_close(p[This]);
2320	if (did_pipes) {
2321	PerlLIO_close(pp[0]);
2322	PerlLIO_close(pp[1]);
2323	}
2324	if (!doexec)
2325	Perl_croak(aTHX_ "Can't fork");
2326	return Nullfp;
2327	}
2328	sleep(5);
2329	}
2330	if (pid == 0) {
2331	GV* tmpgv;
2332
2333	#undef THIS
2334	#undef THAT
2335	#define THIS that
2336	#define THAT This
2337	PerlLIO_close(p[THAT]);
2338	if (did_pipes) {
2339	PerlLIO_close(pp[0]);
2340	#if defined(HAS_FCNTL) && defined(F_SETFD)
2341	fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2342	#endif
2343	}
2344	if (p[THIS] != (*mode == 'r')) {
2345	PerlLIO_dup2(p[THIS], *mode == 'r');
2346	PerlLIO_close(p[THIS]);
2347	}
2348	#ifndef OS2
2349	if (doexec) {
2350	#if !defined(HAS_FCNTL) \|\| !defined(F_SETFD)
2351	int fd;
2352
2353	#ifndef NOFILE
2354	#define NOFILE 20
2355	#endif
2356	for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2357	if (fd != pp[1])
2358	PerlLIO_close(fd);
2359	#endif
2360	do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */
2361	PerlProc__exit(1);
2362	}
2363	#endif /* defined OS2 */
2364	/SUPPRESS 560/
2365	if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
2366	sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2367	PL_forkprocess = 0;
2368	hv_clear(PL_pidstatus); /* we have no children */
2369	return Nullfp;
2370	#undef THIS
2371	#undef THAT
2372	}
2373	do_execfree(); /* free any memory malloced by child on vfork */
2374	PerlLIO_close(p[that]);
2375	if (did_pipes)
2376	PerlLIO_close(pp[1]);
2377	if (p[that] < p[This]) {
2378	PerlLIO_dup2(p[This], p[that]);
2379	PerlLIO_close(p[This]);
2380	p[This] = p[that];
2381	}
2382	sv = *av_fetch(PL_fdpid,p[This],TRUE);
2383	(void)SvUPGRADE(sv,SVt_IV);
2384	SvIVX(sv) = pid;
2385	PL_forkprocess = pid;
2386	if (did_pipes && pid > 0) {
2387	int errkid;
2388	int n = 0, n1;
2389
2390	while (n < sizeof(int)) {
2391	n1 = PerlLIO_read(pp[0],
2392	(void)(((char)&errkid)+n),
2393	(sizeof(int)) - n);
2394	if (n1 <= 0)
2395	break;
2396	n += n1;
2397	}
2398	PerlLIO_close(pp[0]);
2399	did_pipes = 0;
2400	if (n) { /* Error */
2401	if (n != sizeof(int))
2402	Perl_croak(aTHX_ "panic: kid popen errno read");
2403	errno = errkid; /* Propagate errno from kid */
2404	return Nullfp;
2405	}
2406	}
2407	if (did_pipes)
2408	PerlLIO_close(pp[0]);
2409	return PerlIO_fdopen(p[This], mode);
2410	}
2411	#else
2412	#if defined(atarist) \|\| defined(DJGPP)
2413	FILE *popen();
2414	PerlIO *
2415	Perl_my_popen(pTHX_ char cmd, char mode)
2416	{
2417	/* Needs work for PerlIO ! */
2418	/* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
2419	PERL_FLUSHALL_FOR_CHILD;
2420	return popen(PerlIO_exportFILE(cmd, 0), mode);
2421	}
2422	#endif
2423
2424	#endif /* !DOSISH */
2425
2426	#ifdef DUMP_FDS
2427	void
2428	Perl_dump_fds(pTHX_ char *s)
2429	{
2430	int fd;
2431	struct stat tmpstatbuf;
2432
2433	PerlIO_printf(Perl_debug_log,"%s", s);
2434	for (fd = 0; fd < 32; fd++) {
2435	if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2436	PerlIO_printf(Perl_debug_log," %d",fd);
2437	}
2438	PerlIO_printf(Perl_debug_log,"\n");
2439	}
2440	#endif /* DUMP_FDS */
2441
2442	#ifndef HAS_DUP2
2443	int
2444	dup2(int oldfd, int newfd)
2445	{
2446	#if defined(HAS_FCNTL) && defined(F_DUPFD)
2447	if (oldfd == newfd)
2448	return oldfd;
2449	PerlLIO_close(newfd);
2450	return fcntl(oldfd, F_DUPFD, newfd);
2451	#else
2452	#define DUP2_MAX_FDS 256
2453	int fdtmp[DUP2_MAX_FDS];
2454	I32 fdx = 0;
2455	int fd;
2456
2457	if (oldfd == newfd)
2458	return oldfd;
2459	PerlLIO_close(newfd);
2460	/* good enough for low fd's... */
2461	while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2462	if (fdx >= DUP2_MAX_FDS) {
2463	PerlLIO_close(fd);
2464	fd = -1;
2465	break;
2466	}
2467	fdtmp[fdx++] = fd;
2468	}
2469	while (fdx > 0)
2470	PerlLIO_close(fdtmp[--fdx]);
2471	return fd;
2472	#endif
2473	}
2474	#endif
2475
2476
2477	#ifdef HAS_SIGACTION
2478
2479	Sighandler_t
2480	Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2481	{
2482	struct sigaction act, oact;
2483
2484	act.sa_handler = handler;
2485	sigemptyset(&act.sa_mask);
2486	act.sa_flags = 0;
2487	#ifdef SA_RESTART
2488	act.sa_flags \|= SA_RESTART; /* SVR4, 4.3+BSD */
2489	#endif
2490	#ifdef SA_NOCLDWAIT
2491	if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2492	act.sa_flags \|= SA_NOCLDWAIT;
2493	#endif
2494	if (sigaction(signo, &act, &oact) == -1)
2495	return SIG_ERR;
2496	else
2497	return oact.sa_handler;
2498	}
2499
2500	Sighandler_t
2501	Perl_rsignal_state(pTHX_ int signo)
2502	{
2503	struct sigaction oact;
2504
2505	if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2506	return SIG_ERR;
2507	else
2508	return oact.sa_handler;
2509	}
2510
2511	int
2512	Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2513	{
2514	struct sigaction act;
2515
2516	act.sa_handler = handler;
2517	sigemptyset(&act.sa_mask);
2518	act.sa_flags = 0;
2519	#ifdef SA_RESTART
2520	act.sa_flags \|= SA_RESTART; /* SVR4, 4.3+BSD */
2521	#endif
2522	#ifdef SA_NOCLDWAIT
2523	if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2524	act.sa_flags \|= SA_NOCLDWAIT;
2525	#endif
2526	return sigaction(signo, &act, save);
2527	}
2528
2529	int
2530	Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2531	{
2532	return sigaction(signo, save, (struct sigaction *)NULL);
2533	}
2534
2535	#else /* !HAS_SIGACTION */
2536
2537	Sighandler_t
2538	Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2539	{
2540	return PerlProc_signal(signo, handler);
2541	}
2542
2543	static int sig_trapped;
2544
2545	static
2546	Signal_t
2547	sig_trap(int signo)
2548	{
2549	sig_trapped++;
2550	}
2551
2552	Sighandler_t
2553	Perl_rsignal_state(pTHX_ int signo)
2554	{
2555	Sighandler_t oldsig;
2556
2557	sig_trapped = 0;
2558	oldsig = PerlProc_signal(signo, sig_trap);
2559	PerlProc_signal(signo, oldsig);
2560	if (sig_trapped)
2561	PerlProc_kill(PerlProc_getpid(), signo);
2562	return oldsig;
2563	}
2564
2565	int
2566	Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2567	{
2568	*save = PerlProc_signal(signo, handler);
2569	return (*save == SIG_ERR) ? -1 : 0;
2570	}
2571
2572	int
2573	Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2574	{
2575	return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2576	}
2577
2578	#endif /* !HAS_SIGACTION */
2579
2580	/* VMS' my_pclose() is in VMS.c; same with OS/2 */
2581	#if (!defined(DOSISH) \|\| defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2582	I32
2583	Perl_my_pclose(pTHX_ PerlIO *ptr)
2584	{
2585	Sigsave_t hstat, istat, qstat;
2586	int status;
2587	SV **svp;
2588	Pid_t pid;
2589	Pid_t pid2;
2590	bool close_failed;
2591	int saved_errno;
2592	#ifdef VMS
2593	int saved_vaxc_errno;
2594	#endif
2595	#ifdef WIN32
2596	int saved_win32_errno;
2597	#endif
2598
2599	svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2600	pid = SvIVX(*svp);
2601	SvREFCNT_dec(*svp);
2602	*svp = &PL_sv_undef;
2603	#ifdef OS2
2604	if (pid == -1) { /* Opened by popen. */
2605	return my_syspclose(ptr);
2606	}
2607	#endif
2608	if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2609	saved_errno = errno;
2610	#ifdef VMS
2611	saved_vaxc_errno = vaxc$errno;
2612	#endif
2613	#ifdef WIN32
2614	saved_win32_errno = GetLastError();
2615	#endif
2616	}
2617	#ifdef UTS
2618	if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2619	#endif
2620	rsignal_save(SIGHUP, SIG_IGN, &hstat);
2621	rsignal_save(SIGINT, SIG_IGN, &istat);
2622	rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2623	do {
2624	pid2 = wait4pid(pid, &status, 0);
2625	} while (pid2 == -1 && errno == EINTR);
2626	rsignal_restore(SIGHUP, &hstat);
2627	rsignal_restore(SIGINT, &istat);
2628	rsignal_restore(SIGQUIT, &qstat);
2629	if (close_failed) {
2630	SETERRNO(saved_errno, saved_vaxc_errno);
2631	return -1;
2632	}
2633	return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2634	}
2635	#endif /* !DOSISH */
2636
2637	#if (!defined(DOSISH) \|\| defined(OS2) \|\| defined(WIN32)) && !defined(MACOS_TRADITIONAL)
2638	I32
2639	Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2640	{
2641	SV *sv;
2642	SV** svp;
2643	char spid[TYPE_CHARS(int)];
2644
2645	if (!pid)
2646	return -1;
2647	if (pid > 0) {
2648	sprintf(spid, "%"IVdf, (IV)pid);
2649	svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2650	if (svp && *svp != &PL_sv_undef) {
2651	statusp = SvIVX(svp);
2652	(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2653	return pid;
2654	}
2655	}
2656	else {
2657	HE *entry;
2658
2659	hv_iterinit(PL_pidstatus);
2660	if ((entry = hv_iternext(PL_pidstatus))) {
2661	pid = atoi(hv_iterkey(entry,(I32*)statusp));
2662	sv = hv_iterval(PL_pidstatus,entry);
2663	*statusp = SvIVX(sv);
2664	sprintf(spid, "%"IVdf, (IV)pid);
2665	(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2666	return pid;
2667	}
2668	}
2669	#ifdef HAS_WAITPID
2670	# ifdef HAS_WAITPID_RUNTIME
2671	if (!HAS_WAITPID_RUNTIME)
2672	goto hard_way;
2673	# endif
2674	return PerlProc_waitpid(pid,statusp,flags);
2675	#endif
2676	#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2677	return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2678	#endif
2679	#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) \|\| defined(HAS_WAITPID_RUNTIME)
2680	hard_way:
2681	{
2682	I32 result;
2683	if (flags)
2684	Perl_croak(aTHX_ "Can't do waitpid with flags");
2685	else {
2686	while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2687	pidgone(result,*statusp);
2688	if (result < 0)
2689	*statusp = -1;
2690	}
2691	return result;
2692	}
2693	#endif
2694	}
2695	#endif /* !DOSISH \|\| OS2 \|\| WIN32 */
2696
2697	void
2698	/SUPPRESS 590/
2699	Perl_pidgone(pTHX_ Pid_t pid, int status)
2700	{
2701	register SV *sv;
2702	char spid[TYPE_CHARS(int)];
2703
2704	sprintf(spid, "%"IVdf, (IV)pid);
2705	sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2706	(void)SvUPGRADE(sv,SVt_IV);
2707	SvIVX(sv) = status;
2708	return;
2709	}
2710
2711	#if defined(atarist) \|\| defined(OS2) \|\| defined(DJGPP)
2712	int pclose();
2713	#ifdef HAS_FORK
2714	int /* Cannot prototype with I32
2715	in os2ish.h. */
2716	my_syspclose(PerlIO *ptr)
2717	#else
2718	I32
2719	Perl_my_pclose(pTHX_ PerlIO *ptr)
2720	#endif
2721	{
2722	/* Needs work for PerlIO ! */
2723	FILE *f = PerlIO_findFILE(ptr);
2724	I32 result = pclose(f);
2725	#if defined(DJGPP)
2726	result = (result << 8) & 0xff00;
2727	#endif
2728	PerlIO_releaseFILE(ptr,f);
2729	return result;
2730	}
2731	#endif
2732
2733	void
2734	Perl_repeatcpy(pTHX_ register char to, register const char from, I32 len, register I32 count)
2735	{
2736	register I32 todo;
2737	register const char *frombase = from;
2738
2739	if (len == 1) {
2740	register const char c = *from;
2741	while (count-- > 0)
2742	*to++ = c;
2743	return;
2744	}
2745	while (count-- > 0) {
2746	for (todo = len; todo > 0; todo--) {
2747	to++ = from++;
2748	}
2749	from = frombase;
2750	}
2751	}
2752
2753	U32
2754	Perl_cast_ulong(pTHX_ NV f)
2755	{
2756	long along;
2757
2758	#if CASTFLAGS & 2
2759	# define BIGDOUBLE 2147483648.0
2760	if (f >= BIGDOUBLE)
2761	return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)\|0x80000000;
2762	#endif
2763	if (f >= 0.0)
2764	return (unsigned long)f;
2765	along = (long)f;
2766	return (unsigned long)along;
2767	}
2768	# undef BIGDOUBLE
2769
2770	/* Unfortunately, on some systems the cast_uv() function doesn't
2771	work with the system-supplied definition of ULONG_MAX. The
2772	comparison (f >= ULONG_MAX) always comes out true. It must be a
2773	problem with the compiler constant folding.
2774
2775	In any case, this workaround should be fine on any two's complement
2776	system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2777	ccflags.
2778	--Andy Dougherty <doughera@lafcol.lafayette.edu>
2779	*/
2780
2781	/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2782	of LONG_(MIN/MAX).
2783	-- Kenneth Albanowski <kjahds@kjahds.com>
2784	*/
2785
2786	#ifndef MY_UV_MAX
2787	# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
2788	#endif
2789
2790	I32
2791	Perl_cast_i32(pTHX_ NV f)
2792	{
2793	if (f >= I32_MAX)
2794	return (I32) I32_MAX;
2795	if (f <= I32_MIN)
2796	return (I32) I32_MIN;
2797	return (I32) f;
2798	}
2799
2800	IV
2801	Perl_cast_iv(pTHX_ NV f)
2802	{
2803	if (f >= IV_MAX) {
2804	UV uv;
2805
2806	if (f >= (NV)UV_MAX)
2807	return (IV) UV_MAX;
2808	uv = (UV) f;
2809	return (IV)uv;
2810	}
2811	if (f <= IV_MIN)
2812	return (IV) IV_MIN;
2813	return (IV) f;
2814	}
2815
2816	UV
2817	Perl_cast_uv(pTHX_ NV f)
2818	{
2819	if (f >= MY_UV_MAX)
2820	return (UV) MY_UV_MAX;
2821	if (f < 0) {
2822	IV iv;
2823
2824	if (f < IV_MIN)
2825	return (UV)IV_MIN;
2826	iv = (IV) f;
2827	return (UV) iv;
2828	}
2829	return (UV) f;
2830	}
2831
2832	#ifndef HAS_RENAME
2833	I32
2834	Perl_same_dirent(pTHX_ char a, char b)
2835	{
2836	char *fa = strrchr(a,'/');
2837	char *fb = strrchr(b,'/');
2838	struct stat tmpstatbuf1;
2839	struct stat tmpstatbuf2;
2840	SV *tmpsv = sv_newmortal();
2841
2842	if (fa)
2843	fa++;
2844	else
2845	fa = a;
2846	if (fb)
2847	fb++;
2848	else
2849	fb = b;
2850	if (strNE(a,b))
2851	return FALSE;
2852	if (fa == a)
2853	sv_setpv(tmpsv, ".");
2854	else
2855	sv_setpvn(tmpsv, a, fa - a);
2856	if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2857	return FALSE;
2858	if (fb == b)
2859	sv_setpv(tmpsv, ".");
2860	else
2861	sv_setpvn(tmpsv, b, fb - b);
2862	if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2863	return FALSE;
2864	return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2865	tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2866	}
2867	#endif /* !HAS_RENAME */
2868
2869	NV
2870	Perl_scan_bin(pTHX_ char start, I32 len, I32 retlen)
2871	{
2872	register char *s = start;
2873	register NV rnv = 0.0;
2874	register UV ruv = 0;
2875	register bool seenb = FALSE;
2876	register bool overflowed = FALSE;
2877
2878	for (; len-- && *s; s++) {
2879	if (!(s == '0' \|\| s == '1')) {
2880	if (*s == '_')
2881	continue; /* Note: does not check for __ and the like. */
2882	if (seenb == FALSE && *s == 'b' && ruv == 0) {
2883	/* Disallow 0bbb0b0bbb... */
2884	seenb = TRUE;
2885	continue;
2886	}
2887	else {
2888	dTHR;
2889	if (ckWARN(WARN_DIGIT))
2890	Perl_warner(aTHX_ WARN_DIGIT,
2891	"Illegal binary digit '%c' ignored", *s);
2892	break;
2893	}
2894	}
2895	if (!overflowed) {
2896	register UV xuv = ruv << 1;
2897
2898	if ((xuv >> 1) != ruv) {
2899	dTHR;
2900	overflowed = TRUE;
2901	rnv = (NV) ruv;
2902	if (ckWARN_d(WARN_OVERFLOW))
2903	Perl_warner(aTHX_ WARN_OVERFLOW,
2904	"Integer overflow in binary number");
2905	} else
2906	ruv = xuv \| (*s - '0');
2907	}
2908	if (overflowed) {
2909	rnv *= 2;
2910	/* If an NV has not enough bits in its mantissa to
2911	* represent an UV this summing of small low-order numbers
2912	* is a waste of time (because the NV cannot preserve
2913	* the low-order bits anyway): we could just remember when
2914	* did we overflow and in the end just multiply rnv by the
2915	* right amount. */
2916	rnv += (*s - '0');
2917	}
2918	}
2919	if (!overflowed)
2920	rnv = (NV) ruv;
2921	if ( ( overflowed && rnv > 4294967295.0)
2922	#if UVSIZE > 4
2923	\|\| (!overflowed && ruv > 0xffffffff )
2924	#endif
2925	) {
2926	dTHR;
2927	if (ckWARN(WARN_PORTABLE))
2928	Perl_warner(aTHX_ WARN_PORTABLE,
2929	"Binary number > 0b11111111111111111111111111111111 non-portable");
2930	}
2931	*retlen = s - start;
2932	return rnv;
2933	}
2934
2935	NV
2936	Perl_scan_oct(pTHX_ char start, I32 len, I32 retlen)
2937	{
2938	register char *s = start;
2939	register NV rnv = 0.0;
2940	register UV ruv = 0;
2941	register bool overflowed = FALSE;
2942
2943	for (; len-- && *s; s++) {
2944	if (!(s >= '0' && s <= '7')) {
2945	if (*s == '_')
2946	continue; /* Note: does not check for __ and the like. */
2947	else {
2948	/* Allow \octal to work the DWIM way (that is, stop scanning
2949	* as soon as non-octal characters are seen, complain only iff
2950	* someone seems to want to use the digits eight and nine). */
2951	if (s == '8' \|\| s == '9') {
2952	dTHR;
2953	if (ckWARN(WARN_DIGIT))
2954	Perl_warner(aTHX_ WARN_DIGIT,
2955	"Illegal octal digit '%c' ignored", *s);
2956	}
2957	break;
2958	}
2959	}
2960	if (!overflowed) {
2961	register UV xuv = ruv << 3;
2962
2963	if ((xuv >> 3) != ruv) {
2964	dTHR;
2965	overflowed = TRUE;
2966	rnv = (NV) ruv;
2967	if (ckWARN_d(WARN_OVERFLOW))
2968	Perl_warner(aTHX_ WARN_OVERFLOW,
2969	"Integer overflow in octal number");
2970	} else
2971	ruv = xuv \| (*s - '0');
2972	}
2973	if (overflowed) {
2974	rnv *= 8.0;
2975	/* If an NV has not enough bits in its mantissa to
2976	* represent an UV this summing of small low-order numbers
2977	* is a waste of time (because the NV cannot preserve
2978	* the low-order bits anyway): we could just remember when
2979	* did we overflow and in the end just multiply rnv by the
2980	* right amount of 8-tuples. */
2981	rnv += (NV)(*s - '0');
2982	}
2983	}
2984	if (!overflowed)
2985	rnv = (NV) ruv;
2986	if ( ( overflowed && rnv > 4294967295.0)
2987	#if UVSIZE > 4
2988	\|\| (!overflowed && ruv > 0xffffffff )
2989	#endif
2990	) {
2991	dTHR;
2992	if (ckWARN(WARN_PORTABLE))
2993	Perl_warner(aTHX_ WARN_PORTABLE,
2994	"Octal number > 037777777777 non-portable");
2995	}
2996	*retlen = s - start;
2997	return rnv;
2998	}
2999
3000	NV
3001	Perl_scan_hex(pTHX_ char start, I32 len, I32 retlen)
3002	{
3003	register char *s = start;
3004	register NV rnv = 0.0;
3005	register UV ruv = 0;
3006	register bool seenx = FALSE;
3007	register bool overflowed = FALSE;
3008	char *hexdigit;
3009
3010	for (; len-- && *s; s++) {
3011	hexdigit = strchr((char ) PL_hexdigit, s);
3012	if (!hexdigit) {
3013	if (*s == '_')
3014	continue; /* Note: does not check for __ and the like. */
3015	if (seenx == FALSE && *s == 'x' && ruv == 0) {
3016	/* Disallow 0xxx0x0xxx... */
3017	seenx = TRUE;
3018	continue;
3019	}
3020	else {
3021	dTHR;
3022	if (ckWARN(WARN_DIGIT))
3023	Perl_warner(aTHX_ WARN_DIGIT,
3024	"Illegal hexadecimal digit '%c' ignored", *s);
3025	break;
3026	}
3027	}
3028	if (!overflowed) {
3029	register UV xuv = ruv << 4;
3030
3031	if ((xuv >> 4) != ruv) {
3032	dTHR;
3033	overflowed = TRUE;
3034	rnv = (NV) ruv;
3035	if (ckWARN_d(WARN_OVERFLOW))
3036	Perl_warner(aTHX_ WARN_OVERFLOW,
3037	"Integer overflow in hexadecimal number");
3038	} else
3039	ruv = xuv \| ((hexdigit - PL_hexdigit) & 15);
3040	}
3041	if (overflowed) {
3042	rnv *= 16.0;
3043	/* If an NV has not enough bits in its mantissa to
3044	* represent an UV this summing of small low-order numbers
3045	* is a waste of time (because the NV cannot preserve
3046	* the low-order bits anyway): we could just remember when
3047	* did we overflow and in the end just multiply rnv by the
3048	* right amount of 16-tuples. */
3049	rnv += (NV)((hexdigit - PL_hexdigit) & 15);
3050	}
3051	}
3052	if (!overflowed)
3053	rnv = (NV) ruv;
3054	if ( ( overflowed && rnv > 4294967295.0)
3055	#if UVSIZE > 4
3056	\|\| (!overflowed && ruv > 0xffffffff )
3057	#endif
3058	) {
3059	dTHR;
3060	if (ckWARN(WARN_PORTABLE))
3061	Perl_warner(aTHX_ WARN_PORTABLE,
3062	"Hexadecimal number > 0xffffffff non-portable");
3063	}
3064	*retlen = s - start;
3065	return rnv;
3066	}
3067
3068	char*
3069	Perl_find_script(pTHX_ char scriptname, bool dosearch, char *search_ext, I32 flags)
3070	{
3071	dTHR;
3072	char *xfound = Nullch;
3073	char *xfailed = Nullch;
3074	char tmpbuf[MAXPATHLEN];
3075	register char *s;
3076	I32 len;
3077	int retval;
3078	#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3079	# define SEARCH_EXTS ".bat", ".cmd", NULL
3080	# define MAX_EXT_LEN 4
3081	#endif
3082	#ifdef OS2
3083	# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3084	# define MAX_EXT_LEN 4
3085	#endif
3086	#ifdef VMS
3087	# define SEARCH_EXTS ".pl", ".com", NULL
3088	# define MAX_EXT_LEN 4
3089	#endif
3090	/* additional extensions to try in each dir if scriptname not found */
3091	#ifdef SEARCH_EXTS
3092	char *exts[] = { SEARCH_EXTS };
3093	char **ext = search_ext ? search_ext : exts;
3094	int extidx = 0, i = 0;
3095	char *curext = Nullch;
3096	#else
3097	# define MAX_EXT_LEN 0
3098	#endif
3099
3100	/*
3101	* If dosearch is true and if scriptname does not contain path
3102	* delimiters, search the PATH for scriptname.
3103	*
3104	* If SEARCH_EXTS is also defined, will look for each
3105	* scriptname{SEARCH_EXTS} whenever scriptname is not found
3106	* while searching the PATH.
3107	*
3108	* Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3109	* proceeds as follows:
3110	* If DOSISH or VMSISH:
3111	* + look for ./scriptname{,.foo,.bar}
3112	* + search the PATH for scriptname{,.foo,.bar}
3113	*
3114	* If !DOSISH:
3115	* + look only in the PATH for scriptname{,.foo,.bar} (note
3116	* this will not look in '.' if it's not in the PATH)
3117	*/
3118	tmpbuf[0] = '\0';
3119
3120	#ifdef VMS
3121	# ifdef ALWAYS_DEFTYPES
3122	len = strlen(scriptname);
3123	if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3124	int hasdir, idx = 0, deftypes = 1;
3125	bool seen_dot = 1;
3126
3127	hasdir = !dosearch \|\| (strpbrk(scriptname,":[</") != Nullch) ;
3128	# else
3129	if (dosearch) {
3130	int hasdir, idx = 0, deftypes = 1;
3131	bool seen_dot = 1;
3132
3133	hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
3134	# endif
3135	/* The first time through, just add SEARCH_EXTS to whatever we
3136	* already have, so we can check for default file types. */
3137	while (deftypes \|\|
3138	(!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3139	{
3140	if (deftypes) {
3141	deftypes = 0;
3142	*tmpbuf = '\0';
3143	}
3144	if ((strlen(tmpbuf) + strlen(scriptname)
3145	+ MAX_EXT_LEN) >= sizeof tmpbuf)
3146	continue; /* don't search dir with too-long name */
3147	strcat(tmpbuf, scriptname);
3148	#else /* !VMS */
3149
3150	#ifdef DOSISH
3151	if (strEQ(scriptname, "-"))
3152	dosearch = 0;
3153	if (dosearch) { /* Look in '.' first. */
3154	char *cur = scriptname;
3155	#ifdef SEARCH_EXTS
3156	if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3157	while (ext[i])
3158	if (strEQ(ext[i++],curext)) {
3159	extidx = -1; /* already has an ext */
3160	break;
3161	}
3162	do {
3163	#endif
3164	DEBUG_p(PerlIO_printf(Perl_debug_log,
3165	"Looking for %s\n",cur));
3166	if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3167	&& !S_ISDIR(PL_statbuf.st_mode)) {
3168	dosearch = 0;
3169	scriptname = cur;
3170	#ifdef SEARCH_EXTS
3171	break;
3172	#endif
3173	}
3174	#ifdef SEARCH_EXTS
3175	if (cur == scriptname) {
3176	len = strlen(scriptname);
3177	if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3178	break;
3179	cur = strcpy(tmpbuf, scriptname);
3180	}
3181	} while (extidx >= 0 && ext[extidx] /* try an extension? */
3182	&& strcpy(tmpbuf+len, ext[extidx++]));
3183	#endif
3184	}
3185	#endif
3186
3187	#ifdef MACOS_TRADITIONAL
3188	if (dosearch && !strchr(scriptname, ':') &&
3189	(s = PerlEnv_getenv("Commands")))
3190	#else
3191	if (dosearch && !strchr(scriptname, '/')
3192	#ifdef DOSISH
3193	&& !strchr(scriptname, '\\')
3194	#endif
3195	&& (s = PerlEnv_getenv("PATH")))
3196	#endif
3197	{
3198	bool seen_dot = 0;
3199
3200	PL_bufend = s + strlen(s);
3201	while (s < PL_bufend) {
3202	#ifdef MACOS_TRADITIONAL
3203	s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3204	',',
3205	&len);
3206	#else
3207	#if defined(atarist) \|\| defined(DOSISH)
3208	for (len = 0; *s
3209	# ifdef atarist
3210	&& *s != ','
3211	# endif
3212	&& *s != ';'; len++, s++) {
3213	if (len < sizeof tmpbuf)
3214	tmpbuf[len] = *s;
3215	}
3216	if (len < sizeof tmpbuf)
3217	tmpbuf[len] = '\0';
3218	#else /* ! (atarist \|\| DOSISH) */
3219	s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3220	':',
3221	&len);
3222	#endif /* ! (atarist \|\| DOSISH) */
3223	#endif /* MACOS_TRADITIONAL */
3224	if (s < PL_bufend)
3225	s++;
3226	if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3227	continue; /* don't search dir with too-long name */
3228	#ifdef MACOS_TRADITIONAL
3229	if (len && tmpbuf[len - 1] != ':')
3230	tmpbuf[len++] = ':';
3231	#else
3232	if (len
3233	#if defined(atarist) \|\| defined(__MINT__) \|\| defined(DOSISH)
3234	&& tmpbuf[len - 1] != '/'
3235	&& tmpbuf[len - 1] != '\\'
3236	#endif
3237	)
3238	tmpbuf[len++] = '/';
3239	if (len == 2 && tmpbuf[0] == '.')
3240	seen_dot = 1;
3241	#endif
3242	(void)strcpy(tmpbuf + len, scriptname);
3243	#endif /* !VMS */
3244
3245	#ifdef SEARCH_EXTS
3246	len = strlen(tmpbuf);
3247	if (extidx > 0) /* reset after previous loop */
3248	extidx = 0;
3249	do {
3250	#endif
3251	DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3252	retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3253	if (S_ISDIR(PL_statbuf.st_mode)) {
3254	retval = -1;
3255	}
3256	#ifdef SEARCH_EXTS
3257	} while ( retval < 0 /* not there */
3258	&& extidx>=0 && ext[extidx] /* try an extension? */
3259	&& strcpy(tmpbuf+len, ext[extidx++])
3260	);
3261	#endif
3262	if (retval < 0)
3263	continue;
3264	if (S_ISREG(PL_statbuf.st_mode)
3265	&& cando(S_IRUSR,TRUE,&PL_statbuf)
3266	#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3267	&& cando(S_IXUSR,TRUE,&PL_statbuf)
3268	#endif
3269	)
3270	{
3271	xfound = tmpbuf; /* bingo! */
3272	break;
3273	}
3274	if (!xfailed)
3275	xfailed = savepv(tmpbuf);
3276	}
3277	#ifndef DOSISH
3278	if (!xfound && !seen_dot && !xfailed &&
3279	(PerlLIO_stat(scriptname,&PL_statbuf) < 0
3280	\|\| S_ISDIR(PL_statbuf.st_mode)))
3281	#endif
3282	seen_dot = 1; /* Disable message. */
3283	if (!xfound) {
3284	if (flags & 1) { /* do or die? */
3285	Perl_croak(aTHX_ "Can't %s %s%s%s",
3286	(xfailed ? "execute" : "find"),
3287	(xfailed ? xfailed : scriptname),
3288	(xfailed ? "" : " on PATH"),
3289	(xfailed \|\| seen_dot) ? "" : ", '.' not in PATH");
3290	}
3291	scriptname = Nullch;
3292	}
3293	if (xfailed)
3294	Safefree(xfailed);
3295	scriptname = xfound;
3296	}
3297	return (scriptname ? savepv(scriptname) : Nullch);
3298	}
3299
3300	#ifndef PERL_GET_CONTEXT_DEFINED
3301
3302	void *
3303	Perl_get_context(void)
3304	{
3305	#if defined(USE_THREADS) \|\| defined(USE_ITHREADS)
3306	# ifdef OLD_PTHREADS_API
3307	pthread_addr_t t;
3308	if (pthread_getspecific(PL_thr_key, &t))
3309	Perl_croak_nocontext("panic: pthread_getspecific");
3310	return (void*)t;
3311	# else
3312	# ifdef I_MACH_CTHREADS
3313	return (void*)cthread_data(cthread_self());
3314	# else
3315	return (void*)pthread_getspecific(PL_thr_key);
3316	# endif
3317	# endif
3318	#else
3319	return (void*)NULL;
3320	#endif
3321	}
3322
3323	void
3324	Perl_set_context(void *t)
3325	{
3326	#if defined(USE_THREADS) \|\| defined(USE_ITHREADS)
3327	# ifdef I_MACH_CTHREADS
3328	cthread_set_data(cthread_self(), t);
3329	# else
3330	if (pthread_setspecific(PL_thr_key, t))
3331	Perl_croak_nocontext("panic: pthread_setspecific");
3332	# endif
3333	#endif
3334	}
3335
3336	#endif /* !PERL_GET_CONTEXT_DEFINED */
3337
3338	#ifdef USE_THREADS
3339
3340	#ifdef FAKE_THREADS
3341	/* Very simplistic scheduler for now */
3342	void
3343	schedule(void)
3344	{
3345	thr = thr->i.next_run;
3346	}
3347
3348	void
3349	Perl_cond_init(pTHX_ perl_cond *cp)
3350	{
3351	*cp = 0;
3352	}
3353
3354	void
3355	Perl_cond_signal(pTHX_ perl_cond *cp)
3356	{
3357	perl_os_thread t;
3358	perl_cond cond = *cp;
3359
3360	if (!cond)
3361	return;
3362	t = cond->thread;
3363	/* Insert t in the runnable queue just ahead of us */
3364	t->i.next_run = thr->i.next_run;
3365	thr->i.next_run->i.prev_run = t;
3366	t->i.prev_run = thr;
3367	thr->i.next_run = t;
3368	thr->i.wait_queue = 0;
3369	/* Remove from the wait queue */
3370	*cp = cond->next;
3371	Safefree(cond);
3372	}
3373
3374	void
3375	Perl_cond_broadcast(pTHX_ perl_cond *cp)
3376	{
3377	perl_os_thread t;
3378	perl_cond cond, cond_next;
3379
3380	for (cond = *cp; cond; cond = cond_next) {
3381	t = cond->thread;
3382	/* Insert t in the runnable queue just ahead of us */
3383	t->i.next_run = thr->i.next_run;
3384	thr->i.next_run->i.prev_run = t;
3385	t->i.prev_run = thr;
3386	thr->i.next_run = t;
3387	thr->i.wait_queue = 0;
3388	/* Remove from the wait queue */
3389	cond_next = cond->next;
3390	Safefree(cond);
3391	}
3392	*cp = 0;
3393	}
3394
3395	void
3396	Perl_cond_wait(pTHX_ perl_cond *cp)
3397	{
3398	perl_cond cond;
3399
3400	if (thr->i.next_run == thr)
3401	Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3402
3403	New(666, cond, 1, struct perl_wait_queue);
3404	cond->thread = thr;
3405	cond->next = *cp;
3406	*cp = cond;
3407	thr->i.wait_queue = cond;
3408	/* Remove ourselves from runnable queue */
3409	thr->i.next_run->i.prev_run = thr->i.prev_run;
3410	thr->i.prev_run->i.next_run = thr->i.next_run;
3411	}
3412	#endif /* FAKE_THREADS */
3413
3414	MAGIC *
3415	Perl_condpair_magic(pTHX_ SV *sv)
3416	{
3417	MAGIC *mg;
3418
3419	SvUPGRADE(sv, SVt_PVMG);
3420	mg = mg_find(sv, 'm');
3421	if (!mg) {
3422	condpair_t *cp;
3423
3424	New(53, cp, 1, condpair_t);
3425	MUTEX_INIT(&cp->mutex);
3426	COND_INIT(&cp->owner_cond);
3427	COND_INIT(&cp->cond);
3428	cp->owner = 0;
3429	LOCK_CRED_MUTEX; /* XXX need separate mutex? */
3430	mg = mg_find(sv, 'm');
3431	if (mg) {
3432	/* someone else beat us to initialising it */
3433	UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3434	MUTEX_DESTROY(&cp->mutex);
3435	COND_DESTROY(&cp->owner_cond);
3436	COND_DESTROY(&cp->cond);
3437	Safefree(cp);
3438	}
3439	else {
3440	sv_magic(sv, Nullsv, 'm', 0, 0);
3441	mg = SvMAGIC(sv);
3442	mg->mg_ptr = (char *)cp;
3443	mg->mg_len = sizeof(cp);
3444	UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3445	DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3446	"%p: condpair_magic %p\n", thr, sv));)
3447	}
3448	}
3449	return mg;
3450	}
3451
3452	/*
3453	* Make a new perl thread structure using t as a prototype. Some of the
3454	* fields for the new thread are copied from the prototype thread, t,
3455	* so t should not be running in perl at the time this function is
3456	* called. The use by ext/Thread/Thread.xs in core perl (where t is the
3457	* thread calling new_struct_thread) clearly satisfies this constraint.
3458	*/
3459	struct perl_thread *
3460	Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3461	{
3462	#if !defined(PERL_IMPLICIT_CONTEXT)
3463	struct perl_thread *thr;
3464	#endif
3465	SV *sv;
3466	SV **svp;
3467	I32 i;
3468
3469	sv = newSVpvn("", 0);
3470	SvGROW(sv, sizeof(struct perl_thread) + 1);
3471	SvCUR_set(sv, sizeof(struct perl_thread));
3472	thr = (Thread) SvPVX(sv);
3473	#ifdef DEBUGGING
3474	memset(thr, 0xab, sizeof(struct perl_thread));
3475	PL_markstack = 0;
3476	PL_scopestack = 0;
3477	PL_savestack = 0;
3478	PL_retstack = 0;
3479	PL_dirty = 0;
3480	PL_localizing = 0;
3481	Zero(&PL_hv_fetch_ent_mh, 1, HE);
3482	#else
3483	Zero(thr, 1, struct perl_thread);
3484	#endif
3485
3486	thr->oursv = sv;
3487	init_stacks();
3488
3489	PL_curcop = &PL_compiling;
3490	thr->interp = t->interp;
3491	thr->cvcache = newHV();
3492	thr->threadsv = newAV();
3493	thr->specific = newAV();
3494	thr->errsv = newSVpvn("", 0);
3495	thr->flags = THRf_R_JOINABLE;
3496	MUTEX_INIT(&thr->mutex);
3497
3498	JMPENV_BOOTSTRAP;
3499
3500	PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL\|EVAL_WARNONLY\|EVAL_KEEPERR) */
3501	PL_restartop = 0;
3502
3503	PL_statname = NEWSV(66,0);
3504	PL_errors = newSVpvn("", 0);
3505	PL_maxscream = -1;
3506	PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3507	PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3508	PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3509	PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3510	PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3511	PL_regindent = 0;
3512	PL_reginterp_cnt = 0;
3513	PL_lastscream = Nullsv;
3514	PL_screamfirst = 0;
3515	PL_screamnext = 0;
3516	PL_reg_start_tmp = 0;
3517	PL_reg_start_tmpl = 0;
3518	PL_reg_poscache = Nullch;
3519
3520	/* parent thread's data needs to be locked while we make copy */
3521	MUTEX_LOCK(&t->mutex);
3522
3523	#ifdef PERL_FLEXIBLE_EXCEPTIONS
3524	PL_protect = t->Tprotect;
3525	#endif
3526
3527	PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3528	PL_defstash = t->Tdefstash; /* XXX maybe these should */
3529	PL_curstash = t->Tcurstash; /* always be set to main? */
3530
3531	PL_tainted = t->Ttainted;
3532	PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
3533	PL_nrs = newSVsv(t->Tnrs);
3534	PL_rs = SvREFCNT_inc(PL_nrs);
3535	PL_last_in_gv = Nullgv;
3536	PL_ofslen = t->Tofslen;
3537	PL_ofs = savepvn(t->Tofs, PL_ofslen);
3538	PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3539	PL_chopset = t->Tchopset;
3540	PL_bodytarget = newSVsv(t->Tbodytarget);
3541	PL_toptarget = newSVsv(t->Ttoptarget);
3542	if (t->Tformtarget == t->Ttoptarget)
3543	PL_formtarget = PL_toptarget;
3544	else
3545	PL_formtarget = PL_bodytarget;
3546
3547	/* Initialise all per-thread SVs that the template thread used */
3548	svp = AvARRAY(t->threadsv);
3549	for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3550	if (svp && svp != &PL_sv_undef) {
3551	SV sv = newSVsv(svp);
3552	av_store(thr->threadsv, i, sv);
3553	sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
3554	DEBUG_S(PerlIO_printf(Perl_debug_log,
3555	"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3556	(IV)i, t, thr));
3557	}
3558	}
3559	thr->threadsvp = AvARRAY(thr->threadsv);
3560
3561	MUTEX_LOCK(&PL_threads_mutex);
3562	PL_nthreads++;
3563	thr->tid = ++PL_threadnum;
3564	thr->next = t->next;
3565	thr->prev = t;
3566	t->next = thr;
3567	thr->next->prev = thr;
3568	MUTEX_UNLOCK(&PL_threads_mutex);
3569
3570	/* done copying parent's state */
3571	MUTEX_UNLOCK(&t->mutex);
3572
3573	#ifdef HAVE_THREAD_INTERN
3574	Perl_init_thread_intern(thr);
3575	#endif /* HAVE_THREAD_INTERN */
3576	return thr;
3577	}
3578	#endif /* USE_THREADS */
3579
3580	#ifdef HUGE_VAL
3581	/*
3582	* This hack is to force load of "huge" support from libm.a
3583	* So it is in perl for (say) POSIX to use.
3584	* Needed for SunOS with Sun's 'acc' for example.
3585	*/
3586	NV
3587	Perl_huge(void)
3588	{
3589	return HUGE_VAL;
3590	}
3591	#endif
3592
3593	#ifdef PERL_GLOBAL_STRUCT
3594	struct perl_vars *
3595	Perl_GetVars(pTHX)
3596	{
3597	return &PL_Vars;
3598	}
3599	#endif
3600
3601	char **
3602	Perl_get_op_names(pTHX)
3603	{
3604	return PL_op_name;
3605	}
3606
3607	char **
3608	Perl_get_op_descs(pTHX)
3609	{
3610	return PL_op_desc;
3611	}
3612
3613	char *
3614	Perl_get_no_modify(pTHX)
3615	{
3616	return (char*)PL_no_modify;
3617	}
3618
3619	U32 *
3620	Perl_get_opargs(pTHX)
3621	{
3622	return PL_opargs;
3623	}
3624
3625	PPADDR_t*
3626	Perl_get_ppaddr(pTHX)
3627	{
3628	return &PL_ppaddr;
3629	}
3630
3631	#ifndef HAS_GETENV_LEN
3632	char *
3633	Perl_getenv_len(pTHX_ char env_elem, unsigned long len)
3634	{
3635	char *env_trans = PerlEnv_getenv(env_elem);
3636	if (env_trans)
3637	*len = strlen(env_trans);
3638	return env_trans;
3639	}
3640	#endif
3641
3642
3643	MGVTBL*
3644	Perl_get_vtbl(pTHX_ int vtbl_id)
3645	{
3646	MGVTBL* result = Null(MGVTBL*);
3647
3648	switch(vtbl_id) {
3649	case want_vtbl_sv:
3650	result = &PL_vtbl_sv;
3651	break;
3652	case want_vtbl_env:
3653	result = &PL_vtbl_env;
3654	break;
3655	case want_vtbl_envelem:
3656	result = &PL_vtbl_envelem;
3657	break;
3658	case want_vtbl_sig:
3659	result = &PL_vtbl_sig;
3660	break;
3661	case want_vtbl_sigelem:
3662	result = &PL_vtbl_sigelem;
3663	break;
3664	case want_vtbl_pack:
3665	result = &PL_vtbl_pack;
3666	break;
3667	case want_vtbl_packelem:
3668	result = &PL_vtbl_packelem;
3669	break;
3670	case want_vtbl_dbline:
3671	result = &PL_vtbl_dbline;
3672	break;
3673	case want_vtbl_isa:
3674	result = &PL_vtbl_isa;
3675	break;
3676	case want_vtbl_isaelem:
3677	result = &PL_vtbl_isaelem;
3678	break;
3679	case want_vtbl_arylen:
3680	result = &PL_vtbl_arylen;
3681	break;
3682	case want_vtbl_glob:
3683	result = &PL_vtbl_glob;
3684	break;
3685	case want_vtbl_mglob:
3686	result = &PL_vtbl_mglob;
3687	break;
3688	case want_vtbl_nkeys:
3689	result = &PL_vtbl_nkeys;
3690	break;
3691	case want_vtbl_taint:
3692	result = &PL_vtbl_taint;
3693	break;
3694	case want_vtbl_substr:
3695	result = &PL_vtbl_substr;
3696	break;
3697	case want_vtbl_vec:
3698	result = &PL_vtbl_vec;
3699	break;
3700	case want_vtbl_pos:
3701	result = &PL_vtbl_pos;
3702	break;
3703	case want_vtbl_bm:
3704	result = &PL_vtbl_bm;
3705	break;
3706	case want_vtbl_fm:
3707	result = &PL_vtbl_fm;
3708	break;
3709	case want_vtbl_uvar:
3710	result = &PL_vtbl_uvar;
3711	break;
3712	#ifdef USE_THREADS
3713	case want_vtbl_mutex:
3714	result = &PL_vtbl_mutex;
3715	break;
3716	#endif
3717	case want_vtbl_defelem:
3718	result = &PL_vtbl_defelem;
3719	break;
3720	case want_vtbl_regexp:
3721	result = &PL_vtbl_regexp;
3722	break;
3723	case want_vtbl_regdata:
3724	result = &PL_vtbl_regdata;
3725	break;
3726	case want_vtbl_regdatum:
3727	result = &PL_vtbl_regdatum;
3728	break;
3729	#ifdef USE_LOCALE_COLLATE
3730	case want_vtbl_collxfrm:
3731	result = &PL_vtbl_collxfrm;
3732	break;
3733	#endif
3734	case want_vtbl_amagic:
3735	result = &PL_vtbl_amagic;
3736	break;
3737	case want_vtbl_amagicelem:
3738	result = &PL_vtbl_amagicelem;
3739	break;
3740	case want_vtbl_backref:
3741	result = &PL_vtbl_backref;
3742	break;
3743	}
3744	return result;
3745	}
3746
3747	I32
3748	Perl_my_fflush_all(pTHX)
3749	{
3750	#ifdef FFLUSH_NULL
3751	return PerlIO_flush(NULL);
3752	#else
3753	long open_max = -1;
3754	# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3755	# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3756	open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3757	# else
3758	# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3759	open_max = sysconf(_SC_OPEN_MAX);
3760	# else
3761	# ifdef FOPEN_MAX
3762	open_max = FOPEN_MAX;
3763	# else
3764	# ifdef OPEN_MAX
3765	open_max = OPEN_MAX;
3766	# else
3767	# ifdef _NFILE
3768	open_max = _NFILE;
3769	# endif
3770	# endif
3771	# endif
3772	# endif
3773	# endif
3774	if (open_max > 0) {
3775	long i;
3776	for (i = 0; i < open_max; i++)
3777	if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3778	STDIO_STREAM_ARRAY[i]._file < open_max &&
3779	STDIO_STREAM_ARRAY[i]._flag)
3780	PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3781	return 0;
3782	}
3783	# endif
3784	SETERRNO(EBADF,RMS$_IFI);
3785	return EOF;
3786	#endif
3787	}
3788
3789	NV
3790	Perl_my_atof(pTHX_ const char* s)
3791	{
3792	#ifdef USE_LOCALE_NUMERIC
3793	if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
3794	NV x, y;
3795
3796	x = Perl_atof(s);
3797	SET_NUMERIC_STANDARD();
3798	y = Perl_atof(s);
3799	SET_NUMERIC_LOCAL();
3800	if ((y < 0.0 && y < x) \|\| (y > 0.0 && y > x))
3801	return y;
3802	return x;
3803	}
3804	else
3805	return Perl_atof(s);
3806	#else
3807	return Perl_atof(s);
3808	#endif
3809	}
3810
3811	void
3812	Perl_report_closed_fh(pTHX_ GV gv, IO io, const char func, const char obj)
3813	{
3814	SV *sv;
3815	char *name;
3816
3817	assert(gv);
3818
3819	sv = sv_newmortal();
3820	gv_efullname3(sv, gv, Nullch);
3821	name = SvPVX(sv);
3822
3823	Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
3824
3825	if (io && IoDIRP(io))
3826	Perl_warner(aTHX_ WARN_CLOSED,
3827	"\t(Are you trying to call %s() on dirhandle %s?)\n",
3828	func, name);
3829	}

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

Download in other formats: