Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | /* util.c |
a687059c | 2 | * |
a0d0e21e | 3 | * Copyright (c) 1991-1994, Larry Wall |
a687059c | 4 | * |
d48672a2 LW |
5 | * You may distribute under the terms of either the GNU General Public |
6 | * License or the Artistic License, as specified in the README file. | |
8d063cd8 | 7 | * |
8d063cd8 | 8 | */ |
a0d0e21e LW |
9 | |
10 | /* | |
11 | * "Very useful, no doubt, that was to Saruman; yet it seems that he was | |
12 | * not content." --Gandalf | |
13 | */ | |
8d063cd8 | 14 | |
8d063cd8 | 15 | #include "EXTERN.h" |
8d063cd8 | 16 | #include "perl.h" |
62b28dd9 | 17 | |
6eb13c3b | 18 | #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) |
a687059c | 19 | #include <signal.h> |
62b28dd9 | 20 | #endif |
a687059c | 21 | |
bd4080b3 | 22 | /* XXX If this causes problems, set i_unistd=undef in the hint file. */ |
85e6fe83 | 23 | #ifdef I_UNISTD |
8990e307 LW |
24 | # include <unistd.h> |
25 | #endif | |
26 | ||
a687059c LW |
27 | #ifdef I_VFORK |
28 | # include <vfork.h> | |
29 | #endif | |
30 | ||
94b6baf5 AD |
31 | /* Put this after #includes because fork and vfork prototypes may |
32 | conflict. | |
33 | */ | |
34 | #ifndef HAS_VFORK | |
35 | # define vfork fork | |
36 | #endif | |
37 | ||
fe14fcc3 LW |
38 | #ifdef I_FCNTL |
39 | # include <fcntl.h> | |
40 | #endif | |
41 | #ifdef I_SYS_FILE | |
42 | # include <sys/file.h> | |
43 | #endif | |
44 | ||
8d063cd8 | 45 | #define FLUSH |
8d063cd8 | 46 | |
a0d0e21e LW |
47 | #ifdef LEAKTEST |
48 | static void xstat _((void)); | |
49 | #endif | |
50 | ||
de3bb511 LW |
51 | #ifndef safemalloc |
52 | ||
8d063cd8 LW |
53 | /* paranoid version of malloc */ |
54 | ||
a687059c LW |
55 | /* NOTE: Do not call the next three routines directly. Use the macros |
56 | * in handy.h, so that we can easily redefine everything to do tracking of | |
57 | * allocated hunks back to the original New to track down any memory leaks. | |
20cec16a | 58 | * XXX This advice seems to be widely ignored :-( --AD August 1996. |
a687059c LW |
59 | */ |
60 | ||
bd4080b3 | 61 | Malloc_t |
8d063cd8 | 62 | safemalloc(size) |
62b28dd9 LW |
63 | #ifdef MSDOS |
64 | unsigned long size; | |
65 | #else | |
8d063cd8 | 66 | MEM_SIZE size; |
62b28dd9 | 67 | #endif /* MSDOS */ |
8d063cd8 | 68 | { |
bd4080b3 | 69 | Malloc_t ptr; |
62b28dd9 LW |
70 | #ifdef MSDOS |
71 | if (size > 0xffff) { | |
760ac839 | 72 | PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; |
79072805 | 73 | my_exit(1); |
62b28dd9 LW |
74 | } |
75 | #endif /* MSDOS */ | |
34de22dd LW |
76 | #ifdef DEBUGGING |
77 | if ((long)size < 0) | |
463ee0b2 | 78 | croak("panic: malloc"); |
34de22dd | 79 | #endif |
8d063cd8 | 80 | ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ |
79072805 | 81 | #if !(defined(I286) || defined(atarist)) |
760ac839 | 82 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); |
79072805 | 83 | #else |
760ac839 | 84 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); |
8d063cd8 LW |
85 | #endif |
86 | if (ptr != Nullch) | |
87 | return ptr; | |
7c0587c8 LW |
88 | else if (nomemok) |
89 | return Nullch; | |
8d063cd8 | 90 | else { |
760ac839 | 91 | PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; |
79072805 | 92 | my_exit(1); |
8d063cd8 LW |
93 | } |
94 | /*NOTREACHED*/ | |
95 | } | |
96 | ||
97 | /* paranoid version of realloc */ | |
98 | ||
bd4080b3 | 99 | Malloc_t |
8d063cd8 | 100 | saferealloc(where,size) |
bd4080b3 | 101 | Malloc_t where; |
62b28dd9 | 102 | #ifndef MSDOS |
8d063cd8 | 103 | MEM_SIZE size; |
62b28dd9 LW |
104 | #else |
105 | unsigned long size; | |
106 | #endif /* MSDOS */ | |
8d063cd8 | 107 | { |
bd4080b3 | 108 | Malloc_t ptr; |
ecfc5424 | 109 | #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) |
bd4080b3 | 110 | Malloc_t realloc(); |
ecfc5424 | 111 | #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ |
8d063cd8 | 112 | |
62b28dd9 LW |
113 | #ifdef MSDOS |
114 | if (size > 0xffff) { | |
760ac839 | 115 | PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; |
79072805 | 116 | my_exit(1); |
62b28dd9 LW |
117 | } |
118 | #endif /* MSDOS */ | |
378cc40b | 119 | if (!where) |
463ee0b2 | 120 | croak("Null realloc"); |
34de22dd LW |
121 | #ifdef DEBUGGING |
122 | if ((long)size < 0) | |
463ee0b2 | 123 | croak("panic: realloc"); |
34de22dd | 124 | #endif |
8d063cd8 | 125 | ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ |
79072805 LW |
126 | |
127 | #if !(defined(I286) || defined(atarist)) | |
128 | DEBUG_m( { | |
760ac839 LW |
129 | PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); |
130 | PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); | |
79072805 LW |
131 | } ) |
132 | #else | |
133 | DEBUG_m( { | |
760ac839 LW |
134 | PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); |
135 | PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); | |
79072805 | 136 | } ) |
8d063cd8 | 137 | #endif |
79072805 | 138 | |
8d063cd8 LW |
139 | if (ptr != Nullch) |
140 | return ptr; | |
7c0587c8 LW |
141 | else if (nomemok) |
142 | return Nullch; | |
8d063cd8 | 143 | else { |
760ac839 | 144 | PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; |
79072805 | 145 | my_exit(1); |
8d063cd8 LW |
146 | } |
147 | /*NOTREACHED*/ | |
148 | } | |
149 | ||
150 | /* safe version of free */ | |
151 | ||
a687059c | 152 | void |
8d063cd8 | 153 | safefree(where) |
bd4080b3 | 154 | Malloc_t where; |
8d063cd8 | 155 | { |
79072805 | 156 | #if !(defined(I286) || defined(atarist)) |
760ac839 | 157 | DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++)); |
79072805 | 158 | #else |
760ac839 | 159 | DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++)); |
8d063cd8 | 160 | #endif |
378cc40b | 161 | if (where) { |
de3bb511 | 162 | /*SUPPRESS 701*/ |
378cc40b LW |
163 | free(where); |
164 | } | |
8d063cd8 LW |
165 | } |
166 | ||
1050c9ca | 167 | /* safe version of calloc */ |
168 | ||
bd4080b3 | 169 | Malloc_t |
1050c9ca | 170 | safecalloc(count, size) |
171 | MEM_SIZE count; | |
172 | MEM_SIZE size; | |
173 | { | |
bd4080b3 | 174 | Malloc_t ptr; |
1050c9ca | 175 | |
176 | #ifdef MSDOS | |
177 | if (size * count > 0xffff) { | |
760ac839 | 178 | PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; |
1050c9ca | 179 | my_exit(1); |
180 | } | |
181 | #endif /* MSDOS */ | |
182 | #ifdef DEBUGGING | |
183 | if ((long)size < 0 || (long)count < 0) | |
184 | croak("panic: calloc"); | |
185 | #endif | |
186 | #if !(defined(I286) || defined(atarist)) | |
760ac839 | 187 | DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); |
1050c9ca | 188 | #else |
760ac839 | 189 | DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); |
1050c9ca | 190 | #endif |
191 | size *= count; | |
192 | ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ | |
193 | if (ptr != Nullch) { | |
194 | memset((void*)ptr, 0, size); | |
195 | return ptr; | |
196 | } | |
197 | else if (nomemok) | |
198 | return Nullch; | |
199 | else { | |
760ac839 | 200 | PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; |
1050c9ca | 201 | my_exit(1); |
202 | } | |
203 | /*NOTREACHED*/ | |
204 | } | |
205 | ||
de3bb511 LW |
206 | #endif /* !safemalloc */ |
207 | ||
a687059c LW |
208 | #ifdef LEAKTEST |
209 | ||
210 | #define ALIGN sizeof(long) | |
8d063cd8 | 211 | |
bd4080b3 | 212 | Malloc_t |
a687059c | 213 | safexmalloc(x,size) |
79072805 | 214 | I32 x; |
a687059c | 215 | MEM_SIZE size; |
8d063cd8 | 216 | { |
bd4080b3 | 217 | register Malloc_t where; |
8d063cd8 | 218 | |
a687059c LW |
219 | where = safemalloc(size + ALIGN); |
220 | xcount[x]++; | |
221 | where[0] = x % 100; | |
222 | where[1] = x / 100; | |
223 | return where + ALIGN; | |
8d063cd8 | 224 | } |
8d063cd8 | 225 | |
bd4080b3 | 226 | Malloc_t |
a687059c | 227 | safexrealloc(where,size) |
bd4080b3 | 228 | Malloc_t where; |
a687059c LW |
229 | MEM_SIZE size; |
230 | { | |
bd4080b3 | 231 | register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN); |
a0d0e21e | 232 | return new + ALIGN; |
a687059c LW |
233 | } |
234 | ||
235 | void | |
236 | safexfree(where) | |
bd4080b3 | 237 | Malloc_t where; |
a687059c | 238 | { |
79072805 | 239 | I32 x; |
a687059c LW |
240 | |
241 | if (!where) | |
242 | return; | |
243 | where -= ALIGN; | |
244 | x = where[0] + 100 * where[1]; | |
245 | xcount[x]--; | |
246 | safefree(where); | |
247 | } | |
248 | ||
bd4080b3 | 249 | Malloc_t |
1050c9ca | 250 | safexcalloc(x,count,size) |
251 | I32 x; | |
252 | MEM_SIZE count; | |
253 | MEM_SIZE size; | |
254 | { | |
bd4080b3 | 255 | register Malloc_t where; |
1050c9ca | 256 | |
257 | where = safexmalloc(x, size * count + ALIGN); | |
258 | xcount[x]++; | |
259 | memset((void*)where + ALIGN, 0, size * count); | |
260 | where[0] = x % 100; | |
261 | where[1] = x / 100; | |
262 | return where + ALIGN; | |
263 | } | |
264 | ||
7c0587c8 | 265 | static void |
a687059c | 266 | xstat() |
8d063cd8 | 267 | { |
79072805 | 268 | register I32 i; |
8d063cd8 | 269 | |
a687059c | 270 | for (i = 0; i < MAXXCOUNT; i++) { |
de3bb511 | 271 | if (xcount[i] > lastxcount[i]) { |
760ac839 | 272 | PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); |
a687059c | 273 | lastxcount[i] = xcount[i]; |
8d063cd8 LW |
274 | } |
275 | } | |
8d063cd8 | 276 | } |
a687059c LW |
277 | |
278 | #endif /* LEAKTEST */ | |
8d063cd8 LW |
279 | |
280 | /* copy a string up to some (non-backslashed) delimiter, if any */ | |
281 | ||
282 | char * | |
a687059c | 283 | cpytill(to,from,fromend,delim,retlen) |
62b28dd9 LW |
284 | register char *to; |
285 | register char *from; | |
a687059c | 286 | register char *fromend; |
a0d0e21e | 287 | register int delim; |
79072805 | 288 | I32 *retlen; |
8d063cd8 | 289 | { |
a687059c LW |
290 | char *origto = to; |
291 | ||
292 | for (; from < fromend; from++,to++) { | |
378cc40b LW |
293 | if (*from == '\\') { |
294 | if (from[1] == delim) | |
295 | from++; | |
296 | else if (from[1] == '\\') | |
297 | *to++ = *from++; | |
298 | } | |
8d063cd8 LW |
299 | else if (*from == delim) |
300 | break; | |
301 | *to = *from; | |
302 | } | |
303 | *to = '\0'; | |
a687059c | 304 | *retlen = to - origto; |
8d063cd8 LW |
305 | return from; |
306 | } | |
307 | ||
308 | /* return ptr to little string in big string, NULL if not found */ | |
378cc40b | 309 | /* This routine was donated by Corey Satten. */ |
8d063cd8 LW |
310 | |
311 | char * | |
312 | instr(big, little) | |
378cc40b LW |
313 | register char *big; |
314 | register char *little; | |
315 | { | |
316 | register char *s, *x; | |
79072805 | 317 | register I32 first; |
378cc40b | 318 | |
a687059c LW |
319 | if (!little) |
320 | return big; | |
321 | first = *little++; | |
378cc40b LW |
322 | if (!first) |
323 | return big; | |
324 | while (*big) { | |
325 | if (*big++ != first) | |
326 | continue; | |
327 | for (x=big,s=little; *s; /**/ ) { | |
328 | if (!*x) | |
329 | return Nullch; | |
330 | if (*s++ != *x++) { | |
331 | s--; | |
332 | break; | |
333 | } | |
334 | } | |
335 | if (!*s) | |
336 | return big-1; | |
337 | } | |
338 | return Nullch; | |
339 | } | |
8d063cd8 | 340 | |
a687059c LW |
341 | /* same as instr but allow embedded nulls */ |
342 | ||
343 | char * | |
344 | ninstr(big, bigend, little, lend) | |
345 | register char *big; | |
346 | register char *bigend; | |
347 | char *little; | |
348 | char *lend; | |
8d063cd8 | 349 | { |
a687059c | 350 | register char *s, *x; |
79072805 | 351 | register I32 first = *little; |
a687059c | 352 | register char *littleend = lend; |
378cc40b | 353 | |
a0d0e21e | 354 | if (!first && little >= littleend) |
a687059c | 355 | return big; |
de3bb511 LW |
356 | if (bigend - big < littleend - little) |
357 | return Nullch; | |
a687059c LW |
358 | bigend -= littleend - little++; |
359 | while (big <= bigend) { | |
360 | if (*big++ != first) | |
361 | continue; | |
362 | for (x=big,s=little; s < littleend; /**/ ) { | |
363 | if (*s++ != *x++) { | |
364 | s--; | |
365 | break; | |
366 | } | |
367 | } | |
368 | if (s >= littleend) | |
369 | return big-1; | |
378cc40b | 370 | } |
a687059c LW |
371 | return Nullch; |
372 | } | |
373 | ||
374 | /* reverse of the above--find last substring */ | |
375 | ||
376 | char * | |
377 | rninstr(big, bigend, little, lend) | |
378 | register char *big; | |
379 | char *bigend; | |
380 | char *little; | |
381 | char *lend; | |
382 | { | |
383 | register char *bigbeg; | |
384 | register char *s, *x; | |
79072805 | 385 | register I32 first = *little; |
a687059c LW |
386 | register char *littleend = lend; |
387 | ||
a0d0e21e | 388 | if (!first && little >= littleend) |
a687059c LW |
389 | return bigend; |
390 | bigbeg = big; | |
391 | big = bigend - (littleend - little++); | |
392 | while (big >= bigbeg) { | |
393 | if (*big-- != first) | |
394 | continue; | |
395 | for (x=big+2,s=little; s < littleend; /**/ ) { | |
396 | if (*s++ != *x++) { | |
397 | s--; | |
398 | break; | |
399 | } | |
400 | } | |
401 | if (s >= littleend) | |
402 | return big+1; | |
378cc40b | 403 | } |
a687059c | 404 | return Nullch; |
378cc40b | 405 | } |
a687059c | 406 | |
ef7eada9 JH |
407 | /* Initialize the fold[] array. */ |
408 | int | |
409 | perl_init_fold() | |
410 | { | |
411 | int i; | |
412 | ||
413 | for (i = 0; i < 256; i++) { | |
414 | if (isUPPER(i)) fold[i] = toLOWER(i); | |
415 | else if (isLOWER(i)) fold[i] = toUPPER(i); | |
416 | else fold[i] = i; | |
417 | } | |
418 | } | |
419 | ||
f0c5b223 TB |
420 | /* Initialize locale (and the fold[] array).*/ |
421 | int | |
1050c9ca | 422 | perl_init_i18nl10n(printwarn) |
f0c5b223 TB |
423 | int printwarn; |
424 | { | |
425 | int ok = 1; | |
426 | /* returns | |
427 | * 1 = set ok or not applicable, | |
428 | * 0 = fallback to C locale, | |
429 | * -1 = fallback to C locale failed | |
430 | */ | |
ef7eada9 | 431 | #if defined(HAS_SETLOCALE) |
f0c5b223 TB |
432 | char * lc_all = getenv("LC_ALL"); |
433 | char * lc_ctype = getenv("LC_CTYPE"); | |
ef7eada9 JH |
434 | char * lc_collate = getenv("LC_COLLATE"); |
435 | char * lang = getenv("LANG"); | |
436 | int setlocale_failure = 0; | |
437 | ||
438 | #define SETLOCALE_LC_CTYPE 0x01 | |
439 | #define SETLOCALE_LC_COLLATE 0x02 | |
440 | ||
441 | #ifdef LC_CTYPE | |
442 | if (setlocale(LC_CTYPE, "") == 0) | |
443 | setlocale_failure |= SETLOCALE_LC_CTYPE; | |
444 | #endif | |
f0c5b223 | 445 | |
ef7eada9 JH |
446 | #ifdef LC_COLLATE |
447 | if (setlocale(LC_COLLATE, "") == 0) | |
448 | setlocale_failure |= SETLOCALE_LC_COLLATE; | |
449 | else | |
450 | lc_collate_active = 1; | |
451 | #endif | |
452 | ||
453 | if (setlocale_failure && (lc_all || lang)) { | |
454 | char *perl_badlang; | |
20cec16a | 455 | |
456 | if (printwarn > 1 || | |
ef7eada9 JH |
457 | printwarn && |
458 | (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) { | |
459 | ||
460 | PerlIO_printf(PerlIO_stderr(), | |
461 | "perl: warning: Setting locale failed for the categories:\n\t"); | |
462 | #ifdef LC_CTYPE | |
463 | if (setlocale_failure & SETLOCALE_LC_CTYPE) | |
464 | PerlIO_printf(PerlIO_stderr(), | |
465 | "LC_CTYPE "); | |
466 | #endif | |
467 | #ifdef LC_COLLATE | |
468 | if (setlocale_failure & SETLOCALE_LC_COLLATE) | |
760ac839 | 469 | PerlIO_printf(PerlIO_stderr(), |
ef7eada9 JH |
470 | "LC_COLLATE "); |
471 | #endif | |
472 | PerlIO_printf(PerlIO_stderr(), | |
473 | "\n"); | |
474 | ||
475 | PerlIO_printf(PerlIO_stderr(), | |
476 | "perl: warning: Please check that your locale settings:\n"); | |
477 | ||
478 | PerlIO_printf(PerlIO_stderr(), | |
479 | "\tLC_ALL = %c%s%c,\n", | |
480 | lc_all ? '"' : '(', | |
481 | lc_all ? lc_all : "unset", | |
482 | lc_all ? '"' : ')' | |
f0c5b223 | 483 | ); |
ef7eada9 JH |
484 | #ifdef LC_CTYPE |
485 | if (setlocale_failure & SETLOCALE_LC_CTYPE) | |
486 | PerlIO_printf(PerlIO_stderr(), | |
487 | "\tLC_CTYPE = %c%s%c,\n", | |
488 | lc_ctype ? '"' : '(', | |
489 | lc_ctype ? lc_ctype : "unset", | |
490 | lc_ctype ? '"' : ')' | |
491 | ); | |
492 | #endif | |
493 | #ifdef LC_COLLATE | |
494 | if (setlocale_failure & SETLOCALE_LC_COLLATE) | |
495 | PerlIO_printf(PerlIO_stderr(), | |
496 | "\tLC_COLLATE = %c%s%c,\n", | |
497 | lc_collate ? '"' : '(', | |
498 | lc_collate ? lc_collate : "unset", | |
499 | lc_collate ? '"' : ')' | |
500 | ); | |
501 | #endif | |
502 | PerlIO_printf(PerlIO_stderr(), | |
503 | "\tLANG = %c%s%c\n", | |
504 | lang ? '"' : ')', | |
505 | lang ? lang : "unset", | |
506 | lang ? '"' : ')' | |
507 | ); | |
508 | ||
509 | PerlIO_printf(PerlIO_stderr(), | |
510 | " are supported and installed on your system.\n"); | |
511 | ||
f0c5b223 | 512 | ok = 0; |
ef7eada9 JH |
513 | |
514 | } | |
515 | #ifdef LC_ALL | |
516 | if (setlocale_failure) { | |
517 | PerlIO_printf(PerlIO_stderr(), | |
518 | "perl: warning: Falling back to the \"C\" locale.\n"); | |
519 | if (setlocale(LC_ALL, "C") == NULL) { | |
f0c5b223 | 520 | ok = -1; |
ef7eada9 JH |
521 | PerlIO_printf(PerlIO_stderr(), |
522 | "perl: warning: Failed to fall back to the \"C\" locale.\n"); | |
f0c5b223 | 523 | } |
f0c5b223 | 524 | } |
ef7eada9 JH |
525 | #else |
526 | PerlIO_printf(PerlIO_stderr(), | |
527 | "perl: warning: Cannot fall back to the \"C\" locale.\n"); | |
f0c5b223 | 528 | #endif |
ef7eada9 JH |
529 | } |
530 | ||
531 | if (setlocale_failure & SETLOCALE_LC_CTYPE == 0) | |
532 | perl_init_fold(); | |
533 | ||
534 | #endif /* #if defined(HAS_SETLOCALE) */ | |
535 | ||
f0c5b223 TB |
536 | return ok; |
537 | } | |
538 | ||
ef7eada9 JH |
539 | char * |
540 | mem_collxfrm(m, n, nx) /* mem_collxfrm() does strxfrm() for (data,size) */ | |
541 | const char *m; /* "strings", that is, transforms normal eight-bit */ | |
542 | const Size_t n; /* data into a format that can be memcmp()ed to get */ | |
543 | Size_t * nx; /* 'the right' result for each locale. */ | |
544 | { /* Uses strxfrm() but handles embedded NULs. */ | |
545 | char * mx = 0; | |
546 | ||
547 | #ifdef HAS_STRXFRM | |
548 | Size_t ma; | |
549 | ||
550 | /* the expansion factor of 16 has been seen with strxfrm() */ | |
551 | ma = (lc_collate_active ? 16 : 1) * n + 1; | |
552 | ||
553 | #define RENEW_mx() \ | |
554 | do { \ | |
555 | ma = 2 * ma + 1; \ | |
556 | Renew(mx, ma, char); \ | |
557 | if (mx == 0) \ | |
558 | goto out; \ | |
559 | } while (0) | |
560 | ||
561 | New(171, mx, ma, char); | |
562 | ||
563 | if (mx) { | |
564 | Size_t xc, dx; | |
565 | int xok; | |
566 | ||
567 | for (*nx = 0, xc = 0; xc < n; ) { | |
568 | if (m[xc] == 0) | |
569 | do { | |
570 | if (*nx == ma) | |
571 | RENEW_mx(); | |
572 | mx[*nx++] = m[xc++]; | |
573 | } while (xc < n && m[xc] == 0); | |
574 | else { | |
575 | do { | |
576 | dx = strxfrm(mx + *nx, m + xc, ma - *nx); | |
577 | if (dx + *nx > ma) { | |
578 | RENEW_mx(); | |
579 | xok = 0; | |
580 | } else | |
581 | xok = 1; | |
582 | } while (!xok); | |
583 | xc += strlen(mx + *nx); | |
584 | *nx += dx; | |
585 | } | |
586 | } | |
587 | } | |
588 | ||
589 | out: | |
590 | ||
591 | #endif /* HAS_STRXFRM */ | |
592 | ||
593 | return mx; | |
594 | } | |
595 | ||
378cc40b | 596 | void |
79072805 LW |
597 | fbm_compile(sv, iflag) |
598 | SV *sv; | |
599 | I32 iflag; | |
378cc40b | 600 | { |
a687059c LW |
601 | register unsigned char *s; |
602 | register unsigned char *table; | |
79072805 LW |
603 | register U32 i; |
604 | register U32 len = SvCUR(sv); | |
605 | I32 rarest = 0; | |
606 | U32 frequency = 256; | |
607 | ||
748a9306 LW |
608 | if (len > 255) |
609 | return; /* can't have offsets that big */ | |
79072805 | 610 | Sv_Grow(sv,len+258); |
463ee0b2 | 611 | table = (unsigned char*)(SvPVX(sv) + len + 1); |
a687059c LW |
612 | s = table - 2; |
613 | for (i = 0; i < 256; i++) { | |
378cc40b LW |
614 | table[i] = len; |
615 | } | |
616 | i = 0; | |
463ee0b2 | 617 | while (s >= (unsigned char*)(SvPVX(sv))) |
a687059c LW |
618 | { |
619 | if (table[*s] == len) { | |
620 | #ifndef pdp11 | |
621 | if (iflag) | |
622 | table[*s] = table[fold[*s]] = i; | |
623 | #else | |
624 | if (iflag) { | |
79072805 | 625 | I32 j; |
a687059c LW |
626 | j = fold[*s]; |
627 | table[j] = i; | |
628 | table[*s] = i; | |
629 | } | |
630 | #endif /* pdp11 */ | |
631 | else | |
632 | table[*s] = i; | |
633 | } | |
378cc40b LW |
634 | s--,i++; |
635 | } | |
79072805 | 636 | sv_upgrade(sv, SVt_PVBM); |
a0d0e21e | 637 | sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ |
79072805 | 638 | SvVALID_on(sv); |
378cc40b | 639 | |
463ee0b2 | 640 | s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ |
a687059c | 641 | if (iflag) { |
79072805 LW |
642 | register U32 tmp, foldtmp; |
643 | SvCASEFOLD_on(sv); | |
a687059c LW |
644 | for (i = 0; i < len; i++) { |
645 | tmp=freq[s[i]]; | |
646 | foldtmp=freq[fold[s[i]]]; | |
647 | if (tmp < frequency && foldtmp < frequency) { | |
648 | rarest = i; | |
649 | /* choose most frequent among the two */ | |
650 | frequency = (tmp > foldtmp) ? tmp : foldtmp; | |
651 | } | |
652 | } | |
653 | } | |
654 | else { | |
655 | for (i = 0; i < len; i++) { | |
656 | if (freq[s[i]] < frequency) { | |
657 | rarest = i; | |
658 | frequency = freq[s[i]]; | |
659 | } | |
378cc40b LW |
660 | } |
661 | } | |
79072805 LW |
662 | BmRARE(sv) = s[rarest]; |
663 | BmPREVIOUS(sv) = rarest; | |
760ac839 | 664 | DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); |
378cc40b LW |
665 | } |
666 | ||
378cc40b | 667 | char * |
79072805 | 668 | fbm_instr(big, bigend, littlestr) |
a687059c LW |
669 | unsigned char *big; |
670 | register unsigned char *bigend; | |
79072805 | 671 | SV *littlestr; |
378cc40b | 672 | { |
a687059c | 673 | register unsigned char *s; |
79072805 LW |
674 | register I32 tmp; |
675 | register I32 littlelen; | |
a687059c LW |
676 | register unsigned char *little; |
677 | register unsigned char *table; | |
678 | register unsigned char *olds; | |
679 | register unsigned char *oldlittle; | |
378cc40b | 680 | |
79072805 | 681 | if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { |
a0d0e21e LW |
682 | STRLEN len; |
683 | char *l = SvPV(littlestr,len); | |
684 | if (!len) | |
d48672a2 | 685 | return (char*)big; |
a0d0e21e | 686 | return ninstr((char*)big,(char*)bigend, l, l + len); |
d48672a2 | 687 | } |
378cc40b | 688 | |
79072805 LW |
689 | littlelen = SvCUR(littlestr); |
690 | if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ | |
0f85fab0 LW |
691 | if (littlelen > bigend - big) |
692 | return Nullch; | |
463ee0b2 | 693 | little = (unsigned char*)SvPVX(littlestr); |
79072805 | 694 | if (SvCASEFOLD(littlestr)) { /* oops, fake it */ |
a687059c LW |
695 | big = bigend - littlelen; /* just start near end */ |
696 | if (bigend[-1] == '\n' && little[littlelen-1] != '\n') | |
697 | big--; | |
378cc40b LW |
698 | } |
699 | else { | |
a687059c | 700 | s = bigend - littlelen; |
bd4080b3 | 701 | if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) |
a687059c | 702 | return (char*)s; /* how sweet it is */ |
34de22dd LW |
703 | else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' |
704 | && s > big) { | |
a687059c | 705 | s--; |
bd4080b3 | 706 | if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) |
a687059c LW |
707 | return (char*)s; |
708 | } | |
709 | return Nullch; | |
710 | } | |
711 | } | |
463ee0b2 | 712 | table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); |
62b28dd9 LW |
713 | if (--littlelen >= bigend - big) |
714 | return Nullch; | |
715 | s = big + littlelen; | |
a687059c | 716 | oldlittle = little = table - 2; |
79072805 | 717 | if (SvCASEFOLD(littlestr)) { /* case insensitive? */ |
20188a90 | 718 | if (s < bigend) { |
a687059c | 719 | top1: |
de3bb511 | 720 | /*SUPPRESS 560*/ |
a687059c | 721 | if (tmp = table[*s]) { |
62b28dd9 LW |
722 | #ifdef POINTERRIGOR |
723 | if (bigend - s > tmp) { | |
724 | s += tmp; | |
725 | goto top1; | |
726 | } | |
727 | #else | |
728 | if ((s += tmp) < bigend) | |
729 | goto top1; | |
730 | #endif | |
731 | return Nullch; | |
a687059c LW |
732 | } |
733 | else { | |
734 | tmp = littlelen; /* less expensive than calling strncmp() */ | |
735 | olds = s; | |
736 | while (tmp--) { | |
737 | if (*--s == *--little || fold[*s] == *little) | |
738 | continue; | |
739 | s = olds + 1; /* here we pay the price for failure */ | |
740 | little = oldlittle; | |
741 | if (s < bigend) /* fake up continue to outer loop */ | |
742 | goto top1; | |
743 | return Nullch; | |
744 | } | |
a687059c | 745 | return (char *)s; |
a687059c LW |
746 | } |
747 | } | |
748 | } | |
749 | else { | |
20188a90 | 750 | if (s < bigend) { |
a687059c | 751 | top2: |
de3bb511 | 752 | /*SUPPRESS 560*/ |
a687059c | 753 | if (tmp = table[*s]) { |
62b28dd9 LW |
754 | #ifdef POINTERRIGOR |
755 | if (bigend - s > tmp) { | |
756 | s += tmp; | |
757 | goto top2; | |
758 | } | |
759 | #else | |
760 | if ((s += tmp) < bigend) | |
761 | goto top2; | |
762 | #endif | |
763 | return Nullch; | |
a687059c LW |
764 | } |
765 | else { | |
766 | tmp = littlelen; /* less expensive than calling strncmp() */ | |
767 | olds = s; | |
768 | while (tmp--) { | |
769 | if (*--s == *--little) | |
770 | continue; | |
771 | s = olds + 1; /* here we pay the price for failure */ | |
772 | little = oldlittle; | |
773 | if (s < bigend) /* fake up continue to outer loop */ | |
774 | goto top2; | |
775 | return Nullch; | |
776 | } | |
a687059c | 777 | return (char *)s; |
378cc40b | 778 | } |
378cc40b LW |
779 | } |
780 | } | |
781 | return Nullch; | |
782 | } | |
783 | ||
784 | char * | |
785 | screaminstr(bigstr, littlestr) | |
79072805 LW |
786 | SV *bigstr; |
787 | SV *littlestr; | |
378cc40b | 788 | { |
a687059c LW |
789 | register unsigned char *s, *x; |
790 | register unsigned char *big; | |
79072805 LW |
791 | register I32 pos; |
792 | register I32 previous; | |
793 | register I32 first; | |
a687059c LW |
794 | register unsigned char *little; |
795 | register unsigned char *bigend; | |
796 | register unsigned char *littleend; | |
378cc40b | 797 | |
79072805 | 798 | if ((pos = screamfirst[BmRARE(littlestr)]) < 0) |
378cc40b | 799 | return Nullch; |
463ee0b2 | 800 | little = (unsigned char *)(SvPVX(littlestr)); |
79072805 | 801 | littleend = little + SvCUR(littlestr); |
378cc40b | 802 | first = *little++; |
79072805 | 803 | previous = BmPREVIOUS(littlestr); |
463ee0b2 | 804 | big = (unsigned char *)(SvPVX(bigstr)); |
79072805 | 805 | bigend = big + SvCUR(bigstr); |
378cc40b LW |
806 | while (pos < previous) { |
807 | if (!(pos += screamnext[pos])) | |
808 | return Nullch; | |
809 | } | |
de3bb511 | 810 | #ifdef POINTERRIGOR |
79072805 | 811 | if (SvCASEFOLD(littlestr)) { /* case insignificant? */ |
a687059c | 812 | do { |
988174c1 LW |
813 | if (big[pos-previous] != first && big[pos-previous] != fold[first]) |
814 | continue; | |
de3bb511 LW |
815 | for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { |
816 | if (x >= bigend) | |
817 | return Nullch; | |
818 | if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { | |
819 | s--; | |
820 | break; | |
821 | } | |
822 | } | |
823 | if (s == littleend) | |
de3bb511 | 824 | return (char *)(big+pos-previous); |
de3bb511 | 825 | } while ( |
de3bb511 | 826 | pos += screamnext[pos] /* does this goof up anywhere? */ |
de3bb511 LW |
827 | ); |
828 | } | |
829 | else { | |
830 | do { | |
988174c1 LW |
831 | if (big[pos-previous] != first) |
832 | continue; | |
de3bb511 LW |
833 | for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { |
834 | if (x >= bigend) | |
835 | return Nullch; | |
836 | if (*s++ != *x++) { | |
837 | s--; | |
838 | break; | |
839 | } | |
840 | } | |
841 | if (s == littleend) | |
de3bb511 | 842 | return (char *)(big+pos-previous); |
79072805 | 843 | } while ( pos += screamnext[pos] ); |
de3bb511 LW |
844 | } |
845 | #else /* !POINTERRIGOR */ | |
846 | big -= previous; | |
79072805 | 847 | if (SvCASEFOLD(littlestr)) { /* case insignificant? */ |
de3bb511 | 848 | do { |
988174c1 LW |
849 | if (big[pos] != first && big[pos] != fold[first]) |
850 | continue; | |
a687059c LW |
851 | for (x=big+pos+1,s=little; s < littleend; /**/ ) { |
852 | if (x >= bigend) | |
853 | return Nullch; | |
854 | if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { | |
855 | s--; | |
856 | break; | |
857 | } | |
858 | } | |
859 | if (s == littleend) | |
a687059c | 860 | return (char *)(big+pos); |
a687059c | 861 | } while ( |
a687059c | 862 | pos += screamnext[pos] /* does this goof up anywhere? */ |
a687059c LW |
863 | ); |
864 | } | |
865 | else { | |
866 | do { | |
988174c1 LW |
867 | if (big[pos] != first) |
868 | continue; | |
a687059c LW |
869 | for (x=big+pos+1,s=little; s < littleend; /**/ ) { |
870 | if (x >= bigend) | |
871 | return Nullch; | |
872 | if (*s++ != *x++) { | |
873 | s--; | |
874 | break; | |
875 | } | |
378cc40b | 876 | } |
a687059c | 877 | if (s == littleend) |
a687059c | 878 | return (char *)(big+pos); |
a687059c | 879 | } while ( |
a687059c | 880 | pos += screamnext[pos] |
a687059c LW |
881 | ); |
882 | } | |
de3bb511 | 883 | #endif /* POINTERRIGOR */ |
8d063cd8 LW |
884 | return Nullch; |
885 | } | |
886 | ||
79072805 LW |
887 | I32 |
888 | ibcmp(a,b,len) | |
a0d0e21e LW |
889 | register U8 *a; |
890 | register U8 *b; | |
79072805 LW |
891 | register I32 len; |
892 | { | |
893 | while (len--) { | |
894 | if (*a == *b) { | |
895 | a++,b++; | |
896 | continue; | |
897 | } | |
898 | if (fold[*a++] == *b++) | |
899 | continue; | |
900 | return 1; | |
901 | } | |
902 | return 0; | |
903 | } | |
904 | ||
8d063cd8 LW |
905 | /* copy a string to a safe spot */ |
906 | ||
907 | char * | |
a0d0e21e | 908 | savepv(sv) |
79072805 | 909 | char *sv; |
8d063cd8 | 910 | { |
a687059c | 911 | register char *newaddr; |
8d063cd8 | 912 | |
79072805 LW |
913 | New(902,newaddr,strlen(sv)+1,char); |
914 | (void)strcpy(newaddr,sv); | |
8d063cd8 LW |
915 | return newaddr; |
916 | } | |
917 | ||
a687059c LW |
918 | /* same thing but with a known length */ |
919 | ||
920 | char * | |
a0d0e21e | 921 | savepvn(sv, len) |
79072805 LW |
922 | char *sv; |
923 | register I32 len; | |
a687059c LW |
924 | { |
925 | register char *newaddr; | |
926 | ||
927 | New(903,newaddr,len+1,char); | |
79072805 | 928 | Copy(sv,newaddr,len,char); /* might not be null terminated */ |
a687059c LW |
929 | newaddr[len] = '\0'; /* is now */ |
930 | return newaddr; | |
931 | } | |
932 | ||
a0d0e21e | 933 | #if !defined(I_STDARG) && !defined(I_VARARGS) |
8d063cd8 | 934 | |
8990e307 LW |
935 | /* |
936 | * Fallback on the old hackers way of doing varargs | |
937 | */ | |
8d063cd8 | 938 | |
378cc40b | 939 | /*VARARGS1*/ |
7c0587c8 | 940 | char * |
378cc40b LW |
941 | mess(pat,a1,a2,a3,a4) |
942 | char *pat; | |
a687059c | 943 | long a1, a2, a3, a4; |
378cc40b LW |
944 | { |
945 | char *s; | |
f0c5b223 | 946 | char *s_start; |
79072805 LW |
947 | I32 usermess = strEQ(pat,"%s"); |
948 | SV *tmpstr; | |
378cc40b | 949 | |
f0c5b223 | 950 | s = s_start = buf; |
de3bb511 | 951 | if (usermess) { |
8990e307 | 952 | tmpstr = sv_newmortal(); |
79072805 | 953 | sv_setpv(tmpstr, (char*)a1); |
463ee0b2 | 954 | *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1]; |
de3bb511 LW |
955 | } |
956 | else { | |
957 | (void)sprintf(s,pat,a1,a2,a3,a4); | |
958 | s += strlen(s); | |
959 | } | |
960 | ||
378cc40b | 961 | if (s[-1] != '\n') { |
2304df62 AD |
962 | if (dirty) |
963 | strcpy(s, " during global destruction.\n"); | |
964 | else { | |
965 | if (curcop->cop_line) { | |
966 | (void)sprintf(s," at %s line %ld", | |
967 | SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); | |
968 | s += strlen(s); | |
969 | } | |
a0d0e21e LW |
970 | if (GvIO(last_in_gv) && |
971 | IoLINES(GvIOp(last_in_gv)) ) { | |
2304df62 AD |
972 | (void)sprintf(s,", <%s> %s %ld", |
973 | last_in_gv == argvgv ? "" : GvENAME(last_in_gv), | |
974 | strEQ(rs,"\n") ? "line" : "chunk", | |
a0d0e21e | 975 | (long)IoLINES(GvIOp(last_in_gv))); |
2304df62 AD |
976 | s += strlen(s); |
977 | } | |
978 | (void)strcpy(s,".\n"); | |
f0c5b223 | 979 | s += 2; |
378cc40b | 980 | } |
de3bb511 | 981 | if (usermess) |
79072805 | 982 | sv_catpv(tmpstr,buf+1); |
378cc40b | 983 | } |
f0c5b223 TB |
984 | |
985 | if (s - s_start >= sizeof(buf)) { /* Ooops! */ | |
986 | if (usermess) | |
760ac839 | 987 | PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); |
f0c5b223 | 988 | else |
760ac839 LW |
989 | PerlIO_puts(PerlIO_stderr(), buf); |
990 | PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n"); | |
f0c5b223 TB |
991 | my_exit(1); |
992 | } | |
de3bb511 | 993 | if (usermess) |
463ee0b2 | 994 | return SvPVX(tmpstr); |
de3bb511 LW |
995 | else |
996 | return buf; | |
378cc40b LW |
997 | } |
998 | ||
8d063cd8 | 999 | /*VARARGS1*/ |
463ee0b2 | 1000 | void croak(pat,a1,a2,a3,a4) |
8d063cd8 | 1001 | char *pat; |
a687059c | 1002 | long a1, a2, a3, a4; |
8d063cd8 | 1003 | { |
9f68db38 | 1004 | char *tmps; |
de3bb511 | 1005 | char *message; |
748a9306 LW |
1006 | HV *stash; |
1007 | GV *gv; | |
1008 | CV *cv; | |
8d063cd8 | 1009 | |
de3bb511 | 1010 | message = mess(pat,a1,a2,a3,a4); |
20cec16a | 1011 | if (diehook) { |
1012 | SV *olddiehook = diehook; | |
1013 | diehook = Nullsv; /* sv_2cv might call croak() */ | |
1014 | cv = sv_2cv(olddiehook, &stash, &gv, 0); | |
1015 | diehook = olddiehook; | |
1016 | if (cv && !CvDEPTH(cv)) { | |
1017 | dSP; | |
1018 | ||
1019 | PUSHMARK(sp); | |
1020 | EXTEND(sp, 1); | |
1021 | PUSHs(sv_2mortal(newSVpv(message,0))); | |
1022 | PUTBACK; | |
1023 | perl_call_sv((SV*)cv, G_DISCARD); | |
1024 | } | |
748a9306 | 1025 | } |
a0d0e21e LW |
1026 | if (in_eval) { |
1027 | restartop = die_where(message); | |
a5f75d66 | 1028 | Siglongjmp(top_env, 3); |
a0d0e21e | 1029 | } |
760ac839 LW |
1030 | PerlIO_puts(PerlIO_stderr(),message); |
1031 | (void)PerlIO_flush(PerlIO_stderr()); | |
38cd9116 | 1032 | if (e_tmpname) { |
1033 | if (e_fp) { | |
760ac839 | 1034 | PerlIO_close(e_fp); |
38cd9116 | 1035 | e_fp = Nullfp; |
1036 | } | |
a687059c | 1037 | (void)UNLINK(e_tmpname); |
38cd9116 | 1038 | Safefree(e_tmpname); |
1039 | e_tmpname = Nullch; | |
f0c5b223 | 1040 | } |
748a9306 LW |
1041 | statusvalue = SHIFTSTATUS(statusvalue); |
1042 | #ifdef VMS | |
1043 | my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT); | |
1044 | #else | |
1045 | my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); | |
1046 | #endif | |
378cc40b LW |
1047 | } |
1048 | ||
1049 | /*VARARGS1*/ | |
7c0587c8 | 1050 | void warn(pat,a1,a2,a3,a4) |
378cc40b | 1051 | char *pat; |
a687059c | 1052 | long a1, a2, a3, a4; |
378cc40b | 1053 | { |
de3bb511 | 1054 | char *message; |
748a9306 LW |
1055 | SV *sv; |
1056 | HV *stash; | |
1057 | GV *gv; | |
1058 | CV *cv; | |
de3bb511 LW |
1059 | |
1060 | message = mess(pat,a1,a2,a3,a4); | |
20cec16a | 1061 | if (warnhook) { |
1062 | SV *oldwarnhook = warnhook; | |
1063 | warnhook = Nullsv; /* sv_2cv might end up calling warn() */ | |
1064 | cv = sv_2cv(oldwarnhook, &stash, &gv, 0); | |
1065 | warnhook = oldwarnhook; | |
1066 | if (cv && !CvDEPTH(cv)) { | |
1067 | dSP; | |
1068 | ||
1069 | PUSHMARK(sp); | |
1070 | EXTEND(sp, 1); | |
1071 | PUSHs(sv_2mortal(newSVpv(message,0))); | |
1072 | PUTBACK; | |
1073 | perl_call_sv((SV*)cv, G_DISCARD); | |
1074 | return; | |
1075 | } | |
748a9306 | 1076 | } |
20cec16a | 1077 | PerlIO_puts(PerlIO_stderr(),message); |
a687059c | 1078 | #ifdef LEAKTEST |
20cec16a | 1079 | DEBUG_L(xstat()); |
a687059c | 1080 | #endif |
20cec16a | 1081 | (void)PerlIO_flush(PerlIO_stderr()); |
8d063cd8 | 1082 | } |
8990e307 | 1083 | |
a0d0e21e | 1084 | #else /* !defined(I_STDARG) && !defined(I_VARARGS) */ |
8990e307 | 1085 | |
a0d0e21e | 1086 | #ifdef I_STDARG |
8990e307 | 1087 | char * |
2304df62 | 1088 | mess(char *pat, va_list *args) |
a687059c LW |
1089 | #else |
1090 | /*VARARGS0*/ | |
de3bb511 | 1091 | char * |
8990e307 | 1092 | mess(pat, args) |
a687059c | 1093 | char *pat; |
2304df62 | 1094 | va_list *args; |
8990e307 LW |
1095 | #endif |
1096 | { | |
a687059c | 1097 | char *s; |
f0c5b223 | 1098 | char *s_start; |
79072805 LW |
1099 | SV *tmpstr; |
1100 | I32 usermess; | |
d48672a2 | 1101 | #ifndef HAS_VPRINTF |
85e6fe83 | 1102 | #ifdef USE_CHAR_VSPRINTF |
a687059c LW |
1103 | char *vsprintf(); |
1104 | #else | |
79072805 | 1105 | I32 vsprintf(); |
a687059c | 1106 | #endif |
d48672a2 | 1107 | #endif |
a687059c | 1108 | |
f0c5b223 | 1109 | s = s_start = buf; |
de3bb511 LW |
1110 | usermess = strEQ(pat, "%s"); |
1111 | if (usermess) { | |
8990e307 | 1112 | tmpstr = sv_newmortal(); |
2304df62 | 1113 | sv_setpv(tmpstr, va_arg(*args, char *)); |
463ee0b2 | 1114 | *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1]; |
de3bb511 LW |
1115 | } |
1116 | else { | |
2304df62 | 1117 | (void) vsprintf(s,pat,*args); |
de3bb511 LW |
1118 | s += strlen(s); |
1119 | } | |
2304df62 | 1120 | va_end(*args); |
a687059c | 1121 | |
a687059c | 1122 | if (s[-1] != '\n') { |
2304df62 AD |
1123 | if (dirty) |
1124 | strcpy(s, " during global destruction.\n"); | |
1125 | else { | |
1126 | if (curcop->cop_line) { | |
1127 | (void)sprintf(s," at %s line %ld", | |
1128 | SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); | |
1129 | s += strlen(s); | |
1130 | } | |
c07a80fd | 1131 | if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { |
1132 | bool line_mode = (RsSIMPLE(rs) && | |
1133 | SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); | |
2304df62 AD |
1134 | (void)sprintf(s,", <%s> %s %ld", |
1135 | last_in_gv == argvgv ? "" : GvNAME(last_in_gv), | |
c07a80fd | 1136 | line_mode ? "line" : "chunk", |
a0d0e21e | 1137 | (long)IoLINES(GvIOp(last_in_gv))); |
2304df62 AD |
1138 | s += strlen(s); |
1139 | } | |
1140 | (void)strcpy(s,".\n"); | |
f0c5b223 | 1141 | s += 2; |
a687059c | 1142 | } |
de3bb511 | 1143 | if (usermess) |
79072805 | 1144 | sv_catpv(tmpstr,buf+1); |
a687059c | 1145 | } |
de3bb511 | 1146 | |
f0c5b223 TB |
1147 | if (s - s_start >= sizeof(buf)) { /* Ooops! */ |
1148 | if (usermess) | |
760ac839 | 1149 | PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); |
f0c5b223 | 1150 | else |
760ac839 LW |
1151 | PerlIO_puts(PerlIO_stderr(), buf); |
1152 | PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n"); | |
f0c5b223 TB |
1153 | my_exit(1); |
1154 | } | |
de3bb511 | 1155 | if (usermess) |
463ee0b2 | 1156 | return SvPVX(tmpstr); |
de3bb511 LW |
1157 | else |
1158 | return buf; | |
a687059c LW |
1159 | } |
1160 | ||
ecfc5424 | 1161 | #ifdef I_STDARG |
79072805 | 1162 | void |
8990e307 | 1163 | croak(char* pat, ...) |
463ee0b2 | 1164 | #else |
8990e307 LW |
1165 | /*VARARGS0*/ |
1166 | void | |
1167 | croak(pat, va_alist) | |
1168 | char *pat; | |
1169 | va_dcl | |
463ee0b2 | 1170 | #endif |
a687059c LW |
1171 | { |
1172 | va_list args; | |
de3bb511 | 1173 | char *message; |
748a9306 LW |
1174 | HV *stash; |
1175 | GV *gv; | |
1176 | CV *cv; | |
a687059c | 1177 | |
a0d0e21e | 1178 | #ifdef I_STDARG |
8990e307 LW |
1179 | va_start(args, pat); |
1180 | #else | |
a687059c | 1181 | va_start(args); |
8990e307 | 1182 | #endif |
2304df62 | 1183 | message = mess(pat, &args); |
a687059c | 1184 | va_end(args); |
20cec16a | 1185 | if (diehook) { |
1186 | SV *olddiehook = diehook; | |
1187 | diehook = Nullsv; /* sv_2cv might call croak() */ | |
1188 | cv = sv_2cv(olddiehook, &stash, &gv, 0); | |
1189 | diehook = olddiehook; | |
1190 | if (cv && !CvDEPTH(cv)) { | |
1191 | dSP; | |
1192 | ||
1193 | PUSHMARK(sp); | |
1194 | EXTEND(sp, 1); | |
1195 | PUSHs(sv_2mortal(newSVpv(message,0))); | |
1196 | PUTBACK; | |
1197 | perl_call_sv((SV*)cv, G_DISCARD); | |
1198 | } | |
748a9306 | 1199 | } |
a0d0e21e LW |
1200 | if (in_eval) { |
1201 | restartop = die_where(message); | |
a5f75d66 | 1202 | Siglongjmp(top_env, 3); |
a0d0e21e | 1203 | } |
760ac839 LW |
1204 | PerlIO_puts(PerlIO_stderr(),message); |
1205 | (void)PerlIO_flush(PerlIO_stderr()); | |
38cd9116 | 1206 | if (e_tmpname) { |
1207 | if (e_fp) { | |
760ac839 | 1208 | PerlIO_close(e_fp); |
38cd9116 | 1209 | e_fp = Nullfp; |
1210 | } | |
a687059c | 1211 | (void)UNLINK(e_tmpname); |
38cd9116 | 1212 | Safefree(e_tmpname); |
1213 | e_tmpname = Nullch; | |
f0c5b223 | 1214 | } |
748a9306 LW |
1215 | statusvalue = SHIFTSTATUS(statusvalue); |
1216 | #ifdef VMS | |
1217 | my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44))); | |
1218 | #else | |
1219 | my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); | |
1220 | #endif | |
a687059c LW |
1221 | } |
1222 | ||
8990e307 | 1223 | void |
ecfc5424 | 1224 | #ifdef I_STDARG |
8990e307 | 1225 | warn(char* pat,...) |
463ee0b2 | 1226 | #else |
8990e307 LW |
1227 | /*VARARGS0*/ |
1228 | warn(pat,va_alist) | |
1229 | char *pat; | |
1230 | va_dcl | |
463ee0b2 | 1231 | #endif |
a687059c LW |
1232 | { |
1233 | va_list args; | |
de3bb511 | 1234 | char *message; |
748a9306 LW |
1235 | HV *stash; |
1236 | GV *gv; | |
1237 | CV *cv; | |
a687059c | 1238 | |
a0d0e21e | 1239 | #ifdef I_STDARG |
8990e307 LW |
1240 | va_start(args, pat); |
1241 | #else | |
a687059c | 1242 | va_start(args); |
8990e307 | 1243 | #endif |
2304df62 | 1244 | message = mess(pat, &args); |
a687059c LW |
1245 | va_end(args); |
1246 | ||
20cec16a | 1247 | if (warnhook) { |
1248 | SV *oldwarnhook = warnhook; | |
1249 | warnhook = Nullsv; /* sv_2cv might end up calling warn() */ | |
1250 | cv = sv_2cv(oldwarnhook, &stash, &gv, 0); | |
1251 | warnhook = oldwarnhook; | |
1252 | if (cv && !CvDEPTH(cv)) { | |
1253 | dSP; | |
1254 | ||
1255 | PUSHMARK(sp); | |
1256 | EXTEND(sp, 1); | |
1257 | PUSHs(sv_2mortal(newSVpv(message,0))); | |
1258 | PUTBACK; | |
1259 | perl_call_sv((SV*)cv, G_DISCARD); | |
1260 | return; | |
1261 | } | |
748a9306 | 1262 | } |
20cec16a | 1263 | PerlIO_puts(PerlIO_stderr(),message); |
a687059c | 1264 | #ifdef LEAKTEST |
20cec16a | 1265 | DEBUG_L(xstat()); |
a687059c | 1266 | #endif |
20cec16a | 1267 | (void)PerlIO_flush(PerlIO_stderr()); |
a687059c | 1268 | } |
a0d0e21e | 1269 | #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ |
8d063cd8 | 1270 | |
a0d0e21e | 1271 | #ifndef VMS /* VMS' my_setenv() is in VMS.c */ |
8d063cd8 | 1272 | void |
7c0587c8 | 1273 | my_setenv(nam,val) |
8d063cd8 LW |
1274 | char *nam, *val; |
1275 | { | |
79072805 | 1276 | register I32 i=setenv_getix(nam); /* where does it go? */ |
8d063cd8 | 1277 | |
fe14fcc3 | 1278 | if (environ == origenviron) { /* need we copy environment? */ |
79072805 LW |
1279 | I32 j; |
1280 | I32 max; | |
fe14fcc3 LW |
1281 | char **tmpenv; |
1282 | ||
de3bb511 | 1283 | /*SUPPRESS 530*/ |
fe14fcc3 LW |
1284 | for (max = i; environ[max]; max++) ; |
1285 | New(901,tmpenv, max+2, char*); | |
1286 | for (j=0; j<max; j++) /* copy environment */ | |
a0d0e21e | 1287 | tmpenv[j] = savepv(environ[j]); |
fe14fcc3 LW |
1288 | tmpenv[max] = Nullch; |
1289 | environ = tmpenv; /* tell exec where it is now */ | |
1290 | } | |
a687059c LW |
1291 | if (!val) { |
1292 | while (environ[i]) { | |
1293 | environ[i] = environ[i+1]; | |
1294 | i++; | |
1295 | } | |
1296 | return; | |
1297 | } | |
8d063cd8 | 1298 | if (!environ[i]) { /* does not exist yet */ |
fe14fcc3 | 1299 | Renew(environ, i+2, char*); /* just expand it a bit */ |
8d063cd8 LW |
1300 | environ[i+1] = Nullch; /* make sure it's null terminated */ |
1301 | } | |
fe14fcc3 LW |
1302 | else |
1303 | Safefree(environ[i]); | |
a687059c | 1304 | New(904, environ[i], strlen(nam) + strlen(val) + 2, char); |
62b28dd9 | 1305 | #ifndef MSDOS |
a687059c | 1306 | (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ |
62b28dd9 LW |
1307 | #else |
1308 | /* MS-DOS requires environment variable names to be in uppercase */ | |
fe14fcc3 LW |
1309 | /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but |
1310 | * some utilities and applications may break because they only look | |
1311 | * for upper case strings. (Fixed strupr() bug here.)] | |
1312 | */ | |
1313 | strcpy(environ[i],nam); strupr(environ[i]); | |
62b28dd9 LW |
1314 | (void)sprintf(environ[i] + strlen(nam),"=%s",val); |
1315 | #endif /* MSDOS */ | |
8d063cd8 LW |
1316 | } |
1317 | ||
79072805 LW |
1318 | I32 |
1319 | setenv_getix(nam) | |
8d063cd8 LW |
1320 | char *nam; |
1321 | { | |
79072805 | 1322 | register I32 i, len = strlen(nam); |
8d063cd8 LW |
1323 | |
1324 | for (i = 0; environ[i]; i++) { | |
1325 | if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') | |
1326 | break; /* strnEQ must come first to avoid */ | |
1327 | } /* potential SEGV's */ | |
1328 | return i; | |
1329 | } | |
a0d0e21e | 1330 | #endif /* !VMS */ |
378cc40b | 1331 | |
16d20bd9 | 1332 | #ifdef UNLINK_ALL_VERSIONS |
79072805 | 1333 | I32 |
378cc40b LW |
1334 | unlnk(f) /* unlink all versions of a file */ |
1335 | char *f; | |
1336 | { | |
79072805 | 1337 | I32 i; |
378cc40b LW |
1338 | |
1339 | for (i = 0; unlink(f) >= 0; i++) ; | |
1340 | return i ? 0 : -1; | |
1341 | } | |
1342 | #endif | |
1343 | ||
85e6fe83 | 1344 | #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) |
378cc40b | 1345 | char * |
7c0587c8 | 1346 | my_bcopy(from,to,len) |
378cc40b LW |
1347 | register char *from; |
1348 | register char *to; | |
79072805 | 1349 | register I32 len; |
378cc40b LW |
1350 | { |
1351 | char *retval = to; | |
1352 | ||
7c0587c8 LW |
1353 | if (from - to >= 0) { |
1354 | while (len--) | |
1355 | *to++ = *from++; | |
1356 | } | |
1357 | else { | |
1358 | to += len; | |
1359 | from += len; | |
1360 | while (len--) | |
faf8582f | 1361 | *(--to) = *(--from); |
7c0587c8 | 1362 | } |
378cc40b LW |
1363 | return retval; |
1364 | } | |
ffed7fef | 1365 | #endif |
378cc40b | 1366 | |
7c0587c8 | 1367 | #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) |
378cc40b | 1368 | char * |
7c0587c8 | 1369 | my_bzero(loc,len) |
378cc40b | 1370 | register char *loc; |
79072805 | 1371 | register I32 len; |
378cc40b LW |
1372 | { |
1373 | char *retval = loc; | |
1374 | ||
1375 | while (len--) | |
1376 | *loc++ = 0; | |
1377 | return retval; | |
1378 | } | |
1379 | #endif | |
7c0587c8 LW |
1380 | |
1381 | #ifndef HAS_MEMCMP | |
79072805 | 1382 | I32 |
7c0587c8 LW |
1383 | my_memcmp(s1,s2,len) |
1384 | register unsigned char *s1; | |
1385 | register unsigned char *s2; | |
79072805 | 1386 | register I32 len; |
7c0587c8 | 1387 | { |
79072805 | 1388 | register I32 tmp; |
7c0587c8 LW |
1389 | |
1390 | while (len--) { | |
1391 | if (tmp = *s1++ - *s2++) | |
1392 | return tmp; | |
1393 | } | |
1394 | return 0; | |
1395 | } | |
1396 | #endif /* HAS_MEMCMP */ | |
a687059c | 1397 | |
4633a7c4 | 1398 | #if defined(I_STDARG) || defined(I_VARARGS) |
fe14fcc3 | 1399 | #ifndef HAS_VPRINTF |
a687059c | 1400 | |
85e6fe83 | 1401 | #ifdef USE_CHAR_VSPRINTF |
a687059c LW |
1402 | char * |
1403 | #else | |
1404 | int | |
1405 | #endif | |
1406 | vsprintf(dest, pat, args) | |
1407 | char *dest, *pat, *args; | |
1408 | { | |
1409 | FILE fakebuf; | |
1410 | ||
1411 | fakebuf._ptr = dest; | |
1412 | fakebuf._cnt = 32767; | |
35c8bce7 LW |
1413 | #ifndef _IOSTRG |
1414 | #define _IOSTRG 0 | |
1415 | #endif | |
a687059c LW |
1416 | fakebuf._flag = _IOWRT|_IOSTRG; |
1417 | _doprnt(pat, args, &fakebuf); /* what a kludge */ | |
1418 | (void)putc('\0', &fakebuf); | |
85e6fe83 | 1419 | #ifdef USE_CHAR_VSPRINTF |
a687059c LW |
1420 | return(dest); |
1421 | #else | |
1422 | return 0; /* perl doesn't use return value */ | |
1423 | #endif | |
1424 | } | |
1425 | ||
fe14fcc3 | 1426 | #endif /* HAS_VPRINTF */ |
4633a7c4 | 1427 | #endif /* I_VARARGS || I_STDARGS */ |
a687059c LW |
1428 | |
1429 | #ifdef MYSWAP | |
ffed7fef | 1430 | #if BYTEORDER != 0x4321 |
a687059c | 1431 | short |
748a9306 | 1432 | #ifndef CAN_PROTOTYPE |
a687059c LW |
1433 | my_swap(s) |
1434 | short s; | |
748a9306 LW |
1435 | #else |
1436 | my_swap(short s) | |
1437 | #endif | |
a687059c LW |
1438 | { |
1439 | #if (BYTEORDER & 1) == 0 | |
1440 | short result; | |
1441 | ||
1442 | result = ((s & 255) << 8) + ((s >> 8) & 255); | |
1443 | return result; | |
1444 | #else | |
1445 | return s; | |
1446 | #endif | |
1447 | } | |
1448 | ||
1449 | long | |
748a9306 LW |
1450 | #ifndef CAN_PROTOTYPE |
1451 | my_htonl(l) | |
a687059c | 1452 | register long l; |
748a9306 LW |
1453 | #else |
1454 | my_htonl(long l) | |
1455 | #endif | |
a687059c LW |
1456 | { |
1457 | union { | |
1458 | long result; | |
ffed7fef | 1459 | char c[sizeof(long)]; |
a687059c LW |
1460 | } u; |
1461 | ||
ffed7fef | 1462 | #if BYTEORDER == 0x1234 |
a687059c LW |
1463 | u.c[0] = (l >> 24) & 255; |
1464 | u.c[1] = (l >> 16) & 255; | |
1465 | u.c[2] = (l >> 8) & 255; | |
1466 | u.c[3] = l & 255; | |
1467 | return u.result; | |
1468 | #else | |
ffed7fef | 1469 | #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) |
463ee0b2 | 1470 | croak("Unknown BYTEORDER\n"); |
a687059c | 1471 | #else |
79072805 LW |
1472 | register I32 o; |
1473 | register I32 s; | |
a687059c | 1474 | |
ffed7fef LW |
1475 | for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { |
1476 | u.c[o & 0xf] = (l >> s) & 255; | |
a687059c LW |
1477 | } |
1478 | return u.result; | |
1479 | #endif | |
1480 | #endif | |
1481 | } | |
1482 | ||
1483 | long | |
748a9306 LW |
1484 | #ifndef CAN_PROTOTYPE |
1485 | my_ntohl(l) | |
a687059c | 1486 | register long l; |
748a9306 LW |
1487 | #else |
1488 | my_ntohl(long l) | |
1489 | #endif | |
a687059c LW |
1490 | { |
1491 | union { | |
1492 | long l; | |
ffed7fef | 1493 | char c[sizeof(long)]; |
a687059c LW |
1494 | } u; |
1495 | ||
ffed7fef | 1496 | #if BYTEORDER == 0x1234 |
a687059c LW |
1497 | u.c[0] = (l >> 24) & 255; |
1498 | u.c[1] = (l >> 16) & 255; | |
1499 | u.c[2] = (l >> 8) & 255; | |
1500 | u.c[3] = l & 255; | |
1501 | return u.l; | |
1502 | #else | |
ffed7fef | 1503 | #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) |
463ee0b2 | 1504 | croak("Unknown BYTEORDER\n"); |
a687059c | 1505 | #else |
79072805 LW |
1506 | register I32 o; |
1507 | register I32 s; | |
a687059c LW |
1508 | |
1509 | u.l = l; | |
1510 | l = 0; | |
ffed7fef LW |
1511 | for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { |
1512 | l |= (u.c[o & 0xf] & 255) << s; | |
a687059c LW |
1513 | } |
1514 | return l; | |
1515 | #endif | |
1516 | #endif | |
1517 | } | |
1518 | ||
ffed7fef | 1519 | #endif /* BYTEORDER != 0x4321 */ |
988174c1 LW |
1520 | #endif /* MYSWAP */ |
1521 | ||
1522 | /* | |
1523 | * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. | |
1524 | * If these functions are defined, | |
1525 | * the BYTEORDER is neither 0x1234 nor 0x4321. | |
1526 | * However, this is not assumed. | |
1527 | * -DWS | |
1528 | */ | |
1529 | ||
1530 | #define HTOV(name,type) \ | |
1531 | type \ | |
1532 | name (n) \ | |
1533 | register type n; \ | |
1534 | { \ | |
1535 | union { \ | |
1536 | type value; \ | |
1537 | char c[sizeof(type)]; \ | |
1538 | } u; \ | |
79072805 LW |
1539 | register I32 i; \ |
1540 | register I32 s; \ | |
988174c1 LW |
1541 | for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ |
1542 | u.c[i] = (n >> s) & 0xFF; \ | |
1543 | } \ | |
1544 | return u.value; \ | |
1545 | } | |
1546 | ||
1547 | #define VTOH(name,type) \ | |
1548 | type \ | |
1549 | name (n) \ | |
1550 | register type n; \ | |
1551 | { \ | |
1552 | union { \ | |
1553 | type value; \ | |
1554 | char c[sizeof(type)]; \ | |
1555 | } u; \ | |
79072805 LW |
1556 | register I32 i; \ |
1557 | register I32 s; \ | |
988174c1 LW |
1558 | u.value = n; \ |
1559 | n = 0; \ | |
1560 | for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ | |
1561 | n += (u.c[i] & 0xFF) << s; \ | |
1562 | } \ | |
1563 | return n; \ | |
1564 | } | |
1565 | ||
1566 | #if defined(HAS_HTOVS) && !defined(htovs) | |
1567 | HTOV(htovs,short) | |
1568 | #endif | |
1569 | #if defined(HAS_HTOVL) && !defined(htovl) | |
1570 | HTOV(htovl,long) | |
1571 | #endif | |
1572 | #if defined(HAS_VTOHS) && !defined(vtohs) | |
1573 | VTOH(vtohs,short) | |
1574 | #endif | |
1575 | #if defined(HAS_VTOHL) && !defined(vtohl) | |
1576 | VTOH(vtohl,long) | |
1577 | #endif | |
a687059c | 1578 | |
1050c9ca | 1579 | #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in |
f0c5b223 | 1580 | VMS.c, same with OS/2. */ |
760ac839 | 1581 | PerlIO * |
79072805 | 1582 | my_popen(cmd,mode) |
a687059c LW |
1583 | char *cmd; |
1584 | char *mode; | |
1585 | { | |
1586 | int p[2]; | |
79072805 LW |
1587 | register I32 this, that; |
1588 | register I32 pid; | |
1589 | SV *sv; | |
1590 | I32 doexec = strNE(cmd,"-"); | |
a687059c LW |
1591 | |
1592 | if (pipe(p) < 0) | |
1593 | return Nullfp; | |
1594 | this = (*mode == 'w'); | |
1595 | that = !this; | |
463ee0b2 LW |
1596 | if (tainting) { |
1597 | if (doexec) { | |
1598 | taint_env(); | |
1599 | taint_proper("Insecure %s%s", "EXEC"); | |
1600 | } | |
d48672a2 | 1601 | } |
a687059c LW |
1602 | while ((pid = (doexec?vfork():fork())) < 0) { |
1603 | if (errno != EAGAIN) { | |
1604 | close(p[this]); | |
1605 | if (!doexec) | |
463ee0b2 | 1606 | croak("Can't fork"); |
a687059c LW |
1607 | return Nullfp; |
1608 | } | |
1609 | sleep(5); | |
1610 | } | |
1611 | if (pid == 0) { | |
79072805 LW |
1612 | GV* tmpgv; |
1613 | ||
a687059c LW |
1614 | #define THIS that |
1615 | #define THAT this | |
1616 | close(p[THAT]); | |
1617 | if (p[THIS] != (*mode == 'r')) { | |
1618 | dup2(p[THIS], *mode == 'r'); | |
1619 | close(p[THIS]); | |
1620 | } | |
1621 | if (doexec) { | |
a0d0e21e | 1622 | #if !defined(HAS_FCNTL) || !defined(F_SETFD) |
ae986130 LW |
1623 | int fd; |
1624 | ||
1625 | #ifndef NOFILE | |
1626 | #define NOFILE 20 | |
1627 | #endif | |
d48672a2 | 1628 | for (fd = maxsysfd + 1; fd < NOFILE; fd++) |
ae986130 LW |
1629 | close(fd); |
1630 | #endif | |
a687059c LW |
1631 | do_exec(cmd); /* may or may not use the shell */ |
1632 | _exit(1); | |
1633 | } | |
de3bb511 | 1634 | /*SUPPRESS 560*/ |
85e6fe83 | 1635 | if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) |
79072805 | 1636 | sv_setiv(GvSV(tmpgv),(I32)getpid()); |
9f68db38 | 1637 | forkprocess = 0; |
463ee0b2 | 1638 | hv_clear(pidstatus); /* we have no children */ |
a687059c LW |
1639 | return Nullfp; |
1640 | #undef THIS | |
1641 | #undef THAT | |
1642 | } | |
62b28dd9 | 1643 | do_execfree(); /* free any memory malloced by child on vfork */ |
a687059c | 1644 | close(p[that]); |
62b28dd9 LW |
1645 | if (p[that] < p[this]) { |
1646 | dup2(p[this], p[that]); | |
1647 | close(p[this]); | |
1648 | p[this] = p[that]; | |
1649 | } | |
79072805 | 1650 | sv = *av_fetch(fdpid,p[this],TRUE); |
a0d0e21e | 1651 | (void)SvUPGRADE(sv,SVt_IV); |
463ee0b2 | 1652 | SvIVX(sv) = pid; |
a687059c | 1653 | forkprocess = pid; |
760ac839 | 1654 | return PerlIO_fdopen(p[this], mode); |
a687059c | 1655 | } |
7c0587c8 | 1656 | #else |
f0c5b223 | 1657 | #if defined(atarist) |
7c0587c8 | 1658 | FILE *popen(); |
760ac839 | 1659 | PerlIO * |
79072805 | 1660 | my_popen(cmd,mode) |
7c0587c8 LW |
1661 | char *cmd; |
1662 | char *mode; | |
1663 | { | |
760ac839 LW |
1664 | /* Needs work for PerlIO ! */ |
1665 | return popen(PerlIO_exportFILE(cmd), mode); | |
7c0587c8 LW |
1666 | } |
1667 | #endif | |
1668 | ||
1669 | #endif /* !DOSISH */ | |
a687059c | 1670 | |
748a9306 | 1671 | #ifdef DUMP_FDS |
79072805 | 1672 | dump_fds(s) |
ae986130 LW |
1673 | char *s; |
1674 | { | |
1675 | int fd; | |
1676 | struct stat tmpstatbuf; | |
1677 | ||
760ac839 | 1678 | PerlIO_printf(PerlIO_stderr(),"%s", s); |
ae986130 | 1679 | for (fd = 0; fd < 32; fd++) { |
a0d0e21e | 1680 | if (Fstat(fd,&tmpstatbuf) >= 0) |
760ac839 | 1681 | PerlIO_printf(PerlIO_stderr()," %d",fd); |
ae986130 | 1682 | } |
760ac839 | 1683 | PerlIO_printf(PerlIO_stderr(),"\n"); |
ae986130 LW |
1684 | } |
1685 | #endif | |
1686 | ||
fe14fcc3 | 1687 | #ifndef HAS_DUP2 |
fec02dd3 | 1688 | int |
a687059c LW |
1689 | dup2(oldfd,newfd) |
1690 | int oldfd; | |
1691 | int newfd; | |
1692 | { | |
a0d0e21e | 1693 | #if defined(HAS_FCNTL) && defined(F_DUPFD) |
fec02dd3 AD |
1694 | if (oldfd == newfd) |
1695 | return oldfd; | |
62b28dd9 | 1696 | close(newfd); |
fec02dd3 | 1697 | return fcntl(oldfd, F_DUPFD, newfd); |
62b28dd9 | 1698 | #else |
d48672a2 | 1699 | int fdtmp[256]; |
79072805 | 1700 | I32 fdx = 0; |
ae986130 LW |
1701 | int fd; |
1702 | ||
fe14fcc3 | 1703 | if (oldfd == newfd) |
fec02dd3 | 1704 | return oldfd; |
a687059c | 1705 | close(newfd); |
fec02dd3 | 1706 | while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */ |
ae986130 LW |
1707 | fdtmp[fdx++] = fd; |
1708 | while (fdx > 0) | |
1709 | close(fdtmp[--fdx]); | |
fec02dd3 | 1710 | return fd; |
62b28dd9 | 1711 | #endif |
a687059c LW |
1712 | } |
1713 | #endif | |
1714 | ||
1050c9ca | 1715 | #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ |
79072805 LW |
1716 | I32 |
1717 | my_pclose(ptr) | |
760ac839 | 1718 | PerlIO *ptr; |
a687059c | 1719 | { |
ecfc5424 | 1720 | Signal_t (*hstat)(), (*istat)(), (*qstat)(); |
a687059c | 1721 | int status; |
a0d0e21e | 1722 | SV **svp; |
20188a90 | 1723 | int pid; |
a687059c | 1724 | |
760ac839 | 1725 | svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); |
748a9306 | 1726 | pid = (int)SvIVX(*svp); |
a0d0e21e LW |
1727 | SvREFCNT_dec(*svp); |
1728 | *svp = &sv_undef; | |
760ac839 | 1729 | PerlIO_close(ptr); |
7c0587c8 LW |
1730 | #ifdef UTS |
1731 | if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ | |
1732 | #endif | |
a687059c LW |
1733 | hstat = signal(SIGHUP, SIG_IGN); |
1734 | istat = signal(SIGINT, SIG_IGN); | |
1735 | qstat = signal(SIGQUIT, SIG_IGN); | |
748a9306 LW |
1736 | do { |
1737 | pid = wait4pid(pid, &status, 0); | |
1738 | } while (pid == -1 && errno == EINTR); | |
20188a90 LW |
1739 | signal(SIGHUP, hstat); |
1740 | signal(SIGINT, istat); | |
1741 | signal(SIGQUIT, qstat); | |
1742 | return(pid < 0 ? pid : status); | |
1743 | } | |
4633a7c4 LW |
1744 | #endif /* !DOSISH */ |
1745 | ||
1746 | #if !defined(DOSISH) || defined(OS2) | |
79072805 | 1747 | I32 |
20188a90 LW |
1748 | wait4pid(pid,statusp,flags) |
1749 | int pid; | |
1750 | int *statusp; | |
1751 | int flags; | |
1752 | { | |
79072805 LW |
1753 | SV *sv; |
1754 | SV** svp; | |
20188a90 LW |
1755 | char spid[16]; |
1756 | ||
1757 | if (!pid) | |
1758 | return -1; | |
20188a90 LW |
1759 | if (pid > 0) { |
1760 | sprintf(spid, "%d", pid); | |
79072805 LW |
1761 | svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE); |
1762 | if (svp && *svp != &sv_undef) { | |
463ee0b2 | 1763 | *statusp = SvIVX(*svp); |
748a9306 | 1764 | (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); |
20188a90 LW |
1765 | return pid; |
1766 | } | |
1767 | } | |
1768 | else { | |
79072805 | 1769 | HE *entry; |
20188a90 | 1770 | |
79072805 LW |
1771 | hv_iterinit(pidstatus); |
1772 | if (entry = hv_iternext(pidstatus)) { | |
a0d0e21e | 1773 | pid = atoi(hv_iterkey(entry,(I32*)statusp)); |
79072805 | 1774 | sv = hv_iterval(pidstatus,entry); |
463ee0b2 | 1775 | *statusp = SvIVX(sv); |
20188a90 | 1776 | sprintf(spid, "%d", pid); |
748a9306 | 1777 | (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); |
20188a90 LW |
1778 | return pid; |
1779 | } | |
1780 | } | |
79072805 LW |
1781 | #ifdef HAS_WAITPID |
1782 | return waitpid(pid,statusp,flags); | |
1783 | #else | |
a0d0e21e LW |
1784 | #ifdef HAS_WAIT4 |
1785 | return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); | |
1786 | #else | |
1787 | { | |
1788 | I32 result; | |
1789 | if (flags) | |
1790 | croak("Can't do waitpid with flags"); | |
1791 | else { | |
1792 | while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) | |
1793 | pidgone(result,*statusp); | |
1794 | if (result < 0) | |
1795 | *statusp = -1; | |
1796 | } | |
1797 | return result; | |
a687059c LW |
1798 | } |
1799 | #endif | |
20188a90 | 1800 | #endif |
a687059c | 1801 | } |
7c0587c8 | 1802 | #endif /* !DOSISH */ |
a687059c | 1803 | |
7c0587c8 | 1804 | void |
de3bb511 | 1805 | /*SUPPRESS 590*/ |
a687059c LW |
1806 | pidgone(pid,status) |
1807 | int pid; | |
1808 | int status; | |
1809 | { | |
79072805 | 1810 | register SV *sv; |
20188a90 | 1811 | char spid[16]; |
a687059c | 1812 | |
20188a90 | 1813 | sprintf(spid, "%d", pid); |
79072805 | 1814 | sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); |
a0d0e21e | 1815 | (void)SvUPGRADE(sv,SVt_IV); |
463ee0b2 | 1816 | SvIVX(sv) = status; |
20188a90 | 1817 | return; |
a687059c LW |
1818 | } |
1819 | ||
1050c9ca | 1820 | #if defined(atarist) || (defined(OS2) && !defined(HAS_FORK)) |
7c0587c8 | 1821 | int pclose(); |
79072805 LW |
1822 | I32 |
1823 | my_pclose(ptr) | |
760ac839 | 1824 | PerlIO *ptr; |
a687059c | 1825 | { |
760ac839 LW |
1826 | /* Needs work for PerlIO ! */ |
1827 | FILE *f = PerlIO_findFILE(ptr); | |
1828 | I32 result = pclose(f); | |
1829 | PerlIO_releaseFILE(ptr,f); | |
1830 | return result; | |
a687059c | 1831 | } |
7c0587c8 | 1832 | #endif |
9f68db38 LW |
1833 | |
1834 | void | |
1835 | repeatcpy(to,from,len,count) | |
1836 | register char *to; | |
1837 | register char *from; | |
79072805 LW |
1838 | I32 len; |
1839 | register I32 count; | |
9f68db38 | 1840 | { |
79072805 | 1841 | register I32 todo; |
9f68db38 LW |
1842 | register char *frombase = from; |
1843 | ||
1844 | if (len == 1) { | |
1845 | todo = *from; | |
1846 | while (count-- > 0) | |
1847 | *to++ = todo; | |
1848 | return; | |
1849 | } | |
1850 | while (count-- > 0) { | |
1851 | for (todo = len; todo > 0; todo--) { | |
1852 | *to++ = *from++; | |
1853 | } | |
1854 | from = frombase; | |
1855 | } | |
1856 | } | |
0f85fab0 LW |
1857 | |
1858 | #ifndef CASTNEGFLOAT | |
463ee0b2 | 1859 | U32 |
79072805 | 1860 | cast_ulong(f) |
0f85fab0 LW |
1861 | double f; |
1862 | { | |
1863 | long along; | |
1864 | ||
27e2fb84 | 1865 | #if CASTFLAGS & 2 |
34de22dd LW |
1866 | # define BIGDOUBLE 2147483648.0 |
1867 | if (f >= BIGDOUBLE) | |
1868 | return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; | |
1869 | #endif | |
0f85fab0 LW |
1870 | if (f >= 0.0) |
1871 | return (unsigned long)f; | |
1872 | along = (long)f; | |
1873 | return (unsigned long)along; | |
1874 | } | |
ed6116ce LW |
1875 | # undef BIGDOUBLE |
1876 | #endif | |
1877 | ||
1878 | #ifndef CASTI32 | |
5d94fbed | 1879 | |
5d94fbed AD |
1880 | /* Unfortunately, on some systems the cast_uv() function doesn't |
1881 | work with the system-supplied definition of ULONG_MAX. The | |
1882 | comparison (f >= ULONG_MAX) always comes out true. It must be a | |
1883 | problem with the compiler constant folding. | |
1884 | ||
1885 | In any case, this workaround should be fine on any two's complement | |
1886 | system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your | |
1887 | ccflags. | |
1888 | --Andy Dougherty <doughera@lafcol.lafayette.edu> | |
1889 | */ | |
1eb770ff | 1890 | |
1891 | /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead | |
1892 | of LONG_(MIN/MAX). | |
1893 | -- Kenneth Albanowski <kjahds@kjahds.com> | |
1894 | */ | |
1895 | ||
20cec16a | 1896 | #ifndef MY_UV_MAX |
1897 | # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) | |
5d94fbed AD |
1898 | #endif |
1899 | ||
ed6116ce LW |
1900 | I32 |
1901 | cast_i32(f) | |
1902 | double f; | |
1903 | { | |
20cec16a | 1904 | if (f >= I32_MAX) |
1905 | return (I32) I32_MAX; | |
1906 | if (f <= I32_MIN) | |
1907 | return (I32) I32_MIN; | |
ed6116ce LW |
1908 | return (I32) f; |
1909 | } | |
a0d0e21e LW |
1910 | |
1911 | IV | |
1912 | cast_iv(f) | |
1913 | double f; | |
1914 | { | |
20cec16a | 1915 | if (f >= IV_MAX) |
1916 | return (IV) IV_MAX; | |
1917 | if (f <= IV_MIN) | |
1918 | return (IV) IV_MIN; | |
a0d0e21e LW |
1919 | return (IV) f; |
1920 | } | |
5d94fbed AD |
1921 | |
1922 | UV | |
1923 | cast_uv(f) | |
1924 | double f; | |
1925 | { | |
20cec16a | 1926 | if (f >= MY_UV_MAX) |
1927 | return (UV) MY_UV_MAX; | |
5d94fbed AD |
1928 | return (UV) f; |
1929 | } | |
1930 | ||
0f85fab0 | 1931 | #endif |
62b28dd9 | 1932 | |
fe14fcc3 | 1933 | #ifndef HAS_RENAME |
79072805 | 1934 | I32 |
62b28dd9 LW |
1935 | same_dirent(a,b) |
1936 | char *a; | |
1937 | char *b; | |
1938 | { | |
93a17b20 LW |
1939 | char *fa = strrchr(a,'/'); |
1940 | char *fb = strrchr(b,'/'); | |
62b28dd9 LW |
1941 | struct stat tmpstatbuf1; |
1942 | struct stat tmpstatbuf2; | |
1943 | #ifndef MAXPATHLEN | |
1944 | #define MAXPATHLEN 1024 | |
1945 | #endif | |
1946 | char tmpbuf[MAXPATHLEN+1]; | |
1947 | ||
1948 | if (fa) | |
1949 | fa++; | |
1950 | else | |
1951 | fa = a; | |
1952 | if (fb) | |
1953 | fb++; | |
1954 | else | |
1955 | fb = b; | |
1956 | if (strNE(a,b)) | |
1957 | return FALSE; | |
1958 | if (fa == a) | |
6eb13c3b | 1959 | strcpy(tmpbuf,"."); |
62b28dd9 LW |
1960 | else |
1961 | strncpy(tmpbuf, a, fa - a); | |
a0d0e21e | 1962 | if (Stat(tmpbuf, &tmpstatbuf1) < 0) |
62b28dd9 LW |
1963 | return FALSE; |
1964 | if (fb == b) | |
6eb13c3b | 1965 | strcpy(tmpbuf,"."); |
62b28dd9 LW |
1966 | else |
1967 | strncpy(tmpbuf, b, fb - b); | |
a0d0e21e | 1968 | if (Stat(tmpbuf, &tmpstatbuf2) < 0) |
62b28dd9 LW |
1969 | return FALSE; |
1970 | return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && | |
1971 | tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; | |
1972 | } | |
fe14fcc3 LW |
1973 | #endif /* !HAS_RENAME */ |
1974 | ||
1975 | unsigned long | |
79072805 | 1976 | scan_oct(start, len, retlen) |
fe14fcc3 | 1977 | char *start; |
79072805 LW |
1978 | I32 len; |
1979 | I32 *retlen; | |
fe14fcc3 LW |
1980 | { |
1981 | register char *s = start; | |
1982 | register unsigned long retval = 0; | |
1983 | ||
748a9306 | 1984 | while (len && *s >= '0' && *s <= '7') { |
fe14fcc3 LW |
1985 | retval <<= 3; |
1986 | retval |= *s++ - '0'; | |
748a9306 | 1987 | len--; |
fe14fcc3 | 1988 | } |
748a9306 LW |
1989 | if (dowarn && len && (*s == '8' || *s == '9')) |
1990 | warn("Illegal octal digit ignored"); | |
fe14fcc3 LW |
1991 | *retlen = s - start; |
1992 | return retval; | |
1993 | } | |
1994 | ||
1995 | unsigned long | |
79072805 | 1996 | scan_hex(start, len, retlen) |
fe14fcc3 | 1997 | char *start; |
79072805 LW |
1998 | I32 len; |
1999 | I32 *retlen; | |
fe14fcc3 LW |
2000 | { |
2001 | register char *s = start; | |
2002 | register unsigned long retval = 0; | |
2003 | char *tmp; | |
2004 | ||
93a17b20 | 2005 | while (len-- && *s && (tmp = strchr(hexdigit, *s))) { |
fe14fcc3 LW |
2006 | retval <<= 4; |
2007 | retval |= (tmp - hexdigit) & 15; | |
2008 | s++; | |
2009 | } | |
2010 | *retlen = s - start; | |
2011 | return retval; | |
2012 | } | |
760ac839 LW |
2013 | |
2014 | ||
2015 | #ifdef HUGE_VAL | |
2016 | /* | |
2017 | * This hack is to force load of "huge" support from libm.a | |
2018 | * So it is in perl for (say) POSIX to use. | |
2019 | * Needed for SunOS with Sun's 'acc' for example. | |
2020 | */ | |
2021 | double | |
2022 | Perl_huge() | |
2023 | { | |
2024 | return HUGE_VAL; | |
2025 | } | |
2026 | #endif |