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