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