Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

util.c@ 3277

Visit:

Last change on this file since 3277 was 3181, checked in by bird, 18 years ago
perl 5.8.8
File size: 113.3 KB

Line
1	/* util.c
2	*
3	* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4	* 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
5	*
6	* You may distribute under the terms of either the GNU General Public
7	* License or the Artistic License, as specified in the README file.
8	*
9	*/
10
11	/*
12	* "Very useful, no doubt, that was to Saruman; yet it seems that he was
13	* not content." --Gandalf
14	*/
15
16	/* This file contains assorted utility routines.
17	* Which is a polite way of saying any stuff that people couldn't think of
18	* a better place for. Amongst other things, it includes the warning and
19	* dieing stuff, plus wrappers for malloc code.
20	*/
21
22	#include "EXTERN.h"
23	#define PERL_IN_UTIL_C
24	#include "perl.h"
25
26	#ifndef PERL_MICRO
27	#include <signal.h>
28	#ifndef SIG_ERR
29	# define SIG_ERR ((Sighandler_t) -1)
30	#endif
31	#endif
32
33	#ifdef __Lynx__
34	/* Missing protos on LynxOS */
35	int putenv(char *);
36	#endif
37
38	#ifdef I_SYS_WAIT
39	# include <sys/wait.h>
40	#endif
41
42	#ifdef HAS_SELECT
43	# ifdef I_SYS_SELECT
44	# include <sys/select.h>
45	# endif
46	#endif
47
48	#define FLUSH
49
50	#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51	# define FD_CLOEXEC 1 /* NeXT needs this */
52	#endif
53
54	/* NOTE: Do not call the next three routines directly. Use the macros
55	* in handy.h, so that we can easily redefine everything to do tracking of
56	* allocated hunks back to the original New to track down any memory leaks.
57	* XXX This advice seems to be widely ignored :-( --AD August 1996.
58	*/
59
60	/* paranoid version of system's malloc() */
61
62	Malloc_t
63	Perl_safesysmalloc(MEM_SIZE size)
64	{
65	dTHX;
66	Malloc_t ptr;
67	#ifdef HAS_64K_LIMIT
68	if (size > 0xffff) {
69	PerlIO_printf(Perl_error_log,
70	"Allocation too large: %lx\n", size) FLUSH;
71	my_exit(1);
72	}
73	#endif /* HAS_64K_LIMIT */
74	#ifdef DEBUGGING
75	if ((long)size < 0)
76	Perl_croak_nocontext("panic: malloc");
77	#endif
78	ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
79	PERL_ALLOC_CHECK(ptr);
80	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
81	if (ptr != Nullch)
82	return ptr;
83	else if (PL_nomemok)
84	return Nullch;
85	else {
86	/* Can't use PerlIO to write as it allocates memory */
87	PerlLIO_write(PerlIO_fileno(Perl_error_log),
88	PL_no_mem, strlen(PL_no_mem));
89	my_exit(1);
90	return Nullch;
91	}
92	/NOTREACHED/
93	}
94
95	/* paranoid version of system's realloc() */
96
97	Malloc_t
98	Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
99	{
100	dTHX;
101	Malloc_t ptr;
102	#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
103	Malloc_t PerlMem_realloc();
104	#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
105
106	#ifdef HAS_64K_LIMIT
107	if (size > 0xffff) {
108	PerlIO_printf(Perl_error_log,
109	"Reallocation too large: %lx\n", size) FLUSH;
110	my_exit(1);
111	}
112	#endif /* HAS_64K_LIMIT */
113	if (!size) {
114	safesysfree(where);
115	return NULL;
116	}
117
118	if (!where)
119	return safesysmalloc(size);
120	#ifdef DEBUGGING
121	if ((long)size < 0)
122	Perl_croak_nocontext("panic: realloc");
123	#endif
124	ptr = (Malloc_t)PerlMem_realloc(where,size);
125	PERL_ALLOC_CHECK(ptr);
126
127	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
128	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
129
130	if (ptr != Nullch)
131	return ptr;
132	else if (PL_nomemok)
133	return Nullch;
134	else {
135	/* Can't use PerlIO to write as it allocates memory */
136	PerlLIO_write(PerlIO_fileno(Perl_error_log),
137	PL_no_mem, strlen(PL_no_mem));
138	my_exit(1);
139	return Nullch;
140	}
141	/NOTREACHED/
142	}
143
144	/* safe version of system's free() */
145
146	Free_t
147	Perl_safesysfree(Malloc_t where)
148	{
149	#ifdef PERL_IMPLICIT_SYS
150	dTHX;
151	#endif
152	DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
153	if (where) {
154	PerlMem_free(where);
155	}
156	}
157
158	/* safe version of system's calloc() */
159
160	Malloc_t
161	Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
162	{
163	dTHX;
164	Malloc_t ptr;
165
166	#ifdef HAS_64K_LIMIT
167	if (size * count > 0xffff) {
168	PerlIO_printf(Perl_error_log,
169	"Allocation too large: %lx\n", size * count) FLUSH;
170	my_exit(1);
171	}
172	#endif /* HAS_64K_LIMIT */
173	#ifdef DEBUGGING
174	if ((long)size < 0 \|\| (long)count < 0)
175	Perl_croak_nocontext("panic: calloc");
176	#endif
177	size *= count;
178	ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
179	PERL_ALLOC_CHECK(ptr);
180	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));
181	if (ptr != Nullch) {
182	memset((void*)ptr, 0, size);
183	return ptr;
184	}
185	else if (PL_nomemok)
186	return Nullch;
187	else {
188	/* Can't use PerlIO to write as it allocates memory */
189	PerlLIO_write(PerlIO_fileno(Perl_error_log),
190	PL_no_mem, strlen(PL_no_mem));
191	my_exit(1);
192	return Nullch;
193	}
194	/NOTREACHED/
195	}
196
197	/* These must be defined when not using Perl's malloc for binary
198	* compatibility */
199
200	#ifndef MYMALLOC
201
202	Malloc_t Perl_malloc (MEM_SIZE nbytes)
203	{
204	dTHXs;
205	return (Malloc_t)PerlMem_malloc(nbytes);
206	}
207
208	Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
209	{
210	dTHXs;
211	return (Malloc_t)PerlMem_calloc(elements, size);
212	}
213
214	Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
215	{
216	dTHXs;
217	return (Malloc_t)PerlMem_realloc(where, nbytes);
218	}
219
220	Free_t Perl_mfree (Malloc_t where)
221	{
222	dTHXs;
223	PerlMem_free(where);
224	}
225
226	#endif
227
228	/* copy a string up to some (non-backslashed) delimiter, if any */
229
230	char *
231	Perl_delimcpy(pTHX_ register char to, register char toend, register char from, register char fromend, register int delim, I32 *retlen)
232	{
233	register I32 tolen;
234	for (tolen = 0; from < fromend; from++, tolen++) {
235	if (*from == '\\') {
236	if (from[1] == delim)
237	from++;
238	else {
239	if (to < toend)
240	to++ = from;
241	tolen++;
242	from++;
243	}
244	}
245	else if (*from == delim)
246	break;
247	if (to < toend)
248	to++ = from;
249	}
250	if (to < toend)
251	*to = '\0';
252	*retlen = tolen;
253	return (char *)from;
254	}
255
256	/* return ptr to little string in big string, NULL if not found */
257	/* This routine was donated by Corey Satten. */
258
259	char *
260	Perl_instr(pTHX_ register const char big, register const char little)
261	{
262	register I32 first;
263
264	if (!little)
265	return (char*)big;
266	first = *little++;
267	if (!first)
268	return (char*)big;
269	while (*big) {
270	register const char s, x;
271	if (*big++ != first)
272	continue;
273	for (x=big,s=little; s; /*/ ) {
274	if (!*x)
275	return Nullch;
276	if (s++ != x++) {
277	s--;
278	break;
279	}
280	}
281	if (!*s)
282	return (char*)(big-1);
283	}
284	return Nullch;
285	}
286
287	/* same as instr but allow embedded nulls */
288
289	char *
290	Perl_ninstr(pTHX_ register const char big, register const char bigend, const char little, const char lend)
291	{
292	register const I32 first = *little;
293	register const char *littleend = lend;
294
295	if (!first && little >= littleend)
296	return (char*)big;
297	if (bigend - big < littleend - little)
298	return Nullch;
299	bigend -= littleend - little++;
300	while (big <= bigend) {
301	register const char s, x;
302	if (*big++ != first)
303	continue;
304	for (x=big,s=little; s < littleend; /**/ ) {
305	if (s++ != x++) {
306	s--;
307	break;
308	}
309	}
310	if (s >= littleend)
311	return (char*)(big-1);
312	}
313	return Nullch;
314	}
315
316	/* reverse of the above--find last substring */
317
318	char *
319	Perl_rninstr(pTHX_ register const char big, const char bigend, const char little, const char lend)
320	{
321	register const char *bigbeg;
322	register const I32 first = *little;
323	register const char *littleend = lend;
324
325	if (!first && little >= littleend)
326	return (char*)bigend;
327	bigbeg = big;
328	big = bigend - (littleend - little++);
329	while (big >= bigbeg) {
330	register const char s, x;
331	if (*big-- != first)
332	continue;
333	for (x=big+2,s=little; s < littleend; /**/ ) {
334	if (s++ != x++) {
335	s--;
336	break;
337	}
338	}
339	if (s >= littleend)
340	return (char*)(big+1);
341	}
342	return Nullch;
343	}
344
345	#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
346
347	/* As a space optimization, we do not compile tables for strings of length
348	0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
349	special-cased in fbm_instr().
350
351	If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
352
353	/*
354	=head1 Miscellaneous Functions
355
356	=for apidoc fbm_compile
357
358	Analyses the string in order to make fast searches on it using fbm_instr()
359	-- the Boyer-Moore algorithm.
360
361	=cut
362	*/
363
364	void
365	Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
366	{
367	register const U8 *s;
368	register U32 i;
369	STRLEN len;
370	I32 rarest = 0;
371	U32 frequency = 256;
372
373	if (flags & FBMcf_TAIL) {
374	MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
375	sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
376	if (mg && mg->mg_len >= 0)
377	mg->mg_len++;
378	}
379	s = (U8*)SvPV_force_mutable(sv, len);
380	(void)SvUPGRADE(sv, SVt_PVBM);
381	if (len == 0) /* TAIL might be on a zero-length string. */
382	return;
383	if (len > 2) {
384	const unsigned char *sb;
385	const U8 mlen = (len>255) ? 255 : (U8)len;
386	register U8 *table;
387
388	Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
389	table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
390	s = table - 1 - FBM_TABLE_OFFSET; /* last char */
391	memset((void*)table, mlen, 256);
392	table[-1] = (U8)flags;
393	i = 0;
394	sb = s - mlen + 1; /* first char (maybe) */
395	while (s >= sb) {
396	if (table[*s] == mlen)
397	table[*s] = (U8)i;
398	s--, i++;
399	}
400	}
401	sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
402	SvVALID_on(sv);
403
404	s = (const unsigned char)(SvPVX_const(sv)); / deeper magic */
405	for (i = 0; i < len; i++) {
406	if (PL_freq[s[i]] < frequency) {
407	rarest = i;
408	frequency = PL_freq[s[i]];
409	}
410	}
411	BmRARE(sv) = s[rarest];
412	BmPREVIOUS(sv) = (U16)rarest;
413	BmUSEFUL(sv) = 100; /* Initial value */
414	if (flags & FBMcf_TAIL)
415	SvTAIL_on(sv);
416	DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
417	BmRARE(sv),BmPREVIOUS(sv)));
418	}
419
420	/* If SvTAIL(littlestr), it has a fake '\n' at end. */
421	/* If SvTAIL is actually due to \Z or \z, this gives false positives
422	if multiline */
423
424	/*
425	=for apidoc fbm_instr
426
427	Returns the location of the SV in the string delimited by C<str> and
428	C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
429	does not have to be fbm_compiled, but the search will not be as fast
430	then.
431
432	=cut
433	*/
434
435	char *
436	Perl_fbm_instr(pTHX_ unsigned char big, register unsigned char bigend, SV *littlestr, U32 flags)
437	{
438	register unsigned char *s;
439	STRLEN l;
440	register const unsigned char *little
441	= (const unsigned char *)SvPV_const(littlestr,l);
442	register STRLEN littlelen = l;
443	register const I32 multiline = flags & FBMrf_MULTILINE;
444
445	if ((STRLEN)(bigend - big) < littlelen) {
446	if ( SvTAIL(littlestr)
447	&& ((STRLEN)(bigend - big) == littlelen - 1)
448	&& (littlelen == 1
449	\|\| (big == little &&
450	memEQ((char )big, (char )little, littlelen - 1))))
451	return (char*)big;
452	return Nullch;
453	}
454
455	if (littlelen <= 2) { /* Special-cased */
456
457	if (littlelen == 1) {
458	if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
459	/* Know that bigend != big. */
460	if (bigend[-1] == '\n')
461	return (char *)(bigend - 1);
462	return (char *) bigend;
463	}
464	s = big;
465	while (s < bigend) {
466	if (s == little)
467	return (char *)s;
468	s++;
469	}
470	if (SvTAIL(littlestr))
471	return (char *) bigend;
472	return Nullch;
473	}
474	if (!littlelen)
475	return (char)big; / Cannot be SvTAIL! */
476
477	/* littlelen is 2 */
478	if (SvTAIL(littlestr) && !multiline) {
479	if (bigend[-1] == '\n' && bigend[-2] == *little)
480	return (char*)bigend - 2;
481	if (bigend[-1] == *little)
482	return (char*)bigend - 1;
483	return Nullch;
484	}
485	{
486	/* This should be better than FBM if c1 == c2, and almost
487	as good otherwise: maybe better since we do less indirection.
488	And we save a lot of memory by caching no table. */
489	const unsigned char c1 = little[0];
490	const unsigned char c2 = little[1];
491
492	s = big + 1;
493	bigend--;
494	if (c1 != c2) {
495	while (s <= bigend) {
496	if (s[0] == c2) {
497	if (s[-1] == c1)
498	return (char*)s - 1;
499	s += 2;
500	continue;
501	}
502	next_chars:
503	if (s[0] == c1) {
504	if (s == bigend)
505	goto check_1char_anchor;
506	if (s[1] == c2)
507	return (char*)s;
508	else {
509	s++;
510	goto next_chars;
511	}
512	}
513	else
514	s += 2;
515	}
516	goto check_1char_anchor;
517	}
518	/* Now c1 == c2 */
519	while (s <= bigend) {
520	if (s[0] == c1) {
521	if (s[-1] == c1)
522	return (char*)s - 1;
523	if (s == bigend)
524	goto check_1char_anchor;
525	if (s[1] == c1)
526	return (char*)s;
527	s += 3;
528	}
529	else
530	s += 2;
531	}
532	}
533	check_1char_anchor: /* One char and anchor! */
534	if (SvTAIL(littlestr) && (bigend == little))
535	return (char )bigend; / bigend is already decremented. */
536	return Nullch;
537	}
538	if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
539	s = bigend - littlelen;
540	if (s >= big && bigend[-1] == '\n' && s == little
541	/* Automatically of length > 2 */
542	&& memEQ((char)s + 1, (char)little + 1, littlelen - 2))
543	{
544	return (char)s; / how sweet it is */
545	}
546	if (s[1] == *little
547	&& memEQ((char)s + 2, (char)little + 1, littlelen - 2))
548	{
549	return (char)s + 1; / how sweet it is */
550	}
551	return Nullch;
552	}
553	if (SvTYPE(littlestr) != SVt_PVBM \|\| !SvVALID(littlestr)) {
554	char b = ninstr((char)big,(char*)bigend,
555	(char)little, (char)little + littlelen);
556
557	if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
558	/* Chop \n from littlestr: */
559	s = bigend - littlelen + 1;
560	if (s == little
561	&& memEQ((char)s + 1, (char)little + 1, littlelen - 2))
562	{
563	return (char*)s;
564	}
565	return Nullch;
566	}
567	return b;
568	}
569
570	{ /* Do actual FBM. */
571	register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
572	register const unsigned char *oldlittle;
573
574	if (littlelen > (STRLEN)(bigend - big))
575	return Nullch;
576	--littlelen; /* Last char found by table lookup */
577
578	s = big + littlelen;
579	little += littlelen; /* last char */
580	oldlittle = little;
581	if (s < bigend) {
582	register I32 tmp;
583
584	top2:
585	if ((tmp = table[*s])) {
586	if ((s += tmp) < bigend)
587	goto top2;
588	goto check_end;
589	}
590	else { /* less expensive than calling strncmp() */
591	register unsigned char * const olds = s;
592
593	tmp = littlelen;
594
595	while (tmp--) {
596	if (--s == --little)
597	continue;
598	s = olds + 1; /* here we pay the price for failure */
599	little = oldlittle;
600	if (s < bigend) /* fake up continue to outer loop */
601	goto top2;
602	goto check_end;
603	}
604	return (char *)s;
605	}
606	}
607	check_end:
608	if ( s == bigend && (table[-1] & FBMcf_TAIL)
609	&& memEQ((char *)(bigend - littlelen),
610	(char *)(oldlittle - littlelen), littlelen) )
611	return (char*)bigend - littlelen;
612	return Nullch;
613	}
614	}
615
616	/* start_shift, end_shift are positive quantities which give offsets
617	of ends of some substring of bigstr.
618	If "last" we want the last occurrence.
619	old_posp is the way of communication between consequent calls if
620	the next call needs to find the .
621	The initial *old_posp should be -1.
622
623	Note that we take into account SvTAIL, so one can get extra
624	optimizations if _ALL flag is set.
625	*/
626
627	/* If SvTAIL is actually due to \Z or \z, this gives false positives
628	if PL_multiline. In fact if !PL_multiline the authoritative answer
629	is not supported yet. */
630
631	char *
632	Perl_screaminstr(pTHX_ SV bigstr, SV littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
633	{
634	register const unsigned char *big;
635	register I32 pos;
636	register I32 previous;
637	register I32 first;
638	register const unsigned char *little;
639	register I32 stop_pos;
640	register const unsigned char *littleend;
641	I32 found = 0;
642
643	if (*old_posp == -1
644	? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
645	: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
646	cant_find:
647	if ( BmRARE(littlestr) == '\n'
648	&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
649	little = (const unsigned char *)(SvPVX_const(littlestr));
650	littleend = little + SvCUR(littlestr);
651	first = *little++;
652	goto check_tail;
653	}
654	return Nullch;
655	}
656
657	little = (const unsigned char *)(SvPVX_const(littlestr));
658	littleend = little + SvCUR(littlestr);
659	first = *little++;
660	/* The value of pos we can start at: */
661	previous = BmPREVIOUS(littlestr);
662	big = (const unsigned char *)(SvPVX_const(bigstr));
663	/* The value of pos we can stop at: */
664	stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
665	if (previous + start_shift > stop_pos) {
666	/*
667	stop_pos does not include SvTAIL in the count, so this check is incorrect
668	(I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
669	*/
670	#if 0
671	if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
672	goto check_tail;
673	#endif
674	return Nullch;
675	}
676	while (pos < previous + start_shift) {
677	if (!(pos += PL_screamnext[pos]))
678	goto cant_find;
679	}
680	big -= previous;
681	do {
682	register const unsigned char s, x;
683	if (pos >= stop_pos) break;
684	if (big[pos] != first)
685	continue;
686	for (x=big+pos+1,s=little; s < littleend; /**/ ) {
687	if (s++ != x++) {
688	s--;
689	break;
690	}
691	}
692	if (s == littleend) {
693	*old_posp = pos;
694	if (!last) return (char *)(big+pos);
695	found = 1;
696	}
697	} while ( pos += PL_screamnext[pos] );
698	if (last && found)
699	return (char )(big+(old_posp));
700	check_tail:
701	if (!SvTAIL(littlestr) \|\| (end_shift > 0))
702	return Nullch;
703	/* Ignore the trailing "\n". This code is not microoptimized */
704	big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
705	stop_pos = littleend - little; /* Actual littlestr len */
706	if (stop_pos == 0)
707	return (char*)big;
708	big -= stop_pos;
709	if (*big == first
710	&& ((stop_pos == 1) \|\|
711	memEQ((char )(big + 1), (char )little, stop_pos - 1)))
712	return (char*)big;
713	return Nullch;
714	}
715
716	I32
717	Perl_ibcmp(pTHX_ const char s1, const char s2, register I32 len)
718	{
719	register const U8 a = (const U8 )s1;
720	register const U8 b = (const U8 )s2;
721	while (len--) {
722	if (a != b && a != PL_fold[b])
723	return 1;
724	a++,b++;
725	}
726	return 0;
727	}
728
729	I32
730	Perl_ibcmp_locale(pTHX_ const char s1, const char s2, register I32 len)
731	{
732	register const U8 a = (const U8 )s1;
733	register const U8 b = (const U8 )s2;
734	while (len--) {
735	if (a != b && a != PL_fold_locale[b])
736	return 1;
737	a++,b++;
738	}
739	return 0;
740	}
741
742	/* copy a string to a safe spot */
743
744	/*
745	=head1 Memory Management
746
747	=for apidoc savepv
748
749	Perl's version of C<strdup()>. Returns a pointer to a newly allocated
750	string which is a duplicate of C<pv>. The size of the string is
751	determined by C<strlen()>. The memory allocated for the new string can
752	be freed with the C<Safefree()> function.
753
754	=cut
755	*/
756
757	char *
758	Perl_savepv(pTHX_ const char *pv)
759	{
760	if (!pv)
761	return Nullch;
762	else {
763	char *newaddr;
764	const STRLEN pvlen = strlen(pv)+1;
765	Newx(newaddr,pvlen,char);
766	return memcpy(newaddr,pv,pvlen);
767	}
768
769	}
770
771	/* same thing but with a known length */
772
773	/*
774	=for apidoc savepvn
775
776	Perl's version of what C<strndup()> would be if it existed. Returns a
777	pointer to a newly allocated string which is a duplicate of the first
778	C<len> bytes from C<pv>. The memory allocated for the new string can be
779	freed with the C<Safefree()> function.
780
781	=cut
782	*/
783
784	char *
785	Perl_savepvn(pTHX_ const char *pv, register I32 len)
786	{
787	register char *newaddr;
788
789	Newx(newaddr,len+1,char);
790	/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
791	if (pv) {
792	/* might not be null terminated */
793	newaddr[len] = '\0';
794	return (char *) CopyD(pv,newaddr,len,char);
795	}
796	else {
797	return (char *) ZeroD(newaddr,len+1,char);
798	}
799	}
800
801	/*
802	=for apidoc savesharedpv
803
804	A version of C<savepv()> which allocates the duplicate string in memory
805	which is shared between threads.
806
807	=cut
808	*/
809	char *
810	Perl_savesharedpv(pTHX_ const char *pv)
811	{
812	register char *newaddr;
813	STRLEN pvlen;
814	if (!pv)
815	return Nullch;
816
817	pvlen = strlen(pv)+1;
818	newaddr = (char*)PerlMemShared_malloc(pvlen);
819	if (!newaddr) {
820	PerlLIO_write(PerlIO_fileno(Perl_error_log),
821	PL_no_mem, strlen(PL_no_mem));
822	my_exit(1);
823	}
824	return memcpy(newaddr,pv,pvlen);
825	}
826
827	/*
828	=for apidoc savesvpv
829
830	A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
831	the passed in SV using C<SvPV()>
832
833	=cut
834	*/
835
836	char *
837	Perl_savesvpv(pTHX_ SV *sv)
838	{
839	STRLEN len;
840	const char *pv = SvPV_const(sv, len);
841	register char *newaddr;
842
843	++len;
844	Newx(newaddr,len,char);
845	return (char *) CopyD(pv,newaddr,len,char);
846	}
847
848
849	/* the SV for Perl_form() and mess() is not kept in an arena */
850
851	STATIC SV *
852	S_mess_alloc(pTHX)
853	{
854	SV *sv;
855	XPVMG *any;
856
857	if (!PL_dirty)
858	return sv_2mortal(newSVpvn("",0));
859
860	if (PL_mess_sv)
861	return PL_mess_sv;
862
863	/* Create as PVMG now, to avoid any upgrading later */
864	Newx(sv, 1, SV);
865	Newxz(any, 1, XPVMG);
866	SvFLAGS(sv) = SVt_PVMG;
867	SvANY(sv) = (void*)any;
868	SvREFCNT(sv) = 1 << 30; /* practically infinite */
869	PL_mess_sv = sv;
870	return sv;
871	}
872
873	#if defined(PERL_IMPLICIT_CONTEXT)
874	char *
875	Perl_form_nocontext(const char* pat, ...)
876	{
877	dTHX;
878	char *retval;
879	va_list args;
880	va_start(args, pat);
881	retval = vform(pat, &args);
882	va_end(args);
883	return retval;
884	}
885	#endif /* PERL_IMPLICIT_CONTEXT */
886
887	/*
888	=head1 Miscellaneous Functions
889	=for apidoc form
890
891	Takes a sprintf-style format pattern and conventional
892	(non-SV) arguments and returns the formatted string.
893
894	(char ) Perl_form(pTHX_ const char pat, ...)
895
896	can be used any place a string (char *) is required:
897
898	char * s = Perl_form("%d.%d",major,minor);
899
900	Uses a single private buffer so if you want to format several strings you
901	must explicitly copy the earlier strings away (and free the copies when you
902	are done).
903
904	=cut
905	*/
906
907	char *
908	Perl_form(pTHX_ const char* pat, ...)
909	{
910	char *retval;
911	va_list args;
912	va_start(args, pat);
913	retval = vform(pat, &args);
914	va_end(args);
915	return retval;
916	}
917
918	char *
919	Perl_vform(pTHX_ const char pat, va_list args)
920	{
921	SV * const sv = mess_alloc();
922	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
923	return SvPVX(sv);
924	}
925
926	#if defined(PERL_IMPLICIT_CONTEXT)
927	SV *
928	Perl_mess_nocontext(const char *pat, ...)
929	{
930	dTHX;
931	SV *retval;
932	va_list args;
933	va_start(args, pat);
934	retval = vmess(pat, &args);
935	va_end(args);
936	return retval;
937	}
938	#endif /* PERL_IMPLICIT_CONTEXT */
939
940	SV *
941	Perl_mess(pTHX_ const char *pat, ...)
942	{
943	SV *retval;
944	va_list args;
945	va_start(args, pat);
946	retval = vmess(pat, &args);
947	va_end(args);
948	return retval;
949	}
950
951	STATIC COP*
952	S_closest_cop(pTHX_ COP cop, const OP o)
953	{
954	/* Look for PL_op starting from o. cop is the last COP we've seen. */
955
956	if (!o \|\| o == PL_op) return cop;
957
958	if (o->op_flags & OPf_KIDS) {
959	OP *kid;
960	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
961	{
962	COP *new_cop;
963
964	/* If the OP_NEXTSTATE has been optimised away we can still use it
965	* the get the file and line number. */
966
967	if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
968	cop = (COP *)kid;
969
970	/* Keep searching, and return when we've found something. */
971
972	new_cop = closest_cop(cop, kid);
973	if (new_cop) return new_cop;
974	}
975	}
976
977	/* Nothing found. */
978
979	return Null(COP *);
980	}
981
982	SV *
983	Perl_vmess(pTHX_ const char pat, va_list args)
984	{
985	SV *sv = mess_alloc();
986	static const char dgd[] = " during global destruction.\n";
987
988	sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV*), 0, Null(bool));
989	if (!SvCUR(sv) \|\| *(SvEND(sv) - 1) != '\n') {
990
991	/*
992	* Try and find the file and line for PL_op. This will usually be
993	* PL_curcop, but it might be a cop that has been optimised away. We
994	* can try to find such a cop by searching through the optree starting
995	* from the sibling of PL_curcop.
996	*/
997
998	const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
999	if (!cop) cop = PL_curcop;
1000
1001	if (CopLINE(cop))
1002	Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1003	OutCopFILE(cop), (IV)CopLINE(cop));
1004	if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1005	const bool line_mode = (RsSIMPLE(PL_rs) &&
1006	SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1007	Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1008	PL_last_in_gv == PL_argvgv ?
1009	"" : GvNAME(PL_last_in_gv),
1010	line_mode ? "line" : "chunk",
1011	(IV)IoLINES(GvIOp(PL_last_in_gv)));
1012	}
1013	#ifdef USE_5005THREADS
1014	if (thr->tid)
1015	Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1016	#endif
1017	sv_catpv(sv, PL_dirty ? dgd : ".\n");
1018	}
1019	return sv;
1020	}
1021
1022	void
1023	Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1024	{
1025	IO *io;
1026	MAGIC *mg;
1027
1028	if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1029	&& (io = GvIO(PL_stderrgv))
1030	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1031	{
1032	dSP;
1033	ENTER;
1034	SAVETMPS;
1035
1036	save_re_context();
1037	SAVESPTR(PL_stderrgv);
1038	PL_stderrgv = Nullgv;
1039
1040	PUSHSTACKi(PERLSI_MAGIC);
1041
1042	PUSHMARK(SP);
1043	EXTEND(SP,2);
1044	PUSHs(SvTIED_obj((SV*)io, mg));
1045	PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1046	PUTBACK;
1047	call_method("PRINT", G_SCALAR);
1048
1049	POPSTACK;
1050	FREETMPS;
1051	LEAVE;
1052	}
1053	else {
1054	#ifdef USE_SFIO
1055	/* SFIO can really mess with your errno */
1056	const int e = errno;
1057	#endif
1058	PerlIO * const serr = Perl_error_log;
1059
1060	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1061	(void)PerlIO_flush(serr);
1062	#ifdef USE_SFIO
1063	errno = e;
1064	#endif
1065	}
1066	}
1067
1068	/* Common code used by vcroak, vdie and vwarner */
1069
1070	/* Whilst this should really be STATIC, it was not in 5.8.7, hence something
1071	may have linked against it. */
1072	void
1073	S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1074	{
1075	HV *stash;
1076	GV *gv;
1077	CV *cv;
1078	/* sv_2cv might call Perl_croak() */
1079	SV * const olddiehook = PL_diehook;
1080
1081	assert(PL_diehook);
1082	ENTER;
1083	SAVESPTR(PL_diehook);
1084	PL_diehook = Nullsv;
1085	cv = sv_2cv(olddiehook, &stash, &gv, 0);
1086	LEAVE;
1087	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1088	dSP;
1089	SV *msg;
1090
1091	ENTER;
1092	save_re_context();
1093	if (message) {
1094	msg = newSVpvn(message, msglen);
1095	SvFLAGS(msg) \|= utf8;
1096	SvREADONLY_on(msg);
1097	SAVEFREESV(msg);
1098	}
1099	else {
1100	msg = ERRSV;
1101	}
1102
1103	PUSHSTACKi(PERLSI_DIEHOOK);
1104	PUSHMARK(SP);
1105	XPUSHs(msg);
1106	PUTBACK;
1107	call_sv((SV*)cv, G_DISCARD);
1108	POPSTACK;
1109	LEAVE;
1110	}
1111	}
1112
1113	/* Whilst this should really be STATIC, it was not in 5.8.7, hence something
1114	may have linked against it. */
1115	char *
1116	S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1117	I32* utf8)
1118	{
1119	const char *message;
1120
1121	if (pat) {
1122	SV * const msv = vmess(pat, args);
1123	if (PL_errors && SvCUR(PL_errors)) {
1124	sv_catsv(PL_errors, msv);
1125	message = SvPV_const(PL_errors, *msglen);
1126	SvCUR_set(PL_errors, 0);
1127	}
1128	else
1129	message = SvPV_const(msv,*msglen);
1130	*utf8 = SvUTF8(msv);
1131	}
1132	else {
1133	message = Nullch;
1134	}
1135
1136	DEBUG_S(PerlIO_printf(Perl_debug_log,
1137	"%p: die/croak: message = %s\ndiehook = %p\n",
1138	thr, message, PL_diehook));
1139	if (PL_diehook) {
1140	S_vdie_common(aTHX_ message, msglen, utf8);
1141	}
1142	/* Cast because we're not changing function prototypes in maint, and this
1143	function isn't actually static. */
1144	return (char *) message;
1145	}
1146
1147	OP *
1148	Perl_vdie(pTHX_ const char* pat, va_list *args)
1149	{
1150	const char *message;
1151	const int was_in_eval = PL_in_eval;
1152	STRLEN msglen;
1153	I32 utf8 = 0;
1154
1155	DEBUG_S(PerlIO_printf(Perl_debug_log,
1156	"%p: die: curstack = %p, mainstack = %p\n",
1157	thr, PL_curstack, PL_mainstack));
1158
1159	message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1160
1161	PL_restartop = die_where((char *)message, msglen);
1162	SvFLAGS(ERRSV) \|= utf8;
1163	DEBUG_S(PerlIO_printf(Perl_debug_log,
1164	"%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1165	thr, PL_restartop, was_in_eval, PL_top_env));
1166	if ((!PL_restartop && was_in_eval) \|\| PL_top_env->je_prev)
1167	JMPENV_JUMP(3);
1168	return PL_restartop;
1169	}
1170
1171	#if defined(PERL_IMPLICIT_CONTEXT)
1172	OP *
1173	Perl_die_nocontext(const char* pat, ...)
1174	{
1175	dTHX;
1176	OP *o;
1177	va_list args;
1178	va_start(args, pat);
1179	o = vdie(pat, &args);
1180	va_end(args);
1181	return o;
1182	}
1183	#endif /* PERL_IMPLICIT_CONTEXT */
1184
1185	OP *
1186	Perl_die(pTHX_ const char* pat, ...)
1187	{
1188	OP *o;
1189	va_list args;
1190	va_start(args, pat);
1191	o = vdie(pat, &args);
1192	va_end(args);
1193	return o;
1194	}
1195
1196	void
1197	Perl_vcroak(pTHX_ const char* pat, va_list *args)
1198	{
1199	const char *message;
1200	STRLEN msglen;
1201	I32 utf8 = 0;
1202
1203	message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1204
1205	if (PL_in_eval) {
1206	PL_restartop = die_where((char *) message, msglen);
1207	SvFLAGS(ERRSV) \|= utf8;
1208	JMPENV_JUMP(3);
1209	}
1210	else if (!message)
1211	message = SvPVx_const(ERRSV, msglen);
1212
1213	write_to_stderr(message, msglen);
1214	my_failure_exit();
1215	}
1216
1217	#if defined(PERL_IMPLICIT_CONTEXT)
1218	void
1219	Perl_croak_nocontext(const char *pat, ...)
1220	{
1221	dTHX;
1222	va_list args;
1223	va_start(args, pat);
1224	vcroak(pat, &args);
1225	/* NOTREACHED */
1226	va_end(args);
1227	}
1228	#endif /* PERL_IMPLICIT_CONTEXT */
1229
1230	/*
1231	=head1 Warning and Dieing
1232
1233	=for apidoc croak
1234
1235	This is the XSUB-writer's interface to Perl's C<die> function.
1236	Normally call this function the same way you call the C C<printf>
1237	function. Calling C<croak> returns control directly to Perl,
1238	sidestepping the normal C order of execution. See C<warn>.
1239
1240	If you want to throw an exception object, assign the object to
1241	C<$@> and then pass C<Nullch> to croak():
1242
1243	errsv = get_sv("@", TRUE);
1244	sv_setsv(errsv, exception_object);
1245	croak(Nullch);
1246
1247	=cut
1248	*/
1249
1250	void
1251	Perl_croak(pTHX_ const char *pat, ...)
1252	{
1253	va_list args;
1254	va_start(args, pat);
1255	vcroak(pat, &args);
1256	/* NOTREACHED */
1257	va_end(args);
1258	}
1259
1260	void
1261	Perl_vwarn(pTHX_ const char* pat, va_list *args)
1262	{
1263	STRLEN msglen;
1264	SV * const msv = vmess(pat, args);
1265	const I32 utf8 = SvUTF8(msv);
1266	const char * const message = SvPV_const(msv, msglen);
1267
1268	if (PL_warnhook) {
1269	/* sv_2cv might call Perl_warn() */
1270	SV * const oldwarnhook = PL_warnhook;
1271	CV * cv;
1272	HV * stash;
1273	GV * gv;
1274
1275	ENTER;
1276	SAVESPTR(PL_warnhook);
1277	PL_warnhook = Nullsv;
1278	cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1279	LEAVE;
1280	if (cv && !CvDEPTH(cv) && (CvROOT(cv) \|\| CvXSUB(cv))) {
1281	dSP;
1282	SV *msg;
1283
1284	ENTER;
1285	SAVESPTR(PL_warnhook);
1286	PL_warnhook = Nullsv;
1287	save_re_context();
1288	msg = newSVpvn(message, msglen);
1289	SvFLAGS(msg) \|= utf8;
1290	SvREADONLY_on(msg);
1291	SAVEFREESV(msg);
1292
1293	PUSHSTACKi(PERLSI_WARNHOOK);
1294	PUSHMARK(SP);
1295	XPUSHs(msg);
1296	PUTBACK;
1297	call_sv((SV*)cv, G_DISCARD);
1298	POPSTACK;
1299	LEAVE;
1300	return;
1301	}
1302	}
1303
1304	write_to_stderr(message, msglen);
1305	}
1306
1307	#if defined(PERL_IMPLICIT_CONTEXT)
1308	void
1309	Perl_warn_nocontext(const char *pat, ...)
1310	{
1311	dTHX;
1312	va_list args;
1313	va_start(args, pat);
1314	vwarn(pat, &args);
1315	va_end(args);
1316	}
1317	#endif /* PERL_IMPLICIT_CONTEXT */
1318
1319	/*
1320	=for apidoc warn
1321
1322	This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1323	function the same way you call the C C<printf> function. See C<croak>.
1324
1325	=cut
1326	*/
1327
1328	void
1329	Perl_warn(pTHX_ const char *pat, ...)
1330	{
1331	va_list args;
1332	va_start(args, pat);
1333	vwarn(pat, &args);
1334	va_end(args);
1335	}
1336
1337	#if defined(PERL_IMPLICIT_CONTEXT)
1338	void
1339	Perl_warner_nocontext(U32 err, const char *pat, ...)
1340	{
1341	dTHX;
1342	va_list args;
1343	va_start(args, pat);
1344	vwarner(err, pat, &args);
1345	va_end(args);
1346	}
1347	#endif /* PERL_IMPLICIT_CONTEXT */
1348
1349	void
1350	Perl_warner(pTHX_ U32 err, const char* pat,...)
1351	{
1352	va_list args;
1353	va_start(args, pat);
1354	vwarner(err, pat, &args);
1355	va_end(args);
1356	}
1357
1358	void
1359	Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1360	{
1361	if (ckDEAD(err)) {
1362	SV * const msv = vmess(pat, args);
1363	STRLEN msglen;
1364	const char *message = SvPV_const(msv, msglen);
1365	const I32 utf8 = SvUTF8(msv);
1366
1367	#ifdef USE_5005THREADS
1368	DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1369	#endif /* USE_5005THREADS */
1370	if (PL_diehook) {
1371	assert(message);
1372	S_vdie_common(aTHX_ message, msglen, utf8);
1373	}
1374	if (PL_in_eval) {
1375	PL_restartop = die_where((char *) message, msglen);
1376	SvFLAGS(ERRSV) \|= utf8;
1377	JMPENV_JUMP(3);
1378	}
1379	write_to_stderr(message, msglen);
1380	my_failure_exit();
1381	}
1382	else {
1383	Perl_vwarn(aTHX_ pat, args);
1384	}
1385	}
1386
1387	/* implements the ckWARN? macros */
1388
1389	bool
1390	Perl_ckwarn(pTHX_ U32 w)
1391	{
1392	return
1393	(
1394	isLEXWARN_on
1395	&& PL_curcop->cop_warnings != pWARN_NONE
1396	&& (
1397	PL_curcop->cop_warnings == pWARN_ALL
1398	\|\| isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1399	\|\| (unpackWARN2(w) &&
1400	isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1401	\|\| (unpackWARN3(w) &&
1402	isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1403	\|\| (unpackWARN4(w) &&
1404	isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1405	)
1406	)
1407	\|\|
1408	(
1409	isLEXWARN_off && PL_dowarn & G_WARN_ON
1410	)
1411	;
1412	}
1413
1414	/* implements the ckWARN?_d macro */
1415
1416	bool
1417	Perl_ckwarn_d(pTHX_ U32 w)
1418	{
1419	return
1420	isLEXWARN_off
1421	\|\| PL_curcop->cop_warnings == pWARN_ALL
1422	\|\| (
1423	PL_curcop->cop_warnings != pWARN_NONE
1424	&& (
1425	isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1426	\|\| (unpackWARN2(w) &&
1427	isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1428	\|\| (unpackWARN3(w) &&
1429	isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1430	\|\| (unpackWARN4(w) &&
1431	isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1432	)
1433	)
1434	;
1435	}
1436
1437
1438
1439	/* since we've already done strlen() for both nam and val
1440	* we can use that info to make things faster than
1441	* sprintf(s, "%s=%s", nam, val)
1442	*/
1443	#define my_setenv_format(s, nam, nlen, val, vlen) \
1444	Copy(nam, s, nlen, char); \
1445	*(s+nlen) = '='; \
1446	Copy(val, s+(nlen+1), vlen, char); \
1447	*(s+(nlen+1+vlen)) = '\0'
1448
1449	#ifdef USE_ENVIRON_ARRAY
1450	/* VMS' my_setenv() is in vms.c */
1451	#if !defined(WIN32) && !defined(NETWARE)
1452	void
1453	Perl_my_setenv(pTHX_ char nam, char val)
1454	{
1455	#ifdef USE_ITHREADS
1456	/* only parent thread can modify process environment */
1457	if (PL_curinterp == aTHX)
1458	#endif
1459	{
1460	#ifndef PERL_USE_SAFE_PUTENV
1461	if (!PL_use_safe_putenv) {
1462	/* most putenv()s leak, so we manipulate environ directly */
1463	register I32 i=setenv_getix(nam); /* where does it go? */
1464	int nlen, vlen;
1465
1466	if (environ == PL_origenviron) { /* need we copy environment? */
1467	I32 j;
1468	I32 max;
1469	char **tmpenv;
1470
1471	for (max = i; environ[max]; max++) ;
1472	tmpenv = (char*)safesysmalloc((max+2) sizeof(char*));
1473	for (j=0; j<max; j++) { /* copy environment */
1474	const int len = strlen(environ[j]);
1475	tmpenv[j] = (char)safesysmalloc((len+1)sizeof(char));
1476	Copy(environ[j], tmpenv[j], len+1, char);
1477	}
1478	tmpenv[max] = Nullch;
1479	environ = tmpenv; /* tell exec where it is now */
1480	}
1481	if (!val) {
1482	safesysfree(environ[i]);
1483	while (environ[i]) {
1484	environ[i] = environ[i+1];
1485	i++;
1486	}
1487	return;
1488	}
1489	if (!environ[i]) { /* does not exist yet */
1490	environ = (char*)safesysrealloc(environ, (i+2) sizeof(char*));
1491	environ[i+1] = Nullch; /* make sure it's null terminated */
1492	}
1493	else
1494	safesysfree(environ[i]);
1495	nlen = strlen(nam);
1496	vlen = strlen(val);
1497
1498	environ[i] = (char)safesysmalloc((nlen+vlen+2) sizeof(char));
1499	/* all that work just for this */
1500	my_setenv_format(environ[i], nam, nlen, val, vlen);
1501	} else {
1502	# endif
1503	# if defined(__CYGWIN__) \|\| defined(EPOC) \|\| defined(SYMBIAN)
1504	# if defined(HAS_UNSETENV)
1505	if (val == NULL) {
1506	(void)unsetenv(nam);
1507	} else {
1508	(void)setenv(nam, val, 1);
1509	}
1510	# else /* ! HAS_UNSETENV */
1511	(void)setenv(nam, val, 1);
1512	# endif /* HAS_UNSETENV */
1513	# else
1514	# if defined(HAS_UNSETENV)
1515	if (val == NULL) {
1516	(void)unsetenv(nam);
1517	} else {
1518	int nlen = strlen(nam);
1519	int vlen = strlen(val);
1520	char *new_env =
1521	(char)safesysmalloc((nlen + vlen + 2) sizeof(char));
1522	my_setenv_format(new_env, nam, nlen, val, vlen);
1523	(void)putenv(new_env);
1524	}
1525	# else /* ! HAS_UNSETENV */
1526	char *new_env;
1527	int nlen = strlen(nam), vlen;
1528	if (!val) {
1529	val = "";
1530	}
1531	vlen = strlen(val);
1532	new_env = (char)safesysmalloc((nlen + vlen + 2) sizeof(char));
1533	/* all that work just for this */
1534	my_setenv_format(new_env, nam, nlen, val, vlen);
1535	(void)putenv(new_env);
1536	# endif /* HAS_UNSETENV */
1537	# endif /* __CYGWIN__ */
1538	#ifndef PERL_USE_SAFE_PUTENV
1539	}
1540	#endif
1541	}
1542	}
1543
1544	#else /* WIN32 \|\| NETWARE */
1545
1546	void
1547	Perl_my_setenv(pTHX_ char nam, char val)
1548	{
1549	register char *envstr;
1550	const int nlen = strlen(nam);
1551	int vlen;
1552
1553	if (!val) {
1554	val = "";
1555	}
1556	vlen = strlen(val);
1557	Newx(envstr, nlen+vlen+2, char);
1558	my_setenv_format(envstr, nam, nlen, val, vlen);
1559	(void)PerlEnv_putenv(envstr);
1560	Safefree(envstr);
1561	}
1562
1563	#endif /* WIN32 \|\| NETWARE */
1564
1565	#ifndef PERL_MICRO
1566	I32
1567	Perl_setenv_getix(pTHX_ char *nam)
1568	{
1569	register I32 i;
1570	register const I32 len = strlen(nam);
1571
1572	for (i = 0; environ[i]; i++) {
1573	if (
1574	#ifdef WIN32
1575	strnicmp(environ[i],nam,len) == 0
1576	#else
1577	strnEQ(environ[i],nam,len)
1578	#endif
1579	&& environ[i][len] == '=')
1580	break; /* strnEQ must come first to avoid */
1581	} /* potential SEGV's */
1582	return i;
1583	}
1584	#endif /* !PERL_MICRO */
1585
1586	#endif /* !VMS && !EPOC*/
1587
1588	#ifdef UNLINK_ALL_VERSIONS
1589	I32
1590	Perl_unlnk(pTHX_ char f) / unlink all versions of a file */
1591	{
1592	I32 i;
1593
1594	for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1595	return i ? 0 : -1;
1596	}
1597	#endif
1598
1599	/* this is a drop-in replacement for bcopy() */
1600	#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) \|\| (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1601	char *
1602	Perl_my_bcopy(register const char from,register char to,register I32 len)
1603	{
1604	char * const retval = to;
1605
1606	if (from - to >= 0) {
1607	while (len--)
1608	to++ = from++;
1609	}
1610	else {
1611	to += len;
1612	from += len;
1613	while (len--)
1614	(--to) = (--from);
1615	}
1616	return retval;
1617	}
1618	#endif
1619
1620	/* this is a drop-in replacement for memset() */
1621	#ifndef HAS_MEMSET
1622	void *
1623	Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1624	{
1625	char * const retval = loc;
1626
1627	while (len--)
1628	*loc++ = ch;
1629	return retval;
1630	}
1631	#endif
1632
1633	/* this is a drop-in replacement for bzero() */
1634	#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1635	char *
1636	Perl_my_bzero(register char *loc, register I32 len)
1637	{
1638	char * const retval = loc;
1639
1640	while (len--)
1641	*loc++ = 0;
1642	return retval;
1643	}
1644	#endif
1645
1646	/* this is a drop-in replacement for memcmp() */
1647	#if !defined(HAS_MEMCMP) \|\| !defined(HAS_SANE_MEMCMP)
1648	I32
1649	Perl_my_memcmp(const char s1, const char s2, register I32 len)
1650	{
1651	register const U8 a = (const U8 )s1;
1652	register const U8 b = (const U8 )s2;
1653	register I32 tmp;
1654
1655	while (len--) {
1656	if ((tmp = a++ - b++))
1657	return tmp;
1658	}
1659	return 0;
1660	}
1661	#endif /* !HAS_MEMCMP \|\| !HAS_SANE_MEMCMP */
1662
1663	#ifndef HAS_VPRINTF
1664
1665	#ifdef USE_CHAR_VSPRINTF
1666	char *
1667	#else
1668	int
1669	#endif
1670	vsprintf(char dest, const char pat, char *args)
1671	{
1672	FILE fakebuf;
1673
1674	fakebuf._ptr = dest;
1675	fakebuf._cnt = 32767;
1676	#ifndef _IOSTRG
1677	#define _IOSTRG 0
1678	#endif
1679	fakebuf._flag = _IOWRT\|_IOSTRG;
1680	_doprnt(pat, args, &fakebuf); /* what a kludge */
1681	(void)putc('\0', &fakebuf);
1682	#ifdef USE_CHAR_VSPRINTF
1683	return(dest);
1684	#else
1685	return 0; /* perl doesn't use return value */
1686	#endif
1687	}
1688
1689	#endif /* HAS_VPRINTF */
1690
1691	#ifdef MYSWAP
1692	#if BYTEORDER != 0x4321
1693	short
1694	Perl_my_swap(pTHX_ short s)
1695	{
1696	#if (BYTEORDER & 1) == 0
1697	short result;
1698
1699	result = ((s & 255) << 8) + ((s >> 8) & 255);
1700	return result;
1701	#else
1702	return s;
1703	#endif
1704	}
1705
1706	long
1707	Perl_my_htonl(pTHX_ long l)
1708	{
1709	union {
1710	long result;
1711	char c[sizeof(long)];
1712	} u;
1713
1714	#if BYTEORDER == 0x1234
1715	u.c[0] = (l >> 24) & 255;
1716	u.c[1] = (l >> 16) & 255;
1717	u.c[2] = (l >> 8) & 255;
1718	u.c[3] = l & 255;
1719	return u.result;
1720	#else
1721	#if ((BYTEORDER - 0x1111) & 0x444) \|\| !(BYTEORDER & 0xf)
1722	Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1723	#else
1724	register I32 o;
1725	register I32 s;
1726
1727	for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1728	u.c[o & 0xf] = (l >> s) & 255;
1729	}
1730	return u.result;
1731	#endif
1732	#endif
1733	}
1734
1735	long
1736	Perl_my_ntohl(pTHX_ long l)
1737	{
1738	union {
1739	long l;
1740	char c[sizeof(long)];
1741	} u;
1742
1743	#if BYTEORDER == 0x1234
1744	u.c[0] = (l >> 24) & 255;
1745	u.c[1] = (l >> 16) & 255;
1746	u.c[2] = (l >> 8) & 255;
1747	u.c[3] = l & 255;
1748	return u.l;
1749	#else
1750	#if ((BYTEORDER - 0x1111) & 0x444) \|\| !(BYTEORDER & 0xf)
1751	Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1752	#else
1753	register I32 o;
1754	register I32 s;
1755
1756	u.l = l;
1757	l = 0;
1758	for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1759	l \|= (u.c[o & 0xf] & 255) << s;
1760	}
1761	return l;
1762	#endif
1763	#endif
1764	}
1765
1766	#endif /* BYTEORDER != 0x4321 */
1767	#endif /* MYSWAP */
1768
1769	/*
1770	* Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1771	* If these functions are defined,
1772	* the BYTEORDER is neither 0x1234 nor 0x4321.
1773	* However, this is not assumed.
1774	* -DWS
1775	*/
1776
1777	#define HTOLE(name,type) \
1778	type \
1779	name (register type n) \
1780	{ \
1781	union { \
1782	type value; \
1783	char c[sizeof(type)]; \
1784	} u; \
1785	register I32 i; \
1786	register I32 s = 0; \
1787	for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1788	u.c[i] = (n >> s) & 0xFF; \
1789	} \
1790	return u.value; \
1791	}
1792
1793	#define LETOH(name,type) \
1794	type \
1795	name (register type n) \
1796	{ \
1797	union { \
1798	type value; \
1799	char c[sizeof(type)]; \
1800	} u; \
1801	register I32 i; \
1802	register I32 s = 0; \
1803	u.value = n; \
1804	n = 0; \
1805	for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1806	n \|= ((type)(u.c[i] & 0xFF)) << s; \
1807	} \
1808	return n; \
1809	}
1810
1811	/*
1812	* Big-endian byte order functions.
1813	*/
1814
1815	#define HTOBE(name,type) \
1816	type \
1817	name (register type n) \
1818	{ \
1819	union { \
1820	type value; \
1821	char c[sizeof(type)]; \
1822	} u; \
1823	register I32 i; \
1824	register I32 s = 8*(sizeof(u.c)-1); \
1825	for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1826	u.c[i] = (n >> s) & 0xFF; \
1827	} \
1828	return u.value; \
1829	}
1830
1831	#define BETOH(name,type) \
1832	type \
1833	name (register type n) \
1834	{ \
1835	union { \
1836	type value; \
1837	char c[sizeof(type)]; \
1838	} u; \
1839	register I32 i; \
1840	register I32 s = 8*(sizeof(u.c)-1); \
1841	u.value = n; \
1842	n = 0; \
1843	for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1844	n \|= ((type)(u.c[i] & 0xFF)) << s; \
1845	} \
1846	return n; \
1847	}
1848
1849	/*
1850	* If we just can't do it...
1851	*/
1852
1853	#define NOT_AVAIL(name,type) \
1854	type \
1855	name (register type n) \
1856	{ \
1857	Perl_croak_nocontext(#name "() not available"); \
1858	return n; /* not reached */ \
1859	}
1860
1861
1862	#if defined(HAS_HTOVS) && !defined(htovs)
1863	HTOLE(htovs,short)
1864	#endif
1865	#if defined(HAS_HTOVL) && !defined(htovl)
1866	HTOLE(htovl,long)
1867	#endif
1868	#if defined(HAS_VTOHS) && !defined(vtohs)
1869	LETOH(vtohs,short)
1870	#endif
1871	#if defined(HAS_VTOHL) && !defined(vtohl)
1872	LETOH(vtohl,long)
1873	#endif
1874
1875	#ifdef PERL_NEED_MY_HTOLE16
1876	# if U16SIZE == 2
1877	HTOLE(Perl_my_htole16,U16)
1878	# else
1879	NOT_AVAIL(Perl_my_htole16,U16)
1880	# endif
1881	#endif
1882	#ifdef PERL_NEED_MY_LETOH16
1883	# if U16SIZE == 2
1884	LETOH(Perl_my_letoh16,U16)
1885	# else
1886	NOT_AVAIL(Perl_my_letoh16,U16)
1887	# endif
1888	#endif
1889	#ifdef PERL_NEED_MY_HTOBE16
1890	# if U16SIZE == 2
1891	HTOBE(Perl_my_htobe16,U16)
1892	# else
1893	NOT_AVAIL(Perl_my_htobe16,U16)
1894	# endif
1895	#endif
1896	#ifdef PERL_NEED_MY_BETOH16
1897	# if U16SIZE == 2
1898	BETOH(Perl_my_betoh16,U16)
1899	# else
1900	NOT_AVAIL(Perl_my_betoh16,U16)
1901	# endif
1902	#endif
1903
1904	#ifdef PERL_NEED_MY_HTOLE32
1905	# if U32SIZE == 4
1906	HTOLE(Perl_my_htole32,U32)
1907	# else
1908	NOT_AVAIL(Perl_my_htole32,U32)
1909	# endif
1910	#endif
1911	#ifdef PERL_NEED_MY_LETOH32
1912	# if U32SIZE == 4
1913	LETOH(Perl_my_letoh32,U32)
1914	# else
1915	NOT_AVAIL(Perl_my_letoh32,U32)
1916	# endif
1917	#endif
1918	#ifdef PERL_NEED_MY_HTOBE32
1919	# if U32SIZE == 4
1920	HTOBE(Perl_my_htobe32,U32)
1921	# else
1922	NOT_AVAIL(Perl_my_htobe32,U32)
1923	# endif
1924	#endif
1925	#ifdef PERL_NEED_MY_BETOH32
1926	# if U32SIZE == 4
1927	BETOH(Perl_my_betoh32,U32)
1928	# else
1929	NOT_AVAIL(Perl_my_betoh32,U32)
1930	# endif
1931	#endif
1932
1933	#ifdef PERL_NEED_MY_HTOLE64
1934	# if U64SIZE == 8
1935	HTOLE(Perl_my_htole64,U64)
1936	# else
1937	NOT_AVAIL(Perl_my_htole64,U64)
1938	# endif
1939	#endif
1940	#ifdef PERL_NEED_MY_LETOH64
1941	# if U64SIZE == 8
1942	LETOH(Perl_my_letoh64,U64)
1943	# else
1944	NOT_AVAIL(Perl_my_letoh64,U64)
1945	# endif
1946	#endif
1947	#ifdef PERL_NEED_MY_HTOBE64
1948	# if U64SIZE == 8
1949	HTOBE(Perl_my_htobe64,U64)
1950	# else
1951	NOT_AVAIL(Perl_my_htobe64,U64)
1952	# endif
1953	#endif
1954	#ifdef PERL_NEED_MY_BETOH64
1955	# if U64SIZE == 8
1956	BETOH(Perl_my_betoh64,U64)
1957	# else
1958	NOT_AVAIL(Perl_my_betoh64,U64)
1959	# endif
1960	#endif
1961
1962	#ifdef PERL_NEED_MY_HTOLES
1963	HTOLE(Perl_my_htoles,short)
1964	#endif
1965	#ifdef PERL_NEED_MY_LETOHS
1966	LETOH(Perl_my_letohs,short)
1967	#endif
1968	#ifdef PERL_NEED_MY_HTOBES
1969	HTOBE(Perl_my_htobes,short)
1970	#endif
1971	#ifdef PERL_NEED_MY_BETOHS
1972	BETOH(Perl_my_betohs,short)
1973	#endif
1974
1975	#ifdef PERL_NEED_MY_HTOLEI
1976	HTOLE(Perl_my_htolei,int)
1977	#endif
1978	#ifdef PERL_NEED_MY_LETOHI
1979	LETOH(Perl_my_letohi,int)
1980	#endif
1981	#ifdef PERL_NEED_MY_HTOBEI
1982	HTOBE(Perl_my_htobei,int)
1983	#endif
1984	#ifdef PERL_NEED_MY_BETOHI
1985	BETOH(Perl_my_betohi,int)
1986	#endif
1987
1988	#ifdef PERL_NEED_MY_HTOLEL
1989	HTOLE(Perl_my_htolel,long)
1990	#endif
1991	#ifdef PERL_NEED_MY_LETOHL
1992	LETOH(Perl_my_letohl,long)
1993	#endif
1994	#ifdef PERL_NEED_MY_HTOBEL
1995	HTOBE(Perl_my_htobel,long)
1996	#endif
1997	#ifdef PERL_NEED_MY_BETOHL
1998	BETOH(Perl_my_betohl,long)
1999	#endif
2000
2001	void
2002	Perl_my_swabn(void *ptr, int n)
2003	{
2004	register char s = (char )ptr;
2005	register char *e = s + (n-1);
2006	register char tc;
2007
2008	for (n /= 2; n > 0; s++, e--, n--) {
2009	tc = *s;
2010	s = e;
2011	*e = tc;
2012	}
2013	}
2014
2015	PerlIO *
2016	Perl_my_popen_list(pTHX_ char mode, int n, SV *args)
2017	{
2018	#if (!defined(DOSISH) \|\| defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2019	int p[2];
2020	register I32 This, that;
2021	register Pid_t pid;
2022	SV *sv;
2023	I32 did_pipes = 0;
2024	int pp[2];
2025
2026	PERL_FLUSHALL_FOR_CHILD;
2027	This = (*mode == 'w');
2028	that = !This;
2029	if (PL_tainting) {
2030	taint_env();
2031	taint_proper("Insecure %s%s", "EXEC");
2032	}
2033	if (PerlProc_pipe(p) < 0)
2034	return Nullfp;
2035	/* Try for another pipe pair for error return */
2036	if (PerlProc_pipe(pp) >= 0)
2037	did_pipes = 1;
2038	while ((pid = PerlProc_fork()) < 0) {
2039	if (errno != EAGAIN) {
2040	PerlLIO_close(p[This]);
2041	PerlLIO_close(p[that]);
2042	if (did_pipes) {
2043	PerlLIO_close(pp[0]);
2044	PerlLIO_close(pp[1]);
2045	}
2046	return Nullfp;
2047	}
2048	sleep(5);
2049	}
2050	if (pid == 0) {
2051	/* Child */
2052	#undef THIS
2053	#undef THAT
2054	#define THIS that
2055	#define THAT This
2056	/* Close parent's end of error status pipe (if any) */
2057	if (did_pipes) {
2058	PerlLIO_close(pp[0]);
2059	#if defined(HAS_FCNTL) && defined(F_SETFD)
2060	/* Close error pipe automatically if exec works */
2061	fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2062	#endif
2063	}
2064	/* Now dup our end of _the_ pipe to right position */
2065	if (p[THIS] != (*mode == 'r')) {
2066	PerlLIO_dup2(p[THIS], *mode == 'r');
2067	PerlLIO_close(p[THIS]);
2068	if (p[THAT] != (mode == 'r')) / if dup2() didn't close it */
2069	PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2070	}
2071	else
2072	PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2073	#if !defined(HAS_FCNTL) \|\| !defined(F_SETFD)
2074	/* No automatic close - do it by hand */
2075	# ifndef NOFILE
2076	# define NOFILE 20
2077	# endif
2078	{
2079	int fd;
2080
2081	for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2082	if (fd != pp[1])
2083	PerlLIO_close(fd);
2084	}
2085	}
2086	#endif
2087	do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2088	PerlProc__exit(1);
2089	#undef THIS
2090	#undef THAT
2091	}
2092	/* Parent */
2093	do_execfree(); /* free any memory malloced by child on fork */
2094	if (did_pipes)
2095	PerlLIO_close(pp[1]);
2096	/* Keep the lower of the two fd numbers */
2097	if (p[that] < p[This]) {
2098	PerlLIO_dup2(p[This], p[that]);
2099	PerlLIO_close(p[This]);
2100	p[This] = p[that];
2101	}
2102	else
2103	PerlLIO_close(p[that]); /* close child's end of pipe */
2104
2105	LOCK_FDPID_MUTEX;
2106	sv = *av_fetch(PL_fdpid,p[This],TRUE);
2107	UNLOCK_FDPID_MUTEX;
2108	(void)SvUPGRADE(sv,SVt_IV);
2109	SvIV_set(sv, pid);
2110	PL_forkprocess = pid;
2111	/* If we managed to get status pipe check for exec fail */
2112	if (did_pipes && pid > 0) {
2113	int errkid;
2114	int n = 0, n1;
2115
2116	while (n < sizeof(int)) {
2117	n1 = PerlLIO_read(pp[0],
2118	(void)(((char)&errkid)+n),
2119	(sizeof(int)) - n);
2120	if (n1 <= 0)
2121	break;
2122	n += n1;
2123	}
2124	PerlLIO_close(pp[0]);
2125	did_pipes = 0;
2126	if (n) { /* Error */
2127	int pid2, status;
2128	PerlLIO_close(p[This]);
2129	if (n != sizeof(int))
2130	Perl_croak(aTHX_ "panic: kid popen errno read");
2131	do {
2132	pid2 = wait4pid(pid, &status, 0);
2133	} while (pid2 == -1 && errno == EINTR);
2134	errno = errkid; /* Propagate errno from kid */
2135	return Nullfp;
2136	}
2137	}
2138	if (did_pipes)
2139	PerlLIO_close(pp[0]);
2140	return PerlIO_fdopen(p[This], mode);
2141	#else
2142	Perl_croak(aTHX_ "List form of piped open not implemented");
2143	return (PerlIO *) NULL;
2144	#endif
2145	}
2146
2147	/* VMS' my_popen() is in VMS.c, same with OS/2. */
2148	#if (!defined(DOSISH) \|\| defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2149	PerlIO *
2150	Perl_my_popen(pTHX_ char cmd, char mode)
2151	{
2152	int p[2];
2153	register I32 This, that;
2154	register Pid_t pid;
2155	SV *sv;
2156	const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2157	I32 did_pipes = 0;
2158	int pp[2];
2159
2160	PERL_FLUSHALL_FOR_CHILD;
2161	#ifdef OS2
2162	if (doexec) {
2163	return my_syspopen(aTHX_ cmd,mode);
2164	}
2165	#endif
2166	This = (*mode == 'w');
2167	that = !This;
2168	if (doexec && PL_tainting) {
2169	taint_env();
2170	taint_proper("Insecure %s%s", "EXEC");
2171	}
2172	if (PerlProc_pipe(p) < 0)
2173	return Nullfp;
2174	if (doexec && PerlProc_pipe(pp) >= 0)
2175	did_pipes = 1;
2176	while ((pid = PerlProc_fork()) < 0) {
2177	if (errno != EAGAIN) {
2178	PerlLIO_close(p[This]);
2179	PerlLIO_close(p[that]);
2180	if (did_pipes) {
2181	PerlLIO_close(pp[0]);
2182	PerlLIO_close(pp[1]);
2183	}
2184	if (!doexec)
2185	Perl_croak(aTHX_ "Can't fork");
2186	return Nullfp;
2187	}
2188	sleep(5);
2189	}
2190	if (pid == 0) {
2191	GV* tmpgv;
2192
2193	#undef THIS
2194	#undef THAT
2195	#define THIS that
2196	#define THAT This
2197	if (did_pipes) {
2198	PerlLIO_close(pp[0]);
2199	#if defined(HAS_FCNTL) && defined(F_SETFD)
2200	fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2201	#endif
2202	}
2203	if (p[THIS] != (*mode == 'r')) {
2204	PerlLIO_dup2(p[THIS], *mode == 'r');
2205	PerlLIO_close(p[THIS]);
2206	if (p[THAT] != (mode == 'r')) / if dup2() didn't close it */
2207	PerlLIO_close(p[THAT]);
2208	}
2209	else
2210	PerlLIO_close(p[THAT]);
2211	#ifndef OS2
2212	if (doexec) {
2213	#if !defined(HAS_FCNTL) \|\| !defined(F_SETFD)
2214	#ifndef NOFILE
2215	#define NOFILE 20
2216	#endif
2217	{
2218	int fd;
2219
2220	for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2221	if (fd != pp[1])
2222	PerlLIO_close(fd);
2223	}
2224	#endif
2225	/* may or may not use the shell */
2226	do_exec3(cmd, pp[1], did_pipes);
2227	PerlProc__exit(1);
2228	}
2229	#endif /* defined OS2 */
2230	if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2231	SvREADONLY_off(GvSV(tmpgv));
2232	sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2233	SvREADONLY_on(GvSV(tmpgv));
2234	}
2235	#ifdef THREADS_HAVE_PIDS
2236	PL_ppid = (IV)getppid();
2237	#endif
2238	PL_forkprocess = 0;
2239	hv_clear(PL_pidstatus); /* we have no children */
2240	return Nullfp;
2241	#undef THIS
2242	#undef THAT
2243	}
2244	do_execfree(); /* free any memory malloced by child on vfork */
2245	if (did_pipes)
2246	PerlLIO_close(pp[1]);
2247	if (p[that] < p[This]) {
2248	PerlLIO_dup2(p[This], p[that]);
2249	PerlLIO_close(p[This]);
2250	p[This] = p[that];
2251	}
2252	else
2253	PerlLIO_close(p[that]);
2254
2255	LOCK_FDPID_MUTEX;
2256	sv = *av_fetch(PL_fdpid,p[This],TRUE);
2257	UNLOCK_FDPID_MUTEX;
2258	(void)SvUPGRADE(sv,SVt_IV);
2259	SvIV_set(sv, pid);
2260	PL_forkprocess = pid;
2261	if (did_pipes && pid > 0) {
2262	int errkid;
2263	int n = 0, n1;
2264
2265	while (n < sizeof(int)) {
2266	n1 = PerlLIO_read(pp[0],
2267	(void)(((char)&errkid)+n),
2268	(sizeof(int)) - n);
2269	if (n1 <= 0)
2270	break;
2271	n += n1;
2272	}
2273	PerlLIO_close(pp[0]);
2274	did_pipes = 0;
2275	if (n) { /* Error */
2276	int pid2, status;
2277	PerlLIO_close(p[This]);
2278	if (n != sizeof(int))
2279	Perl_croak(aTHX_ "panic: kid popen errno read");
2280	do {
2281	pid2 = wait4pid(pid, &status, 0);
2282	} while (pid2 == -1 && errno == EINTR);
2283	errno = errkid; /* Propagate errno from kid */
2284	return Nullfp;
2285	}
2286	}
2287	if (did_pipes)
2288	PerlLIO_close(pp[0]);
2289	return PerlIO_fdopen(p[This], mode);
2290	}
2291	#else
2292	#if defined(atarist) \|\| defined(EPOC)
2293	FILE *popen();
2294	PerlIO *
2295	Perl_my_popen(pTHX_ char cmd, char mode)
2296	{
2297	PERL_FLUSHALL_FOR_CHILD;
2298	/* Call system's popen() to get a FILE *, then import it.
2299	used 0 for 2nd parameter to PerlIO_importFILE;
2300	apparently not used
2301	*/
2302	return PerlIO_importFILE(popen(cmd, mode), 0);
2303	}
2304	#else
2305	#if defined(DJGPP)
2306	FILE *djgpp_popen();
2307	PerlIO *
2308	Perl_my_popen(pTHX_ char cmd, char mode)
2309	{
2310	PERL_FLUSHALL_FOR_CHILD;
2311	/* Call system's popen() to get a FILE *, then import it.
2312	used 0 for 2nd parameter to PerlIO_importFILE;
2313	apparently not used
2314	*/
2315	return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2316	}
2317	#endif
2318	#endif
2319
2320	#endif /* !DOSISH */
2321
2322	/* this is called in parent before the fork() */
2323	void
2324	Perl_atfork_lock(void)
2325	{
2326	#if defined(USE_5005THREADS) \|\| defined(USE_ITHREADS)
2327	/* locks must be held in locking order (if any) */
2328	# ifdef MYMALLOC
2329	MUTEX_LOCK(&PL_malloc_mutex);
2330	# endif
2331	OP_REFCNT_LOCK;
2332	#endif
2333	}
2334
2335	/* this is called in both parent and child after the fork() */
2336	void
2337	Perl_atfork_unlock(void)
2338	{
2339	#if defined(USE_5005THREADS) \|\| defined(USE_ITHREADS)
2340	/* locks must be released in same order as in atfork_lock() */
2341	# ifdef MYMALLOC
2342	MUTEX_UNLOCK(&PL_malloc_mutex);
2343	# endif
2344	OP_REFCNT_UNLOCK;
2345	#endif
2346	}
2347
2348	Pid_t
2349	Perl_my_fork(void)
2350	{
2351	#if defined(HAS_FORK)
2352	Pid_t pid;
2353	#if (defined(USE_5005THREADS) \|\| defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2354	atfork_lock();
2355	pid = fork();
2356	atfork_unlock();
2357	#else
2358	/* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2359	* handlers elsewhere in the code */
2360	pid = fork();
2361	#endif
2362	return pid;
2363	#else
2364	/* this "canna happen" since nothing should be calling here if !HAS_FORK */
2365	Perl_croak_nocontext("fork() not available");
2366	return 0;
2367	#endif /* HAS_FORK */
2368	}
2369
2370	#ifdef DUMP_FDS
2371	void
2372	Perl_dump_fds(pTHX_ char *s)
2373	{
2374	int fd;
2375	Stat_t tmpstatbuf;
2376
2377	PerlIO_printf(Perl_debug_log,"%s", s);
2378	for (fd = 0; fd < 32; fd++) {
2379	if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2380	PerlIO_printf(Perl_debug_log," %d",fd);
2381	}
2382	PerlIO_printf(Perl_debug_log,"\n");
2383	return;
2384	}
2385	#endif /* DUMP_FDS */
2386
2387	#ifndef HAS_DUP2
2388	int
2389	dup2(int oldfd, int newfd)
2390	{
2391	#if defined(HAS_FCNTL) && defined(F_DUPFD)
2392	if (oldfd == newfd)
2393	return oldfd;
2394	PerlLIO_close(newfd);
2395	return fcntl(oldfd, F_DUPFD, newfd);
2396	#else
2397	#define DUP2_MAX_FDS 256
2398	int fdtmp[DUP2_MAX_FDS];
2399	I32 fdx = 0;
2400	int fd;
2401
2402	if (oldfd == newfd)
2403	return oldfd;
2404	PerlLIO_close(newfd);
2405	/* good enough for low fd's... */
2406	while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2407	if (fdx >= DUP2_MAX_FDS) {
2408	PerlLIO_close(fd);
2409	fd = -1;
2410	break;
2411	}
2412	fdtmp[fdx++] = fd;
2413	}
2414	while (fdx > 0)
2415	PerlLIO_close(fdtmp[--fdx]);
2416	return fd;
2417	#endif
2418	}
2419	#endif
2420
2421	#ifndef PERL_MICRO
2422	#ifdef HAS_SIGACTION
2423
2424	#ifdef MACOS_TRADITIONAL
2425	/* We don't want restart behavior on MacOS */
2426	#undef SA_RESTART
2427	#endif
2428
2429	Sighandler_t
2430	Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2431	{
2432	struct sigaction act, oact;
2433
2434	#ifdef USE_ITHREADS
2435	/* only "parent" interpreter can diddle signals */
2436	if (PL_curinterp != aTHX)
2437	return SIG_ERR;
2438	#endif
2439
2440	act.sa_handler = handler;
2441	sigemptyset(&act.sa_mask);
2442	act.sa_flags = 0;
2443	#ifdef SA_RESTART
2444	if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2445	act.sa_flags \|= SA_RESTART; /* SVR4, 4.3+BSD */
2446	#endif
2447	#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2448	if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2449	act.sa_flags \|= SA_NOCLDWAIT;
2450	#endif
2451	if (sigaction(signo, &act, &oact) == -1)
2452	return SIG_ERR;
2453	else
2454	return oact.sa_handler;
2455	}
2456
2457	Sighandler_t
2458	Perl_rsignal_state(pTHX_ int signo)
2459	{
2460	struct sigaction oact;
2461
2462	if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2463	return SIG_ERR;
2464	else
2465	return oact.sa_handler;
2466	}
2467
2468	int
2469	Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2470	{
2471	struct sigaction act;
2472
2473	#ifdef USE_ITHREADS
2474	/* only "parent" interpreter can diddle signals */
2475	if (PL_curinterp != aTHX)
2476	return -1;
2477	#endif
2478
2479	act.sa_handler = handler;
2480	sigemptyset(&act.sa_mask);
2481	act.sa_flags = 0;
2482	#ifdef SA_RESTART
2483	if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2484	act.sa_flags \|= SA_RESTART; /* SVR4, 4.3+BSD */
2485	#endif
2486	#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2487	if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2488	act.sa_flags \|= SA_NOCLDWAIT;
2489	#endif
2490	return sigaction(signo, &act, save);
2491	}
2492
2493	int
2494	Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2495	{
2496	#ifdef USE_ITHREADS
2497	/* only "parent" interpreter can diddle signals */
2498	if (PL_curinterp != aTHX)
2499	return -1;
2500	#endif
2501
2502	return sigaction(signo, save, (struct sigaction *)NULL);
2503	}
2504
2505	#else /* !HAS_SIGACTION */
2506
2507	Sighandler_t
2508	Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2509	{
2510	#if defined(USE_ITHREADS) && !defined(WIN32)
2511	/* only "parent" interpreter can diddle signals */
2512	if (PL_curinterp != aTHX)
2513	return SIG_ERR;
2514	#endif
2515
2516	return PerlProc_signal(signo, handler);
2517	}
2518
2519	static int PL_sig_trapped; /* XXX signals are process-wide anyway, so we
2520	ignore the implications of this for threading */
2521
2522	static
2523	Signal_t
2524	sig_trap(int signo)
2525	{
2526	PL_sig_trapped++;
2527	}
2528
2529	Sighandler_t
2530	Perl_rsignal_state(pTHX_ int signo)
2531	{
2532	Sighandler_t oldsig;
2533
2534	#if defined(USE_ITHREADS) && !defined(WIN32)
2535	/* only "parent" interpreter can diddle signals */
2536	if (PL_curinterp != aTHX)
2537	return SIG_ERR;
2538	#endif
2539
2540	PL_sig_trapped = 0;
2541	oldsig = PerlProc_signal(signo, sig_trap);
2542	PerlProc_signal(signo, oldsig);
2543	if (PL_sig_trapped)
2544	PerlProc_kill(PerlProc_getpid(), signo);
2545	return oldsig;
2546	}
2547
2548	int
2549	Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2550	{
2551	#if defined(USE_ITHREADS) && !defined(WIN32)
2552	/* only "parent" interpreter can diddle signals */
2553	if (PL_curinterp != aTHX)
2554	return -1;
2555	#endif
2556	*save = PerlProc_signal(signo, handler);
2557	return (*save == SIG_ERR) ? -1 : 0;
2558	}
2559
2560	int
2561	Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2562	{
2563	#if defined(USE_ITHREADS) && !defined(WIN32)
2564	/* only "parent" interpreter can diddle signals */
2565	if (PL_curinterp != aTHX)
2566	return -1;
2567	#endif
2568	return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2569	}
2570
2571	#endif /* !HAS_SIGACTION */
2572	#endif /* !PERL_MICRO */
2573
2574	/* VMS' my_pclose() is in VMS.c; same with OS/2 */
2575	#if (!defined(DOSISH) \|\| defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2576	I32
2577	Perl_my_pclose(pTHX_ PerlIO *ptr)
2578	{
2579	Sigsave_t hstat, istat, qstat;
2580	int status;
2581	SV **svp;
2582	Pid_t pid;
2583	Pid_t pid2;
2584	bool close_failed;
2585	int saved_errno = 0;
2586	#ifdef VMS
2587	int saved_vaxc_errno;
2588	#endif
2589	#ifdef WIN32
2590	int saved_win32_errno;
2591	#endif
2592
2593	LOCK_FDPID_MUTEX;
2594	svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2595	UNLOCK_FDPID_MUTEX;
2596	pid = (SvTYPE(svp) == SVt_IV) ? SvIVX(svp) : -1;
2597	SvREFCNT_dec(*svp);
2598	*svp = &PL_sv_undef;
2599	#ifdef OS2
2600	if (pid == -1) { /* Opened by popen. */
2601	return my_syspclose(ptr);
2602	}
2603	#endif
2604	if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2605	saved_errno = errno;
2606	#ifdef VMS
2607	saved_vaxc_errno = vaxc$errno;
2608	#endif
2609	#ifdef WIN32
2610	saved_win32_errno = GetLastError();
2611	#endif
2612	}
2613	#ifdef UTS
2614	if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2615	#endif
2616	#ifndef PERL_MICRO
2617	rsignal_save(SIGHUP, SIG_IGN, &hstat);
2618	rsignal_save(SIGINT, SIG_IGN, &istat);
2619	rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2620	#endif
2621	do {
2622	pid2 = wait4pid(pid, &status, 0);
2623	} while (pid2 == -1 && errno == EINTR);
2624	#ifndef PERL_MICRO
2625	rsignal_restore(SIGHUP, &hstat);
2626	rsignal_restore(SIGINT, &istat);
2627	rsignal_restore(SIGQUIT, &qstat);
2628	#endif
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(NETWARE)) && !defined(MACOS_TRADITIONAL)
2638	I32
2639	Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2640	{
2641	I32 result = 0;
2642	if (!pid)
2643	return -1;
2644	#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) \|\| defined(HAS_WAITPID_RUNTIME)
2645	{
2646	char spid[TYPE_CHARS(IV)];
2647
2648	if (pid > 0) {
2649	SV** svp;
2650	sprintf(spid, "%"IVdf, (IV)pid);
2651	svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2652	if (svp && *svp != &PL_sv_undef) {
2653	statusp = SvIVX(svp);
2654	(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2655	return pid;
2656	}
2657	}
2658	else {
2659	HE *entry;
2660
2661	hv_iterinit(PL_pidstatus);
2662	if ((entry = hv_iternext(PL_pidstatus))) {
2663	SV *sv = hv_iterval(PL_pidstatus,entry);
2664
2665	pid = atoi(hv_iterkey(entry,(I32*)statusp));
2666	*statusp = SvIVX(sv);
2667	sprintf(spid, "%"IVdf, (IV)pid);
2668	(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2669	return pid;
2670	}
2671	}
2672	}
2673	#endif
2674	#ifdef HAS_WAITPID
2675	# ifdef HAS_WAITPID_RUNTIME
2676	if (!HAS_WAITPID_RUNTIME)
2677	goto hard_way;
2678	# endif
2679	result = PerlProc_waitpid(pid,statusp,flags);
2680	goto finish;
2681	#endif
2682	#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2683	result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2684	goto finish;
2685	#endif
2686	#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) \|\| defined(HAS_WAITPID_RUNTIME)
2687	#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2688	hard_way:
2689	#endif
2690	{
2691	if (flags)
2692	Perl_croak(aTHX_ "Can't do waitpid with flags");
2693	else {
2694	while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2695	pidgone(result,*statusp);
2696	if (result < 0)
2697	*statusp = -1;
2698	}
2699	}
2700	#endif
2701	#if defined(HAS_WAITPID) \|\| defined(HAS_WAIT4)
2702	finish:
2703	#endif
2704	if (result < 0 && errno == EINTR) {
2705	PERL_ASYNC_CHECK();
2706	}
2707	return result;
2708	}
2709	#endif /* !DOSISH \|\| OS2 \|\| WIN32 \|\| NETWARE */
2710
2711	void
2712	Perl_pidgone(pTHX_ Pid_t pid, int status)
2713	{
2714	register SV *sv;
2715	char spid[TYPE_CHARS(IV)];
2716
2717	sprintf(spid, "%"IVdf, (IV)pid);
2718	sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2719	(void)SvUPGRADE(sv,SVt_IV);
2720	SvIV_set(sv, status);
2721	return;
2722	}
2723
2724	#if defined(atarist) \|\| defined(OS2) \|\| defined(EPOC)
2725	int pclose();
2726	#ifdef HAS_FORK
2727	int /* Cannot prototype with I32
2728	in os2ish.h. */
2729	my_syspclose(PerlIO *ptr)
2730	#else
2731	I32
2732	Perl_my_pclose(pTHX_ PerlIO *ptr)
2733	#endif
2734	{
2735	/* Needs work for PerlIO ! */
2736	FILE *f = PerlIO_findFILE(ptr);
2737	I32 result = pclose(f);
2738	PerlIO_releaseFILE(ptr,f);
2739	return result;
2740	}
2741	#endif
2742
2743	#if defined(DJGPP)
2744	int djgpp_pclose();
2745	I32
2746	Perl_my_pclose(pTHX_ PerlIO *ptr)
2747	{
2748	/* Needs work for PerlIO ! */
2749	FILE *f = PerlIO_findFILE(ptr);
2750	I32 result = djgpp_pclose(f);
2751	result = (result << 8) & 0xff00;
2752	PerlIO_releaseFILE(ptr,f);
2753	return result;
2754	}
2755	#endif
2756
2757	void
2758	Perl_repeatcpy(pTHX_ register char to, register const char from, I32 len, register I32 count)
2759	{
2760	register I32 todo;
2761	register const char *frombase = from;
2762
2763	if (len == 1) {
2764	register const char c = *from;
2765	while (count-- > 0)
2766	*to++ = c;
2767	return;
2768	}
2769	while (count-- > 0) {
2770	for (todo = len; todo > 0; todo--) {
2771	to++ = from++;
2772	}
2773	from = frombase;
2774	}
2775	}
2776
2777	#ifndef HAS_RENAME
2778	I32
2779	Perl_same_dirent(pTHX_ char a, char b)
2780	{
2781	char *fa = strrchr(a,'/');
2782	char *fb = strrchr(b,'/');
2783	Stat_t tmpstatbuf1;
2784	Stat_t tmpstatbuf2;
2785	SV *tmpsv = sv_newmortal();
2786
2787	if (fa)
2788	fa++;
2789	else
2790	fa = a;
2791	if (fb)
2792	fb++;
2793	else
2794	fb = b;
2795	if (strNE(a,b))
2796	return FALSE;
2797	if (fa == a)
2798	sv_setpvn(tmpsv, ".", 1);
2799	else
2800	sv_setpvn(tmpsv, a, fa - a);
2801	if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2802	return FALSE;
2803	if (fb == b)
2804	sv_setpvn(tmpsv, ".", 1);
2805	else
2806	sv_setpvn(tmpsv, b, fb - b);
2807	if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2808	return FALSE;
2809	return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2810	tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2811	}
2812	#endif /* !HAS_RENAME */
2813
2814	char*
2815	Perl_find_script(pTHX_ char scriptname, bool dosearch, char *search_ext,
2816	I32 flags)
2817	{
2818	const char *xfound = Nullch;
2819	char *xfailed = Nullch;
2820	char tmpbuf[MAXPATHLEN];
2821	register char *s;
2822	I32 len = 0;
2823	int retval;
2824	#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2825	# define SEARCH_EXTS ".bat", ".cmd", NULL
2826	# define MAX_EXT_LEN 4
2827	#endif
2828	#ifdef OS2
2829	# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2830	# define MAX_EXT_LEN 4
2831	#endif
2832	#ifdef VMS
2833	# define SEARCH_EXTS ".pl", ".com", NULL
2834	# define MAX_EXT_LEN 4
2835	#endif
2836	/* additional extensions to try in each dir if scriptname not found */
2837	#ifdef SEARCH_EXTS
2838	const char *const exts[] = { SEARCH_EXTS };
2839	const char const const ext =
2840	search_ext ? (const char const const)search_ext : exts;
2841	int extidx = 0, i = 0;
2842	const char *curext = Nullch;
2843	#else
2844	PERL_UNUSED_ARG(search_ext);
2845	# define MAX_EXT_LEN 0
2846	#endif
2847
2848	/*
2849	* If dosearch is true and if scriptname does not contain path
2850	* delimiters, search the PATH for scriptname.
2851	*
2852	* If SEARCH_EXTS is also defined, will look for each
2853	* scriptname{SEARCH_EXTS} whenever scriptname is not found
2854	* while searching the PATH.
2855	*
2856	* Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2857	* proceeds as follows:
2858	* If DOSISH or VMSISH:
2859	* + look for ./scriptname{,.foo,.bar}
2860	* + search the PATH for scriptname{,.foo,.bar}
2861	*
2862	* If !DOSISH:
2863	* + look only in the PATH for scriptname{,.foo,.bar} (note
2864	* this will not look in '.' if it's not in the PATH)
2865	*/
2866	tmpbuf[0] = '\0';
2867
2868	#ifdef VMS
2869	# ifdef ALWAYS_DEFTYPES
2870	len = strlen(scriptname);
2871	if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2872	int hasdir, idx = 0, deftypes = 1;
2873	bool seen_dot = 1;
2874
2875	hasdir = !dosearch \|\| (strpbrk(scriptname,":[</") != Nullch) ;
2876	# else
2877	if (dosearch) {
2878	int hasdir, idx = 0, deftypes = 1;
2879	bool seen_dot = 1;
2880
2881	hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2882	# endif
2883	/* The first time through, just add SEARCH_EXTS to whatever we
2884	* already have, so we can check for default file types. */
2885	while (deftypes \|\|
2886	(!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2887	{
2888	if (deftypes) {
2889	deftypes = 0;
2890	*tmpbuf = '\0';
2891	}
2892	if ((strlen(tmpbuf) + strlen(scriptname)
2893	+ MAX_EXT_LEN) >= sizeof tmpbuf)
2894	continue; /* don't search dir with too-long name */
2895	strcat(tmpbuf, scriptname);
2896	#else /* !VMS */
2897
2898	#ifdef DOSISH
2899	if (strEQ(scriptname, "-"))
2900	dosearch = 0;
2901	if (dosearch) { /* Look in '.' first. */
2902	char *cur = scriptname;
2903	#ifdef SEARCH_EXTS
2904	if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2905	while (ext[i])
2906	if (strEQ(ext[i++],curext)) {
2907	extidx = -1; /* already has an ext */
2908	break;
2909	}
2910	do {
2911	#endif
2912	DEBUG_p(PerlIO_printf(Perl_debug_log,
2913	"Looking for %s\n",cur));
2914	if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2915	&& !S_ISDIR(PL_statbuf.st_mode)) {
2916	dosearch = 0;
2917	scriptname = cur;
2918	#ifdef SEARCH_EXTS
2919	break;
2920	#endif
2921	}
2922	#ifdef SEARCH_EXTS
2923	if (cur == scriptname) {
2924	len = strlen(scriptname);
2925	if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2926	break;
2927	/* FIXME? Convert to memcpy */
2928	cur = strcpy(tmpbuf, scriptname);
2929	}
2930	} while (extidx >= 0 && ext[extidx] /* try an extension? */
2931	&& strcpy(tmpbuf+len, ext[extidx++]));
2932	#endif
2933	}
2934	#endif
2935
2936	#ifdef MACOS_TRADITIONAL
2937	if (dosearch && !strchr(scriptname, ':') &&
2938	(s = PerlEnv_getenv("Commands")))
2939	#else
2940	if (dosearch && !strchr(scriptname, '/')
2941	#ifdef DOSISH
2942	&& !strchr(scriptname, '\\')
2943	#endif
2944	&& (s = PerlEnv_getenv("PATH")))
2945	#endif
2946	{
2947	bool seen_dot = 0;
2948
2949	PL_bufend = s + strlen(s);
2950	while (s < PL_bufend) {
2951	#ifdef MACOS_TRADITIONAL
2952	s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2953	',',
2954	&len);
2955	#else
2956	#if defined(atarist) \|\| defined(DOSISH)
2957	for (len = 0; *s
2958	# ifdef atarist
2959	&& *s != ','
2960	# endif
2961	&& *s != ';'; len++, s++) {
2962	if (len < sizeof tmpbuf)
2963	tmpbuf[len] = *s;
2964	}
2965	if (len < sizeof tmpbuf)
2966	tmpbuf[len] = '\0';
2967	#else /* ! (atarist \|\| DOSISH) */
2968	s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2969	':',
2970	&len);
2971	#endif /* ! (atarist \|\| DOSISH) */
2972	#endif /* MACOS_TRADITIONAL */
2973	if (s < PL_bufend)
2974	s++;
2975	if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2976	continue; /* don't search dir with too-long name */
2977	#ifdef MACOS_TRADITIONAL
2978	if (len && tmpbuf[len - 1] != ':')
2979	tmpbuf[len++] = ':';
2980	#else
2981	if (len
2982	# if defined(atarist) \|\| defined(__MINT__) \|\| defined(DOSISH)
2983	&& tmpbuf[len - 1] != '/'
2984	&& tmpbuf[len - 1] != '\\'
2985	# endif
2986	)
2987	tmpbuf[len++] = '/';
2988	if (len == 2 && tmpbuf[0] == '.')
2989	seen_dot = 1;
2990	#endif
2991	/* FIXME? Convert to memcpy by storing previous strlen(scriptname)
2992	*/
2993	(void)strcpy(tmpbuf + len, scriptname);
2994	#endif /* !VMS */
2995
2996	#ifdef SEARCH_EXTS
2997	len = strlen(tmpbuf);
2998	if (extidx > 0) /* reset after previous loop */
2999	extidx = 0;
3000	do {
3001	#endif
3002	DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3003	retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3004	if (S_ISDIR(PL_statbuf.st_mode)) {
3005	retval = -1;
3006	}
3007	#ifdef SEARCH_EXTS
3008	} while ( retval < 0 /* not there */
3009	&& extidx>=0 && ext[extidx] /* try an extension? */
3010	&& strcpy(tmpbuf+len, ext[extidx++])
3011	);
3012	#endif
3013	if (retval < 0)
3014	continue;
3015	if (S_ISREG(PL_statbuf.st_mode)
3016	&& cando(S_IRUSR,TRUE,&PL_statbuf)
3017	#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3018	&& cando(S_IXUSR,TRUE,&PL_statbuf)
3019	#endif
3020	)
3021	{
3022	xfound = tmpbuf; /* bingo! */
3023	break;
3024	}
3025	if (!xfailed)
3026	xfailed = savepv(tmpbuf);
3027	}
3028	#ifndef DOSISH
3029	if (!xfound && !seen_dot && !xfailed &&
3030	(PerlLIO_stat(scriptname,&PL_statbuf) < 0
3031	\|\| S_ISDIR(PL_statbuf.st_mode)))
3032	#endif
3033	seen_dot = 1; /* Disable message. */
3034	if (!xfound) {
3035	if (flags & 1) { /* do or die? */
3036	Perl_croak(aTHX_ "Can't %s %s%s%s",
3037	(xfailed ? "execute" : "find"),
3038	(xfailed ? xfailed : scriptname),
3039	(xfailed ? "" : " on PATH"),
3040	(xfailed \|\| seen_dot) ? "" : ", '.' not in PATH");
3041	}
3042	scriptname = Nullch;
3043	}
3044	Safefree(xfailed);
3045	/* Cast because we're not changing function prototypes in maint. */
3046	scriptname = (char *) xfound;
3047	}
3048	return (scriptname ? savepv(scriptname) : Nullch);
3049	}
3050
3051	#ifndef PERL_GET_CONTEXT_DEFINED
3052
3053	void *
3054	Perl_get_context(void)
3055	{
3056	#if defined(USE_5005THREADS) \|\| defined(USE_ITHREADS)
3057	# ifdef OLD_PTHREADS_API
3058	pthread_addr_t t;
3059	if (pthread_getspecific(PL_thr_key, &t))
3060	Perl_croak_nocontext("panic: pthread_getspecific");
3061	return (void*)t;
3062	# else
3063	# ifdef I_MACH_CTHREADS
3064	return (void*)cthread_data(cthread_self());
3065	# else
3066	return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3067	# endif
3068	# endif
3069	#else
3070	return (void*)NULL;
3071	#endif
3072	}
3073
3074	void
3075	Perl_set_context(void *t)
3076	{
3077	#if defined(USE_5005THREADS) \|\| defined(USE_ITHREADS)
3078	# ifdef I_MACH_CTHREADS
3079	cthread_set_data(cthread_self(), t);
3080	# else
3081	if (pthread_setspecific(PL_thr_key, t))
3082	Perl_croak_nocontext("panic: pthread_setspecific");
3083	# endif
3084	#else
3085	PERL_UNUSED_ARG(t);
3086	#endif
3087	}
3088
3089	#endif /* !PERL_GET_CONTEXT_DEFINED */
3090
3091	#ifdef USE_5005THREADS
3092
3093	#ifdef FAKE_THREADS
3094	/* Very simplistic scheduler for now */
3095	void
3096	schedule(void)
3097	{
3098	thr = thr->i.next_run;
3099	}
3100
3101	void
3102	Perl_cond_init(pTHX_ perl_cond *cp)
3103	{
3104	*cp = 0;
3105	}
3106
3107	void
3108	Perl_cond_signal(pTHX_ perl_cond *cp)
3109	{
3110	perl_os_thread t;
3111	perl_cond cond = *cp;
3112
3113	if (!cond)
3114	return;
3115	t = cond->thread;
3116	/* Insert t in the runnable queue just ahead of us */
3117	t->i.next_run = thr->i.next_run;
3118	thr->i.next_run->i.prev_run = t;
3119	t->i.prev_run = thr;
3120	thr->i.next_run = t;
3121	thr->i.wait_queue = 0;
3122	/* Remove from the wait queue */
3123	*cp = cond->next;
3124	Safefree(cond);
3125	}
3126
3127	void
3128	Perl_cond_broadcast(pTHX_ perl_cond *cp)
3129	{
3130	perl_os_thread t;
3131	perl_cond cond, cond_next;
3132
3133	for (cond = *cp; cond; cond = cond_next) {
3134	t = cond->thread;
3135	/* Insert t in the runnable queue just ahead of us */
3136	t->i.next_run = thr->i.next_run;
3137	thr->i.next_run->i.prev_run = t;
3138	t->i.prev_run = thr;
3139	thr->i.next_run = t;
3140	thr->i.wait_queue = 0;
3141	/* Remove from the wait queue */
3142	cond_next = cond->next;
3143	Safefree(cond);
3144	}
3145	*cp = 0;
3146	}
3147
3148	void
3149	Perl_cond_wait(pTHX_ perl_cond *cp)
3150	{
3151	perl_cond cond;
3152
3153	if (thr->i.next_run == thr)
3154	Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3155
3156	New(666, cond, 1, struct perl_wait_queue);
3157	cond->thread = thr;
3158	cond->next = *cp;
3159	*cp = cond;
3160	thr->i.wait_queue = cond;
3161	/* Remove ourselves from runnable queue */
3162	thr->i.next_run->i.prev_run = thr->i.prev_run;
3163	thr->i.prev_run->i.next_run = thr->i.next_run;
3164	}
3165	#endif /* FAKE_THREADS */
3166
3167	MAGIC *
3168	Perl_condpair_magic(pTHX_ SV *sv)
3169	{
3170	MAGIC *mg;
3171
3172	(void)SvUPGRADE(sv, SVt_PVMG);
3173	mg = mg_find(sv, PERL_MAGIC_mutex);
3174	if (!mg) {
3175	condpair_t *cp;
3176
3177	New(53, cp, 1, condpair_t);
3178	MUTEX_INIT(&cp->mutex);
3179	COND_INIT(&cp->owner_cond);
3180	COND_INIT(&cp->cond);
3181	cp->owner = 0;
3182	LOCK_CRED_MUTEX; /* XXX need separate mutex? */
3183	mg = mg_find(sv, PERL_MAGIC_mutex);
3184	if (mg) {
3185	/* someone else beat us to initialising it */
3186	UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3187	MUTEX_DESTROY(&cp->mutex);
3188	COND_DESTROY(&cp->owner_cond);
3189	COND_DESTROY(&cp->cond);
3190	Safefree(cp);
3191	}
3192	else {
3193	sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
3194	mg = SvMAGIC(sv);
3195	mg->mg_ptr = (char *)cp;
3196	mg->mg_len = sizeof(cp);
3197	UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3198	DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3199	"%p: condpair_magic %p\n", thr, sv)));
3200	}
3201	}
3202	return mg;
3203	}
3204
3205	SV *
3206	Perl_sv_lock(pTHX_ SV *osv)
3207	{
3208	MAGIC *mg;
3209	SV *sv = osv;
3210
3211	LOCK_SV_LOCK_MUTEX;
3212	if (SvROK(sv)) {
3213	sv = SvRV(sv);
3214	}
3215
3216	mg = condpair_magic(sv);
3217	MUTEX_LOCK(MgMUTEXP(mg));
3218	if (MgOWNER(mg) == thr)
3219	MUTEX_UNLOCK(MgMUTEXP(mg));
3220	else {
3221	while (MgOWNER(mg))
3222	COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3223	MgOWNER(mg) = thr;
3224	DEBUG_S(PerlIO_printf(Perl_debug_log,
3225	"0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3226	PTR2UV(thr), PTR2UV(sv)));
3227	MUTEX_UNLOCK(MgMUTEXP(mg));
3228	SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3229	}
3230	UNLOCK_SV_LOCK_MUTEX;
3231	return sv;
3232	}
3233
3234	/*
3235	* Make a new perl thread structure using t as a prototype. Some of the
3236	* fields for the new thread are copied from the prototype thread, t,
3237	* so t should not be running in perl at the time this function is
3238	* called. The use by ext/Thread/Thread.xs in core perl (where t is the
3239	* thread calling new_struct_thread) clearly satisfies this constraint.
3240	*/
3241	struct perl_thread *
3242	Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3243	{
3244	#if !defined(PERL_IMPLICIT_CONTEXT)
3245	struct perl_thread *thr;
3246	#endif
3247	SV *sv;
3248	SV **svp;
3249	I32 i;
3250
3251	sv = newSVpvn("", 0);
3252	SvGROW(sv, sizeof(struct perl_thread) + 1);
3253	SvCUR_set(sv, sizeof(struct perl_thread));
3254	thr = (Thread) SvPVX(sv);
3255	#ifdef DEBUGGING
3256	Poison(thr, 1, struct perl_thread);
3257	PL_markstack = 0;
3258	PL_scopestack = 0;
3259	PL_savestack = 0;
3260	PL_retstack = 0;
3261	PL_dirty = 0;
3262	PL_localizing = 0;
3263	Zero(&PL_hv_fetch_ent_mh, 1, HE);
3264	PL_efloatbuf = (char*)NULL;
3265	PL_efloatsize = 0;
3266	#else
3267	Zero(thr, 1, struct perl_thread);
3268	#endif
3269
3270	thr->oursv = sv;
3271	init_stacks();
3272
3273	PL_curcop = &PL_compiling;
3274	thr->interp = t->interp;
3275	thr->cvcache = newHV();
3276	thr->threadsv = newAV();
3277	thr->specific = newAV();
3278	thr->errsv = newSVpvn("", 0);
3279	thr->flags = THRf_R_JOINABLE;
3280	thr->thr_done = 0;
3281	MUTEX_INIT(&thr->mutex);
3282
3283	JMPENV_BOOTSTRAP;
3284
3285	PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL\|EVAL_WARNONLY\|EVAL_KEEPERR\|EVAL_INREQUIRE) */
3286	PL_restartop = 0;
3287
3288	PL_statname = NEWSV(66,0);
3289	PL_errors = newSVpvn("", 0);
3290	PL_maxscream = -1;
3291	PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3292	PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3293	PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3294	PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3295	PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3296	PL_regindent = 0;
3297	PL_reginterp_cnt = 0;
3298	PL_lastscream = Nullsv;
3299	PL_screamfirst = 0;
3300	PL_screamnext = 0;
3301	PL_reg_start_tmp = 0;
3302	PL_reg_start_tmpl = 0;
3303	PL_reg_poscache = Nullch;
3304
3305	PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3306
3307	/* parent thread's data needs to be locked while we make copy */
3308	MUTEX_LOCK(&t->mutex);
3309
3310	#ifdef PERL_FLEXIBLE_EXCEPTIONS
3311	PL_protect = t->Tprotect;
3312	#endif
3313
3314	PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3315	PL_defstash = t->Tdefstash; /* XXX maybe these should */
3316	PL_curstash = t->Tcurstash; /* always be set to main? */
3317
3318	PL_tainted = t->Ttainted;
3319	PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
3320	PL_rs = newSVsv(t->Trs);
3321	PL_last_in_gv = Nullgv;
3322	PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3323	PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3324	PL_chopset = t->Tchopset;
3325	PL_bodytarget = newSVsv(t->Tbodytarget);
3326	PL_toptarget = newSVsv(t->Ttoptarget);
3327	if (t->Tformtarget == t->Ttoptarget)
3328	PL_formtarget = PL_toptarget;
3329	else
3330	PL_formtarget = PL_bodytarget;
3331	PL_watchaddr = 0; /* XXX */
3332	PL_watchok = 0; /* XXX */
3333	PL_comppad = 0;
3334	PL_curpad = 0;
3335
3336	/* Initialise all per-thread SVs that the template thread used */
3337	svp = AvARRAY(t->threadsv);
3338	for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3339	if (svp && svp != &PL_sv_undef) {
3340	SV sv = newSVsv(svp);
3341	av_store(thr->threadsv, i, sv);
3342	sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3343	DEBUG_S(PerlIO_printf(Perl_debug_log,
3344	"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3345	(IV)i, t, thr));
3346	}
3347	}
3348	thr->threadsvp = AvARRAY(thr->threadsv);
3349
3350	MUTEX_LOCK(&PL_threads_mutex);
3351	PL_nthreads++;
3352	thr->tid = ++PL_threadnum;
3353	thr->next = t->next;
3354	thr->prev = t;
3355	t->next = thr;
3356	thr->next->prev = thr;
3357	MUTEX_UNLOCK(&PL_threads_mutex);
3358
3359	/* done copying parent's state */
3360	MUTEX_UNLOCK(&t->mutex);
3361
3362	#ifdef HAVE_THREAD_INTERN
3363	Perl_init_thread_intern(thr);
3364	#endif /* HAVE_THREAD_INTERN */
3365	return thr;
3366	}
3367	#endif /* USE_5005THREADS */
3368
3369	#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3370	struct perl_vars *
3371	Perl_GetVars(pTHX)
3372	{
3373	return &PL_Vars;
3374	}
3375	#endif
3376
3377	char **
3378	Perl_get_op_names(pTHX)
3379	{
3380	return (char **)PL_op_name;
3381	}
3382
3383	char **
3384	Perl_get_op_descs(pTHX)
3385	{
3386	return (char **)PL_op_desc;
3387	}
3388
3389	char *
3390	Perl_get_no_modify(pTHX)
3391	{
3392	/* Cast because we're not changing function prototypes in maint. */
3393	return (char *) PL_no_modify;
3394	}
3395
3396	U32 *
3397	Perl_get_opargs(pTHX)
3398	{
3399	return (U32 *)PL_opargs;
3400	}
3401
3402	PPADDR_t*
3403	Perl_get_ppaddr(pTHX)
3404	{
3405	return (PPADDR_t*)PL_ppaddr;
3406	}
3407
3408	#ifndef HAS_GETENV_LEN
3409	char *
3410	Perl_getenv_len(pTHX_ const char env_elem, unsigned long len)
3411	{
3412	char * const env_trans = PerlEnv_getenv(env_elem);
3413	if (env_trans)
3414	*len = strlen(env_trans);
3415	return env_trans;
3416	}
3417	#endif
3418
3419
3420	MGVTBL*
3421	Perl_get_vtbl(pTHX_ int vtbl_id)
3422	{
3423	const MGVTBL* result = Null(MGVTBL*);
3424
3425	switch(vtbl_id) {
3426	case want_vtbl_sv:
3427	result = &PL_vtbl_sv;
3428	break;
3429	case want_vtbl_env:
3430	result = &PL_vtbl_env;
3431	break;
3432	case want_vtbl_envelem:
3433	result = &PL_vtbl_envelem;
3434	break;
3435	case want_vtbl_sig:
3436	result = &PL_vtbl_sig;
3437	break;
3438	case want_vtbl_sigelem:
3439	result = &PL_vtbl_sigelem;
3440	break;
3441	case want_vtbl_pack:
3442	result = &PL_vtbl_pack;
3443	break;
3444	case want_vtbl_packelem:
3445	result = &PL_vtbl_packelem;
3446	break;
3447	case want_vtbl_dbline:
3448	result = &PL_vtbl_dbline;
3449	break;
3450	case want_vtbl_isa:
3451	result = &PL_vtbl_isa;
3452	break;
3453	case want_vtbl_isaelem:
3454	result = &PL_vtbl_isaelem;
3455	break;
3456	case want_vtbl_arylen:
3457	result = &PL_vtbl_arylen;
3458	break;
3459	case want_vtbl_glob:
3460	result = &PL_vtbl_glob;
3461	break;
3462	case want_vtbl_mglob:
3463	result = &PL_vtbl_mglob;
3464	break;
3465	case want_vtbl_nkeys:
3466	result = &PL_vtbl_nkeys;
3467	break;
3468	case want_vtbl_taint:
3469	result = &PL_vtbl_taint;
3470	break;
3471	case want_vtbl_substr:
3472	result = &PL_vtbl_substr;
3473	break;
3474	case want_vtbl_vec:
3475	result = &PL_vtbl_vec;
3476	break;
3477	case want_vtbl_pos:
3478	result = &PL_vtbl_pos;
3479	break;
3480	case want_vtbl_bm:
3481	result = &PL_vtbl_bm;
3482	break;
3483	case want_vtbl_fm:
3484	result = &PL_vtbl_fm;
3485	break;
3486	case want_vtbl_uvar:
3487	result = &PL_vtbl_uvar;
3488	break;
3489	#ifdef USE_5005THREADS
3490	case want_vtbl_mutex:
3491	result = &PL_vtbl_mutex;
3492	break;
3493	#endif
3494	case want_vtbl_defelem:
3495	result = &PL_vtbl_defelem;
3496	break;
3497	case want_vtbl_regexp:
3498	result = &PL_vtbl_regexp;
3499	break;
3500	case want_vtbl_regdata:
3501	result = &PL_vtbl_regdata;
3502	break;
3503	case want_vtbl_regdatum:
3504	result = &PL_vtbl_regdatum;
3505	break;
3506	#ifdef USE_LOCALE_COLLATE
3507	case want_vtbl_collxfrm:
3508	result = &PL_vtbl_collxfrm;
3509	break;
3510	#endif
3511	case want_vtbl_amagic:
3512	result = &PL_vtbl_amagic;
3513	break;
3514	case want_vtbl_amagicelem:
3515	result = &PL_vtbl_amagicelem;
3516	break;
3517	case want_vtbl_backref:
3518	result = &PL_vtbl_backref;
3519	break;
3520	case want_vtbl_utf8:
3521	result = &PL_vtbl_utf8;
3522	break;
3523	}
3524	return (MGVTBL*)result;
3525	}
3526
3527	I32
3528	Perl_my_fflush_all(pTHX)
3529	{
3530	#if defined(USE_PERLIO) \|\| defined(FFLUSH_NULL) \|\| defined(USE_SFIO)
3531	return PerlIO_flush(NULL);
3532	#else
3533	# if defined(HAS__FWALK)
3534	extern int fflush(FILE *);
3535	/* undocumented, unprototyped, but very useful BSDism */
3536	extern void _fwalk(int ()(FILE ));
3537	_fwalk(&fflush);
3538	return 0;
3539	# else
3540	# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3541	long open_max = -1;
3542	# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3543	open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3544	# else
3545	# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3546	open_max = sysconf(_SC_OPEN_MAX);
3547	# else
3548	# ifdef FOPEN_MAX
3549	open_max = FOPEN_MAX;
3550	# else
3551	# ifdef OPEN_MAX
3552	open_max = OPEN_MAX;
3553	# else
3554	# ifdef _NFILE
3555	open_max = _NFILE;
3556	# endif
3557	# endif
3558	# endif
3559	# endif
3560	# endif
3561	if (open_max > 0) {
3562	long i;
3563	for (i = 0; i < open_max; i++)
3564	if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3565	STDIO_STREAM_ARRAY[i]._file < open_max &&
3566	STDIO_STREAM_ARRAY[i]._flag)
3567	PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3568	return 0;
3569	}
3570	# endif
3571	SETERRNO(EBADF,RMS_IFI);
3572	return EOF;
3573	# endif
3574	#endif
3575	}
3576
3577	void
3578	Perl_report_evil_fh(pTHX_ GV gv, IO io, I32 op)
3579	{
3580	const char * const func =
3581	op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3582	op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3583	PL_op_desc[op];
3584	const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3585	const char * const type = OP_IS_SOCKET(op)
3586	\|\| (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3587	? "socket" : "filehandle";
3588	const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3589
3590	if (op == OP_phoney_OUTPUT_ONLY \|\| op == OP_phoney_INPUT_ONLY) {
3591	if (ckWARN(WARN_IO)) {
3592	const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3593	if (name && *name)
3594	Perl_warner(aTHX_ packWARN(WARN_IO),
3595	"Filehandle %s opened only for %sput",
3596	name, direction);
3597	else
3598	Perl_warner(aTHX_ packWARN(WARN_IO),
3599	"Filehandle opened only for %sput", direction);
3600	}
3601	}
3602	else {
3603	const char *vile;
3604	I32 warn_type;
3605
3606	if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3607	vile = "closed";
3608	warn_type = WARN_CLOSED;
3609	}
3610	else {
3611	vile = "unopened";
3612	warn_type = WARN_UNOPENED;
3613	}
3614
3615	if (ckWARN(warn_type)) {
3616	if (name && *name) {
3617	Perl_warner(aTHX_ packWARN(warn_type),
3618	"%s%s on %s %s %s", func, pars, vile, type, name);
3619	if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3620	Perl_warner(
3621	aTHX_ packWARN(warn_type),
3622	"\t(Are you trying to call %s%s on dirhandle %s?)\n",
3623	func, pars, name
3624	);
3625	}
3626	else {
3627	Perl_warner(aTHX_ packWARN(warn_type),
3628	"%s%s on %s %s", func, pars, vile, type);
3629	if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3630	Perl_warner(
3631	aTHX_ packWARN(warn_type),
3632	"\t(Are you trying to call %s%s on dirhandle?)\n",
3633	func, pars
3634	);
3635	}
3636	}
3637	}
3638	}
3639
3640	#ifdef EBCDIC
3641	/* in ASCII order, not that it matters */
3642	static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3643
3644	int
3645	Perl_ebcdic_control(pTHX_ int ch)
3646	{
3647	if (ch > 'a') {
3648	const char *ctlp;
3649
3650	if (islower(ch))
3651	ch = toupper(ch);
3652
3653	if ((ctlp = strchr(controllablechars, ch)) == 0) {
3654	Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3655	}
3656
3657	if (ctlp == controllablechars)
3658	return('\177'); /* DEL */
3659	else
3660	return((unsigned char)(ctlp - controllablechars - 1));
3661	} else { /* Want uncontrol */
3662	if (ch == '\177' \|\| ch == -1)
3663	return('?');
3664	else if (ch == '\157')
3665	return('\177');
3666	else if (ch == '\174')
3667	return('\000');
3668	else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3669	return('\036');
3670	else if (ch == '\155')
3671	return('\037');
3672	else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3673	return(controllablechars[ch+1]);
3674	else
3675	Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3676	}
3677	}
3678	#endif
3679
3680	/* To workaround core dumps from the uninitialised tm_zone we get the
3681	* system to give us a reasonable struct to copy. This fix means that
3682	* strftime uses the tm_zone and tm_gmtoff values returned by
3683	* localtime(time()). That should give the desired result most of the
3684	* time. But probably not always!
3685	*
3686	* This does not address tzname aspects of NETaa14816.
3687	*
3688	*/
3689
3690	#ifdef HAS_GNULIBC
3691	# ifndef STRUCT_TM_HASZONE
3692	# define STRUCT_TM_HASZONE
3693	# endif
3694	#endif
3695
3696	#ifdef STRUCT_TM_HASZONE /* Backward compat */
3697	# ifndef HAS_TM_TM_ZONE
3698	# define HAS_TM_TM_ZONE
3699	# endif
3700	#endif
3701
3702	void
3703	Perl_init_tm(pTHX_ struct tm ptm) / see mktime, strftime and asctime */
3704	{
3705	#ifdef HAS_TM_TM_ZONE
3706	Time_t now;
3707	const struct tm* my_tm;
3708	(void)time(&now);
3709	my_tm = localtime(&now);
3710	if (my_tm)
3711	Copy(my_tm, ptm, 1, struct tm);
3712	#else
3713	PERL_UNUSED_ARG(ptm);
3714	#endif
3715	}
3716
3717	/*
3718	* mini_mktime - normalise struct tm values without the localtime()
3719	* semantics (and overhead) of mktime().
3720	*/
3721	void
3722	Perl_mini_mktime(pTHX_ struct tm *ptm)
3723	{
3724	int yearday;
3725	int secs;
3726	int month, mday, year, jday;
3727	int odd_cent, odd_year;
3728
3729	#define DAYS_PER_YEAR 365
3730	#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3731	#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3732	#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3733	#define SECS_PER_HOUR (60*60)
3734	#define SECS_PER_DAY (24*SECS_PER_HOUR)
3735	/* parentheses deliberately absent on these two, otherwise they don't work */
3736	#define MONTH_TO_DAYS 153/5
3737	#define DAYS_TO_MONTH 5/153
3738	/* offset to bias by March (month 4) 1st between month/mday & year finding */
3739	#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3740	/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3741	#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3742
3743	/*
3744	* Year/day algorithm notes:
3745	*
3746	* With a suitable offset for numeric value of the month, one can find
3747	* an offset into the year by considering months to have 30.6 (153/5) days,
3748	* using integer arithmetic (i.e., with truncation). To avoid too much
3749	* messing about with leap days, we consider January and February to be
3750	* the 13th and 14th month of the previous year. After that transformation,
3751	* we need the month index we use to be high by 1 from 'normal human' usage,
3752	* so the month index values we use run from 4 through 15.
3753	*
3754	* Given that, and the rules for the Gregorian calendar (leap years are those
3755	* divisible by 4 unless also divisible by 100, when they must be divisible
3756	* by 400 instead), we can simply calculate the number of days since some
3757	* arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3758	* the days we derive from our month index, and adding in the day of the
3759	* month. The value used here is not adjusted for the actual origin which
3760	* it normally would use (1 January A.D. 1), since we're not exposing it.
3761	* We're only building the value so we can turn around and get the
3762	* normalised values for the year, month, day-of-month, and day-of-year.
3763	*
3764	* For going backward, we need to bias the value we're using so that we find
3765	* the right year value. (Basically, we don't want the contribution of
3766	* March 1st to the number to apply while deriving the year). Having done
3767	* that, we 'count up' the contribution to the year number by accounting for
3768	* full quadracenturies (400-year periods) with their extra leap days, plus
3769	* the contribution from full centuries (to avoid counting in the lost leap
3770	* days), plus the contribution from full quad-years (to count in the normal
3771	* leap days), plus the leftover contribution from any non-leap years.
3772	* At this point, if we were working with an actual leap day, we'll have 0
3773	* days left over. This is also true for March 1st, however. So, we have
3774	* to special-case that result, and (earlier) keep track of the 'odd'
3775	* century and year contributions. If we got 4 extra centuries in a qcent,
3776	* or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3777	* Otherwise, we add back in the earlier bias we removed (the 123 from
3778	* figuring in March 1st), find the month index (integer division by 30.6),
3779	* and the remainder is the day-of-month. We then have to convert back to
3780	* 'real' months (including fixing January and February from being 14/15 in
3781	* the previous year to being in the proper year). After that, to get
3782	* tm_yday, we work with the normalised year and get a new yearday value for
3783	* January 1st, which we subtract from the yearday value we had earlier,
3784	* representing the date we've re-built. This is done from January 1
3785	* because tm_yday is 0-origin.
3786	*
3787	* Since POSIX time routines are only guaranteed to work for times since the
3788	* UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3789	* applies Gregorian calendar rules even to dates before the 16th century
3790	* doesn't bother me. Besides, you'd need cultural context for a given
3791	* date to know whether it was Julian or Gregorian calendar, and that's
3792	* outside the scope for this routine. Since we convert back based on the
3793	* same rules we used to build the yearday, you'll only get strange results
3794	* for input which needed normalising, or for the 'odd' century years which
3795	* were leap years in the Julian calander but not in the Gregorian one.
3796	* I can live with that.
3797	*
3798	* This algorithm also fails to handle years before A.D. 1 gracefully, but
3799	* that's still outside the scope for POSIX time manipulation, so I don't
3800	* care.
3801	*/
3802
3803	year = 1900 + ptm->tm_year;
3804	month = ptm->tm_mon;
3805	mday = ptm->tm_mday;
3806	/* allow given yday with no month & mday to dominate the result */
3807	if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3808	month = 0;
3809	mday = 0;
3810	jday = 1 + ptm->tm_yday;
3811	}
3812	else {
3813	jday = 0;
3814	}
3815	if (month >= 2)
3816	month+=2;
3817	else
3818	month+=14, year--;
3819	yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3820	yearday += month*MONTH_TO_DAYS + mday + jday;
3821	/*
3822	* Note that we don't know when leap-seconds were or will be,
3823	* so we have to trust the user if we get something which looks
3824	* like a sensible leap-second. Wild values for seconds will
3825	* be rationalised, however.
3826	*/
3827	if ((unsigned) ptm->tm_sec <= 60) {
3828	secs = 0;
3829	}
3830	else {
3831	secs = ptm->tm_sec;
3832	ptm->tm_sec = 0;
3833	}
3834	secs += 60 * ptm->tm_min;
3835	secs += SECS_PER_HOUR * ptm->tm_hour;
3836	if (secs < 0) {
3837	if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3838	/* got negative remainder, but need positive time */
3839	/* back off an extra day to compensate */
3840	yearday += (secs/SECS_PER_DAY)-1;
3841	secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3842	}
3843	else {
3844	yearday += (secs/SECS_PER_DAY);
3845	secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3846	}
3847	}
3848	else if (secs >= SECS_PER_DAY) {
3849	yearday += (secs/SECS_PER_DAY);
3850	secs %= SECS_PER_DAY;
3851	}
3852	ptm->tm_hour = secs/SECS_PER_HOUR;
3853	secs %= SECS_PER_HOUR;
3854	ptm->tm_min = secs/60;
3855	secs %= 60;
3856	ptm->tm_sec += secs;
3857	/* done with time of day effects */
3858	/*
3859	* The algorithm for yearday has (so far) left it high by 428.
3860	* To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3861	* bias it by 123 while trying to figure out what year it
3862	* really represents. Even with this tweak, the reverse
3863	* translation fails for years before A.D. 0001.
3864	* It would still fail for Feb 29, but we catch that one below.
3865	*/
3866	jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3867	yearday -= YEAR_ADJUST;
3868	year = (yearday / DAYS_PER_QCENT) * 400;
3869	yearday %= DAYS_PER_QCENT;
3870	odd_cent = yearday / DAYS_PER_CENT;
3871	year += odd_cent * 100;
3872	yearday %= DAYS_PER_CENT;
3873	year += (yearday / DAYS_PER_QYEAR) * 4;
3874	yearday %= DAYS_PER_QYEAR;
3875	odd_year = yearday / DAYS_PER_YEAR;
3876	year += odd_year;
3877	yearday %= DAYS_PER_YEAR;
3878	if (!yearday && (odd_cent==4 \|\| odd_year==4)) { /* catch Feb 29 */
3879	month = 1;
3880	yearday = 29;
3881	}
3882	else {
3883	yearday += YEAR_ADJUST; /* recover March 1st crock */
3884	month = yearday*DAYS_TO_MONTH;
3885	yearday -= month*MONTH_TO_DAYS;
3886	/* recover other leap-year adjustment */
3887	if (month > 13) {
3888	month-=14;
3889	year++;
3890	}
3891	else {
3892	month-=2;
3893	}
3894	}
3895	ptm->tm_year = year - 1900;
3896	if (yearday) {
3897	ptm->tm_mday = yearday;
3898	ptm->tm_mon = month;
3899	}
3900	else {
3901	ptm->tm_mday = 31;
3902	ptm->tm_mon = month - 1;
3903	}
3904	/* re-build yearday based on Jan 1 to get tm_yday */
3905	year--;
3906	yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3907	yearday += 14*MONTH_TO_DAYS + 1;
3908	ptm->tm_yday = jday - yearday;
3909	/* fix tm_wday if not overridden by caller */
3910	if ((unsigned)ptm->tm_wday > 6)
3911	ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3912	}
3913
3914	char *
3915	Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3916	{
3917	#ifdef HAS_STRFTIME
3918	char *buf;
3919	int buflen;
3920	struct tm mytm;
3921	int len;
3922
3923	init_tm(&mytm); /* XXX workaround - see init_tm() above */
3924	mytm.tm_sec = sec;
3925	mytm.tm_min = min;
3926	mytm.tm_hour = hour;
3927	mytm.tm_mday = mday;
3928	mytm.tm_mon = mon;
3929	mytm.tm_year = year;
3930	mytm.tm_wday = wday;
3931	mytm.tm_yday = yday;
3932	mytm.tm_isdst = isdst;
3933	mini_mktime(&mytm);
3934	/* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3935	#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) \|\| defined(HAS_TM_TM_ZONE))
3936	STMT_START {
3937	struct tm mytm2;
3938	mytm2 = mytm;
3939	mktime(&mytm2);
3940	#ifdef HAS_TM_TM_GMTOFF
3941	mytm.tm_gmtoff = mytm2.tm_gmtoff;
3942	#endif
3943	#ifdef HAS_TM_TM_ZONE
3944	mytm.tm_zone = mytm2.tm_zone;
3945	#endif
3946	} STMT_END;
3947	#endif
3948	buflen = 64;
3949	Newx(buf, buflen, char);
3950	len = strftime(buf, buflen, fmt, &mytm);
3951	/*
3952	** The following is needed to handle to the situation where
3953	** tmpbuf overflows. Basically we want to allocate a buffer
3954	** and try repeatedly. The reason why it is so complicated
3955	** is that getting a return value of 0 from strftime can indicate
3956	** one of the following:
3957	** 1. buffer overflowed,
3958	** 2. illegal conversion specifier, or
3959	** 3. the format string specifies nothing to be returned(not
3960	** an error). This could be because format is an empty string
3961	** or it specifies %p that yields an empty string in some locale.
3962	** If there is a better way to make it portable, go ahead by
3963	** all means.
3964	*/
3965	if ((len > 0 && len < buflen) \|\| (len == 0 && *fmt == '\0'))
3966	return buf;
3967	else {
3968	/* Possibly buf overflowed - try again with a bigger buf */
3969	const int fmtlen = strlen(fmt);
3970	const int bufsize = fmtlen + buflen;
3971
3972	Newx(buf, bufsize, char);
3973	while (buf) {
3974	buflen = strftime(buf, bufsize, fmt, &mytm);
3975	if (buflen > 0 && buflen < bufsize)
3976	break;
3977	/* heuristic to prevent out-of-memory errors */
3978	if (bufsize > 100*fmtlen) {
3979	Safefree(buf);
3980	buf = NULL;
3981	break;
3982	}
3983	Renew(buf, bufsize*2, char);
3984	}
3985	return buf;
3986	}
3987	#else
3988	Perl_croak(aTHX_ "panic: no strftime");
3989	return NULL;
3990	#endif
3991	}
3992
3993
3994	#define SV_CWD_RETURN_UNDEF \
3995	sv_setsv(sv, &PL_sv_undef); \
3996	return FALSE
3997
3998	#define SV_CWD_ISDOT(dp) \
3999	(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' \|\| \
4000	(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4001
4002	/*
4003	=head1 Miscellaneous Functions
4004
4005	=for apidoc getcwd_sv
4006
4007	Fill the sv with current working directory
4008
4009	=cut
4010	*/
4011
4012	/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4013	* rewritten again by dougm, optimized for use with xs TARG, and to prefer
4014	* getcwd(3) if available
4015	* Comments from the orignal:
4016	* This is a faster version of getcwd. It's also more dangerous
4017	* because you might chdir out of a directory that you can't chdir
4018	* back into. */
4019
4020	int
4021	Perl_getcwd_sv(pTHX_ register SV *sv)
4022	{
4023	#ifndef PERL_MICRO
4024
4025	#ifndef INCOMPLETE_TAINTS
4026	SvTAINTED_on(sv);
4027	#endif
4028
4029	#ifdef HAS_GETCWD
4030	{
4031	char buf[MAXPATHLEN];
4032
4033	/* Some getcwd()s automatically allocate a buffer of the given
4034	* size from the heap if they are given a NULL buffer pointer.
4035	* The problem is that this behaviour is not portable. */
4036	if (getcwd(buf, sizeof(buf) - 1)) {
4037	sv_setpvn(sv, buf, strlen(buf));
4038	return TRUE;
4039	}
4040	else {
4041	sv_setsv(sv, &PL_sv_undef);
4042	return FALSE;
4043	}
4044	}
4045
4046	#else
4047
4048	Stat_t statbuf;
4049	int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4050	int pathlen=0;
4051	Direntry_t *dp;
4052
4053	(void)SvUPGRADE(sv, SVt_PV);
4054
4055	if (PerlLIO_lstat(".", &statbuf) < 0) {
4056	SV_CWD_RETURN_UNDEF;
4057	}
4058
4059	orig_cdev = statbuf.st_dev;
4060	orig_cino = statbuf.st_ino;
4061	cdev = orig_cdev;
4062	cino = orig_cino;
4063
4064	for (;;) {
4065	DIR *dir;
4066	odev = cdev;
4067	oino = cino;
4068
4069	if (PerlDir_chdir("..") < 0) {
4070	SV_CWD_RETURN_UNDEF;
4071	}
4072	if (PerlLIO_stat(".", &statbuf) < 0) {
4073	SV_CWD_RETURN_UNDEF;
4074	}
4075
4076	cdev = statbuf.st_dev;
4077	cino = statbuf.st_ino;
4078
4079	if (odev == cdev && oino == cino) {
4080	break;
4081	}
4082	if (!(dir = PerlDir_open("."))) {
4083	SV_CWD_RETURN_UNDEF;
4084	}
4085
4086	while ((dp = PerlDir_read(dir)) != NULL) {
4087	#ifdef DIRNAMLEN
4088	const int namelen = dp->d_namlen;
4089	#else
4090	const int namelen = strlen(dp->d_name);
4091	#endif
4092	/* skip . and .. */
4093	if (SV_CWD_ISDOT(dp)) {
4094	continue;
4095	}
4096
4097	if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4098	SV_CWD_RETURN_UNDEF;
4099	}
4100
4101	tdev = statbuf.st_dev;
4102	tino = statbuf.st_ino;
4103	if (tino == oino && tdev == odev) {
4104	break;
4105	}
4106	}
4107
4108	if (!dp) {
4109	SV_CWD_RETURN_UNDEF;
4110	}
4111
4112	if (pathlen + namelen + 1 >= MAXPATHLEN) {
4113	SV_CWD_RETURN_UNDEF;
4114	}
4115
4116	SvGROW(sv, pathlen + namelen + 1);
4117
4118	if (pathlen) {
4119	/* shift down */
4120	Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4121	}
4122
4123	/* prepend current directory to the front */
4124	*SvPVX(sv) = '/';
4125	Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4126	pathlen += (namelen + 1);
4127
4128	#ifdef VOID_CLOSEDIR
4129	PerlDir_close(dir);
4130	#else
4131	if (PerlDir_close(dir) < 0) {
4132	SV_CWD_RETURN_UNDEF;
4133	}
4134	#endif
4135	}
4136
4137	if (pathlen) {
4138	SvCUR_set(sv, pathlen);
4139	*SvEND(sv) = '\0';
4140	SvPOK_only(sv);
4141
4142	if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4143	SV_CWD_RETURN_UNDEF;
4144	}
4145	}
4146	if (PerlLIO_stat(".", &statbuf) < 0) {
4147	SV_CWD_RETURN_UNDEF;
4148	}
4149
4150	cdev = statbuf.st_dev;
4151	cino = statbuf.st_ino;
4152
4153	if (cdev != orig_cdev \|\| cino != orig_cino) {
4154	Perl_croak(aTHX_ "Unstable directory path, "
4155	"current directory changed unexpectedly");
4156	}
4157
4158	return TRUE;
4159	#endif
4160
4161	#else
4162	return FALSE;
4163	#endif
4164	}
4165
4166	#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4167	# define EMULATE_SOCKETPAIR_UDP
4168	#endif
4169
4170	#ifdef EMULATE_SOCKETPAIR_UDP
4171	static int
4172	S_socketpair_udp (int fd[2]) {
4173	dTHX;
4174	/* Fake a datagram socketpair using UDP to localhost. */
4175	int sockets[2] = {-1, -1};
4176	struct sockaddr_in addresses[2];
4177	int i;
4178	Sock_size_t size = sizeof(struct sockaddr_in);
4179	unsigned short port;
4180	int got;
4181
4182	memset(&addresses, 0, sizeof(addresses));
4183	i = 1;
4184	do {
4185	sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4186	if (sockets[i] == -1)
4187	goto tidy_up_and_fail;
4188
4189	addresses[i].sin_family = AF_INET;
4190	addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4191	addresses[i].sin_port = 0; /* kernel choses port. */
4192	if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4193	sizeof(struct sockaddr_in)) == -1)
4194	goto tidy_up_and_fail;
4195	} while (i--);
4196
4197	/* Now have 2 UDP sockets. Find out which port each is connected to, and
4198	for each connect the other socket to it. */
4199	i = 1;
4200	do {
4201	if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4202	&size) == -1)
4203	goto tidy_up_and_fail;
4204	if (size != sizeof(struct sockaddr_in))
4205	goto abort_tidy_up_and_fail;
4206	/* !1 is 0, !0 is 1 */
4207	if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4208	sizeof(struct sockaddr_in)) == -1)
4209	goto tidy_up_and_fail;
4210	} while (i--);
4211
4212	/* Now we have 2 sockets connected to each other. I don't trust some other
4213	process not to have already sent a packet to us (by random) so send
4214	a packet from each to the other. */
4215	i = 1;
4216	do {
4217	/* I'm going to send my own port number. As a short.
4218	(Who knows if someone somewhere has sin_port as a bitfield and needs
4219	this routine. (I'm assuming crays have socketpair)) */
4220	port = addresses[i].sin_port;
4221	got = PerlLIO_write(sockets[i], &port, sizeof(port));
4222	if (got != sizeof(port)) {
4223	if (got == -1)
4224	goto tidy_up_and_fail;
4225	goto abort_tidy_up_and_fail;
4226	}
4227	} while (i--);
4228
4229	/* Packets sent. I don't trust them to have arrived though.
4230	(As I understand it Solaris TCP stack is multithreaded. Non-blocking
4231	connect to localhost will use a second kernel thread. In 2.6 the
4232	first thread running the connect() returns before the second completes,
4233	so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4234	returns 0. Poor programs have tripped up. One poor program's authors'
4235	had a 50-1 reverse stock split. Not sure how connected these were.)
4236	So I don't trust someone not to have an unpredictable UDP stack.
4237	*/
4238
4239	{
4240	struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4241	int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4242	fd_set rset;
4243
4244	FD_ZERO(&rset);
4245	FD_SET(sockets[0], &rset);
4246	FD_SET(sockets[1], &rset);
4247
4248	got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4249	if (got != 2 \|\| !FD_ISSET(sockets[0], &rset)
4250	\|\| !FD_ISSET(sockets[1], &rset)) {
4251	/* I hope this is portable and appropriate. */
4252	if (got == -1)
4253	goto tidy_up_and_fail;
4254	goto abort_tidy_up_and_fail;
4255	}
4256	}
4257
4258	/* And the paranoia department even now doesn't trust it to have arrive
4259	(hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4260	{
4261	struct sockaddr_in readfrom;
4262	unsigned short buffer[2];
4263
4264	i = 1;
4265	do {
4266	#ifdef MSG_DONTWAIT
4267	got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4268	sizeof(buffer), MSG_DONTWAIT,
4269	(struct sockaddr *) &readfrom, &size);
4270	#else
4271	got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4272	sizeof(buffer), 0,
4273	(struct sockaddr *) &readfrom, &size);
4274	#endif
4275
4276	if (got == -1)
4277	goto tidy_up_and_fail;
4278	if (got != sizeof(port)
4279	\|\| size != sizeof(struct sockaddr_in)
4280	/* Check other socket sent us its port. */
4281	\|\| buffer[0] != (unsigned short) addresses[!i].sin_port
4282	/* Check kernel says we got the datagram from that socket */
4283	\|\| readfrom.sin_family != addresses[!i].sin_family
4284	\|\| readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4285	\|\| readfrom.sin_port != addresses[!i].sin_port)
4286	goto abort_tidy_up_and_fail;
4287	} while (i--);
4288	}
4289	/* My caller (my_socketpair) has validated that this is non-NULL */
4290	fd[0] = sockets[0];
4291	fd[1] = sockets[1];
4292	/* I hereby declare this connection open. May God bless all who cross
4293	her. */
4294	return 0;
4295
4296	abort_tidy_up_and_fail:
4297	errno = ECONNABORTED;
4298	tidy_up_and_fail:
4299	{
4300	const int save_errno = errno;
4301	if (sockets[0] != -1)
4302	PerlLIO_close(sockets[0]);
4303	if (sockets[1] != -1)
4304	PerlLIO_close(sockets[1]);
4305	errno = save_errno;
4306	return -1;
4307	}
4308	}
4309	#endif /* EMULATE_SOCKETPAIR_UDP */
4310
4311	#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4312	int
4313	Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4314	/* Stevens says that family must be AF_LOCAL, protocol 0.
4315	I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4316	dTHX;
4317	int listener = -1;
4318	int connector = -1;
4319	int acceptor = -1;
4320	struct sockaddr_in listen_addr;
4321	struct sockaddr_in connect_addr;
4322	Sock_size_t size;
4323
4324	if (protocol
4325	#ifdef AF_UNIX
4326	\|\| family != AF_UNIX
4327	#endif
4328	) {
4329	errno = EAFNOSUPPORT;
4330	return -1;
4331	}
4332	if (!fd) {
4333	errno = EINVAL;
4334	return -1;
4335	}
4336
4337	#ifdef EMULATE_SOCKETPAIR_UDP
4338	if (type == SOCK_DGRAM)
4339	return S_socketpair_udp(fd);
4340	#endif
4341
4342	listener = PerlSock_socket(AF_INET, type, 0);
4343	if (listener == -1)
4344	return -1;
4345	memset(&listen_addr, 0, sizeof(listen_addr));
4346	listen_addr.sin_family = AF_INET;
4347	listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4348	listen_addr.sin_port = 0; /* kernel choses port. */
4349	if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4350	sizeof(listen_addr)) == -1)
4351	goto tidy_up_and_fail;
4352	if (PerlSock_listen(listener, 1) == -1)
4353	goto tidy_up_and_fail;
4354
4355	connector = PerlSock_socket(AF_INET, type, 0);
4356	if (connector == -1)
4357	goto tidy_up_and_fail;
4358	/* We want to find out the port number to connect to. */
4359	size = sizeof(connect_addr);
4360	if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4361	&size) == -1)
4362	goto tidy_up_and_fail;
4363	if (size != sizeof(connect_addr))
4364	goto abort_tidy_up_and_fail;
4365	if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4366	sizeof(connect_addr)) == -1)
4367	goto tidy_up_and_fail;
4368
4369	size = sizeof(listen_addr);
4370	acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4371	&size);
4372	if (acceptor == -1)
4373	goto tidy_up_and_fail;
4374	if (size != sizeof(listen_addr))
4375	goto abort_tidy_up_and_fail;
4376	PerlLIO_close(listener);
4377	/* Now check we are talking to ourself by matching port and host on the
4378	two sockets. */
4379	if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4380	&size) == -1)
4381	goto tidy_up_and_fail;
4382	if (size != sizeof(connect_addr)
4383	\|\| listen_addr.sin_family != connect_addr.sin_family
4384	\|\| listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4385	\|\| listen_addr.sin_port != connect_addr.sin_port) {
4386	goto abort_tidy_up_and_fail;
4387	}
4388	fd[0] = connector;
4389	fd[1] = acceptor;
4390	return 0;
4391
4392	abort_tidy_up_and_fail:
4393	#ifdef ECONNABORTED
4394	errno = ECONNABORTED; /* This would be the standard thing to do. */
4395	#else
4396	# ifdef ECONNREFUSED
4397	errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4398	# else
4399	errno = ETIMEDOUT; /* Desperation time. */
4400	# endif
4401	#endif
4402	tidy_up_and_fail:
4403	{
4404	int save_errno = errno;
4405	if (listener != -1)
4406	PerlLIO_close(listener);
4407	if (connector != -1)
4408	PerlLIO_close(connector);
4409	if (acceptor != -1)
4410	PerlLIO_close(acceptor);
4411	errno = save_errno;
4412	return -1;
4413	}
4414	}
4415	#else
4416	/* In any case have a stub so that there's code corresponding
4417	* to the my_socketpair in global.sym. */
4418	int
4419	Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4420	#ifdef HAS_SOCKETPAIR
4421	return socketpair(family, type, protocol, fd);
4422	#else
4423	return -1;
4424	#endif
4425	}
4426	#endif
4427
4428	/*
4429
4430	=for apidoc sv_nosharing
4431
4432	Dummy routine which "shares" an SV when there is no sharing module present.
4433	Exists to avoid test for a NULL function pointer and because it could potentially warn under
4434	some level of strict-ness.
4435
4436	=cut
4437	*/
4438
4439	void
4440	Perl_sv_nosharing(pTHX_ SV *sv)
4441	{
4442	PERL_UNUSED_ARG(sv);
4443	}
4444
4445	/*
4446	=for apidoc sv_nolocking
4447
4448	Dummy routine which "locks" an SV when there is no locking module present.
4449	Exists to avoid test for a NULL function pointer and because it could potentially warn under
4450	some level of strict-ness.
4451
4452	=cut
4453	*/
4454
4455	void
4456	Perl_sv_nolocking(pTHX_ SV *sv)
4457	{
4458	PERL_UNUSED_ARG(sv);
4459	}
4460
4461
4462	/*
4463	=for apidoc sv_nounlocking
4464
4465	Dummy routine which "unlocks" an SV when there is no locking module present.
4466	Exists to avoid test for a NULL function pointer and because it could potentially warn under
4467	some level of strict-ness.
4468
4469	=cut
4470	*/
4471
4472	void
4473	Perl_sv_nounlocking(pTHX_ SV *sv)
4474	{
4475	PERL_UNUSED_ARG(sv);
4476	}
4477
4478	U32
4479	Perl_parse_unicode_opts(pTHX_ char **popt)
4480	{
4481	const char p = popt;
4482	U32 opt = 0;
4483
4484	if (*p) {
4485	if (isDIGIT(*p)) {
4486	opt = (U32) atoi(p);
4487	while (isDIGIT(*p)) p++;
4488	if (p && p != '\n' && *p != '\r')
4489	Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4490	}
4491	else {
4492	for (; *p; p++) {
4493	switch (*p) {
4494	case PERL_UNICODE_STDIN:
4495	opt \|= PERL_UNICODE_STDIN_FLAG; break;
4496	case PERL_UNICODE_STDOUT:
4497	opt \|= PERL_UNICODE_STDOUT_FLAG; break;
4498	case PERL_UNICODE_STDERR:
4499	opt \|= PERL_UNICODE_STDERR_FLAG; break;
4500	case PERL_UNICODE_STD:
4501	opt \|= PERL_UNICODE_STD_FLAG; break;
4502	case PERL_UNICODE_IN:
4503	opt \|= PERL_UNICODE_IN_FLAG; break;
4504	case PERL_UNICODE_OUT:
4505	opt \|= PERL_UNICODE_OUT_FLAG; break;
4506	case PERL_UNICODE_INOUT:
4507	opt \|= PERL_UNICODE_INOUT_FLAG; break;
4508	case PERL_UNICODE_LOCALE:
4509	opt \|= PERL_UNICODE_LOCALE_FLAG; break;
4510	case PERL_UNICODE_ARGV:
4511	opt \|= PERL_UNICODE_ARGV_FLAG; break;
4512	default:
4513	if (p != '\n' && p != '\r')
4514	Perl_croak(aTHX_
4515	"Unknown Unicode option letter '%c'", *p);
4516	}
4517	}
4518	}
4519	}
4520	else
4521	opt = PERL_UNICODE_DEFAULT_FLAGS;
4522
4523	if (opt & ~PERL_UNICODE_ALL_FLAGS)
4524	Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4525	(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4526
4527	/* Cast because we're not changing function prototypes in maint. */
4528	popt = (char ) p;
4529
4530	return opt;
4531	}
4532
4533	U32
4534	Perl_seed(pTHX)
4535	{
4536	/*
4537	* This is really just a quick hack which grabs various garbage
4538	* values. It really should be a real hash algorithm which
4539	* spreads the effect of every input bit onto every output bit,
4540	* if someone who knows about such things would bother to write it.
4541	* Might be a good idea to add that function to CORE as well.
4542	* No numbers below come from careful analysis or anything here,
4543	* except they are primes and SEED_C1 > 1E6 to get a full-width
4544	* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4545	* probably be bigger too.
4546	*/
4547	#if RANDBITS > 16
4548	# define SEED_C1 1000003
4549	#define SEED_C4 73819
4550	#else
4551	# define SEED_C1 25747
4552	#define SEED_C4 20639
4553	#endif
4554	#define SEED_C2 3
4555	#define SEED_C3 269
4556	#define SEED_C5 26107
4557
4558	#ifndef PERL_NO_DEV_RANDOM
4559	int fd;
4560	#endif
4561	U32 u;
4562	#ifdef VMS
4563	# include <starlet.h>
4564	/* when[] = (low 32 bits, high 32 bits) of time since epoch
4565	* in 100-ns units, typically incremented ever 10 ms. */
4566	unsigned int when[2];
4567	#else
4568	# ifdef HAS_GETTIMEOFDAY
4569	struct timeval when;
4570	# else
4571	Time_t when;
4572	# endif
4573	#endif
4574
4575	/* This test is an escape hatch, this symbol isn't set by Configure. */
4576	#ifndef PERL_NO_DEV_RANDOM
4577	#ifndef PERL_RANDOM_DEVICE
4578	/* /dev/random isn't used by default because reads from it will block
4579	* if there isn't enough entropy available. You can compile with
4580	* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4581	* is enough real entropy to fill the seed. */
4582	# define PERL_RANDOM_DEVICE "/dev/urandom"
4583	#endif
4584	fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4585	if (fd != -1) {
4586	if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4587	u = 0;
4588	PerlLIO_close(fd);
4589	if (u)
4590	return u;
4591	}
4592	#endif
4593
4594	#ifdef VMS
4595	_ckvmssts(sys$gettim(when));
4596	u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4597	#else
4598	# ifdef HAS_GETTIMEOFDAY
4599	PerlProc_gettimeofday(&when,NULL);
4600	u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4601	# else
4602	(void)time(&when);
4603	u = (U32)SEED_C1 * when;
4604	# endif
4605	#endif
4606	u += SEED_C3 * (U32)PerlProc_getpid();
4607	u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4608	#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4609	u += SEED_C5 * (U32)PTR2UV(&when);
4610	#endif
4611	return u;
4612	}
4613
4614	UV
4615	Perl_get_hash_seed(pTHX)
4616	{
4617	const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4618	UV myseed = 0;
4619
4620	if (s)
4621	while (isSPACE(*s)) s++;
4622	if (s && isDIGIT(*s))
4623	myseed = (UV)Atoul(s);
4624	else
4625	#ifdef USE_HASH_SEED_EXPLICIT
4626	if (s)
4627	#endif
4628	{
4629	/* Compute a random seed */
4630	(void)seedDrand01((Rand_seed_t)seed());
4631	myseed = (UV)(Drand01() * (NV)UV_MAX);
4632	#if RANDBITS < (UVSIZE * 8)
4633	/* Since there are not enough randbits to to reach all
4634	* the bits of a UV, the low bits might need extra
4635	* help. Sum in another random number that will
4636	* fill in the low bits. */
4637	myseed +=
4638	(UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4639	#endif /* RANDBITS < (UVSIZE * 8) */
4640	if (myseed == 0) { /* Superparanoia. */
4641	myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4642	if (myseed == 0)
4643	Perl_croak(aTHX_ "Your random numbers are not that random");
4644	}
4645	}
4646	PL_rehash_seed_set = TRUE;
4647
4648	return myseed;
4649	}
4650
4651	#ifdef USE_ITHREADS
4652	bool
4653	Perl_stashpv_hvname_match(pTHX_ const COP c, const HV hv)
4654	{
4655	const char * const stashpv = CopSTASHPV(c);
4656	const char * const name = HvNAME_get(hv);
4657
4658	if (stashpv == name)
4659	return TRUE;
4660	if (stashpv && name)
4661	if (strEQ(stashpv, name))
4662	return TRUE;
4663	return FALSE;
4664	}
4665	#endif
4666
4667	void
4668	Perl_my_clearenv(pTHX)
4669	{
4670	#if ! defined(PERL_MICRO)
4671	# if defined(PERL_IMPLICIT_SYS) \|\| defined(WIN32)
4672	PerlEnv_clearenv();
4673	# else /* ! (PERL_IMPLICIT_SYS \|\| WIN32) */
4674	# if defined(USE_ENVIRON_ARRAY)
4675	# if defined(USE_ITHREADS)
4676	/* only the parent thread can clobber the process environment */
4677	if (PL_curinterp == aTHX)
4678	# endif /* USE_ITHREADS */
4679	{
4680	# if ! defined(PERL_USE_SAFE_PUTENV)
4681	if ( !PL_use_safe_putenv) {
4682	I32 i;
4683	if (environ == PL_origenviron)
4684	environ = (char*)safesysmalloc(sizeof(char));
4685	else
4686	for (i = 0; environ[i]; i++)
4687	(void)safesysfree(environ[i]);
4688	}
4689	environ[0] = NULL;
4690	# else /* PERL_USE_SAFE_PUTENV */
4691	# if defined(HAS_CLEARENV)
4692	(void)clearenv();
4693	# elif defined(HAS_UNSETENV)
4694	int bsiz = 80; /* Most envvar names will be shorter than this. */
4695	char buf = (char)safesysmalloc(bsiz * sizeof(char));
4696	while (*environ != NULL) {
4697	char e = strchr(environ, '=');
4698	int l = e ? e - environ : strlen(environ);
4699	if (bsiz < l + 1) {
4700	(void)safesysfree(buf);
4701	bsiz = l + 1;
4702	buf = (char)safesysmalloc(bsiz sizeof(char));
4703	}
4704	strncpy(buf, *environ, l);
4705	*(buf + l) = '\0';
4706	(void)unsetenv(buf);
4707	}
4708	(void)safesysfree(buf);
4709	# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
4710	/* Just null environ and accept the leakage. */
4711	*environ = NULL;
4712	# endif /* HAS_CLEARENV \|\| HAS_UNSETENV */
4713	# endif /* ! PERL_USE_SAFE_PUTENV */
4714	}
4715	# endif /* USE_ENVIRON_ARRAY */
4716	# endif /* PERL_IMPLICIT_SYS \|\| WIN32 */
4717	#endif /* PERL_MICRO */
4718	}
4719
4720	/*
4721	* Local variables:
4722	* c-indentation-style: bsd
4723	* c-basic-offset: 4
4724	* indent-tabs-mode: t
4725	* End:
4726	*
4727	* ex: set ts=8 sts=4 sw=4 noet:
4728	*/

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

Context Navigation

source: vendor/perl/5.8.8/util.c@ 3277

Download in other formats: