1 | /* util.c |
---|
2 | * |
---|
3 | * Copyright (c) 1991-1997, Larry Wall |
---|
4 | * |
---|
5 | * You may distribute under the terms of either the GNU General Public |
---|
6 | * License or the Artistic License, as specified in the README file. |
---|
7 | * |
---|
8 | */ |
---|
9 | |
---|
10 | /* |
---|
11 | * "Very useful, no doubt, that was to Saruman; yet it seems that he was |
---|
12 | * not content." --Gandalf |
---|
13 | */ |
---|
14 | |
---|
15 | #include "EXTERN.h" |
---|
16 | #include "perl.h" |
---|
17 | |
---|
18 | #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) |
---|
19 | #include <signal.h> |
---|
20 | #endif |
---|
21 | |
---|
22 | #ifndef SIG_ERR |
---|
23 | # define SIG_ERR ((Sighandler_t) -1) |
---|
24 | #endif |
---|
25 | |
---|
26 | /* XXX If this causes problems, set i_unistd=undef in the hint file. */ |
---|
27 | #ifdef I_UNISTD |
---|
28 | # include <unistd.h> |
---|
29 | #endif |
---|
30 | |
---|
31 | #ifdef I_VFORK |
---|
32 | # include <vfork.h> |
---|
33 | #endif |
---|
34 | |
---|
35 | /* Put this after #includes because fork and vfork prototypes may |
---|
36 | conflict. |
---|
37 | */ |
---|
38 | #ifndef HAS_VFORK |
---|
39 | # define vfork fork |
---|
40 | #endif |
---|
41 | |
---|
42 | #ifdef I_FCNTL |
---|
43 | # include <fcntl.h> |
---|
44 | #endif |
---|
45 | #ifdef I_SYS_FILE |
---|
46 | # include <sys/file.h> |
---|
47 | #endif |
---|
48 | |
---|
49 | #ifdef I_SYS_WAIT |
---|
50 | # include <sys/wait.h> |
---|
51 | #endif |
---|
52 | |
---|
53 | #define FLUSH |
---|
54 | |
---|
55 | #ifdef LEAKTEST |
---|
56 | static void xstat _((void)); |
---|
57 | #endif |
---|
58 | |
---|
59 | #ifndef MYMALLOC |
---|
60 | |
---|
61 | /* paranoid version of malloc */ |
---|
62 | |
---|
63 | /* NOTE: Do not call the next three routines directly. Use the macros |
---|
64 | * in handy.h, so that we can easily redefine everything to do tracking of |
---|
65 | * allocated hunks back to the original New to track down any memory leaks. |
---|
66 | * XXX This advice seems to be widely ignored :-( --AD August 1996. |
---|
67 | */ |
---|
68 | |
---|
69 | Malloc_t |
---|
70 | safemalloc(size) |
---|
71 | MEM_SIZE size; |
---|
72 | { |
---|
73 | Malloc_t ptr; |
---|
74 | #ifdef HAS_64K_LIMIT |
---|
75 | if (size > 0xffff) { |
---|
76 | PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; |
---|
77 | my_exit(1); |
---|
78 | } |
---|
79 | #endif /* HAS_64K_LIMIT */ |
---|
80 | #ifdef DEBUGGING |
---|
81 | if ((long)size < 0) |
---|
82 | croak("panic: malloc"); |
---|
83 | #endif |
---|
84 | ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ |
---|
85 | #if !(defined(I286) || defined(atarist)) |
---|
86 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); |
---|
87 | #else |
---|
88 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); |
---|
89 | #endif |
---|
90 | if (ptr != Nullch) |
---|
91 | return ptr; |
---|
92 | else if (nomemok) |
---|
93 | return Nullch; |
---|
94 | else { |
---|
95 | PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; |
---|
96 | my_exit(1); |
---|
97 | } |
---|
98 | /*NOTREACHED*/ |
---|
99 | } |
---|
100 | |
---|
101 | /* paranoid version of realloc */ |
---|
102 | |
---|
103 | Malloc_t |
---|
104 | saferealloc(where,size) |
---|
105 | Malloc_t where; |
---|
106 | MEM_SIZE size; |
---|
107 | { |
---|
108 | Malloc_t ptr; |
---|
109 | #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) |
---|
110 | Malloc_t realloc(); |
---|
111 | #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ |
---|
112 | |
---|
113 | #ifdef HAS_64K_LIMIT |
---|
114 | if (size > 0xffff) { |
---|
115 | PerlIO_printf(PerlIO_stderr(), |
---|
116 | "Reallocation too large: %lx\n", size) FLUSH; |
---|
117 | my_exit(1); |
---|
118 | } |
---|
119 | #endif /* HAS_64K_LIMIT */ |
---|
120 | if (!where) |
---|
121 | croak("Null realloc"); |
---|
122 | #ifdef DEBUGGING |
---|
123 | if ((long)size < 0) |
---|
124 | croak("panic: realloc"); |
---|
125 | #endif |
---|
126 | ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ |
---|
127 | |
---|
128 | #if !(defined(I286) || defined(atarist)) |
---|
129 | DEBUG_m( { |
---|
130 | PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); |
---|
131 | PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); |
---|
132 | } ) |
---|
133 | #else |
---|
134 | DEBUG_m( { |
---|
135 | PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); |
---|
136 | PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); |
---|
137 | } ) |
---|
138 | #endif |
---|
139 | |
---|
140 | if (ptr != Nullch) |
---|
141 | return ptr; |
---|
142 | else if (nomemok) |
---|
143 | return Nullch; |
---|
144 | else { |
---|
145 | PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; |
---|
146 | my_exit(1); |
---|
147 | } |
---|
148 | /*NOTREACHED*/ |
---|
149 | } |
---|
150 | |
---|
151 | /* safe version of free */ |
---|
152 | |
---|
153 | Free_t |
---|
154 | safefree(where) |
---|
155 | Malloc_t where; |
---|
156 | { |
---|
157 | #if !(defined(I286) || defined(atarist)) |
---|
158 | DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++)); |
---|
159 | #else |
---|
160 | DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++)); |
---|
161 | #endif |
---|
162 | if (where) { |
---|
163 | /*SUPPRESS 701*/ |
---|
164 | free(where); |
---|
165 | } |
---|
166 | } |
---|
167 | |
---|
168 | /* safe version of calloc */ |
---|
169 | |
---|
170 | Malloc_t |
---|
171 | safecalloc(count, size) |
---|
172 | MEM_SIZE count; |
---|
173 | MEM_SIZE size; |
---|
174 | { |
---|
175 | Malloc_t ptr; |
---|
176 | |
---|
177 | #ifdef HAS_64K_LIMIT |
---|
178 | if (size * count > 0xffff) { |
---|
179 | PerlIO_printf(PerlIO_stderr(), |
---|
180 | "Allocation too large: %lx\n", size * count) FLUSH; |
---|
181 | my_exit(1); |
---|
182 | } |
---|
183 | #endif /* HAS_64K_LIMIT */ |
---|
184 | #ifdef DEBUGGING |
---|
185 | if ((long)size < 0 || (long)count < 0) |
---|
186 | croak("panic: calloc"); |
---|
187 | #endif |
---|
188 | size *= count; |
---|
189 | ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ |
---|
190 | #if !(defined(I286) || defined(atarist)) |
---|
191 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); |
---|
192 | #else |
---|
193 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); |
---|
194 | #endif |
---|
195 | if (ptr != Nullch) { |
---|
196 | memset((void*)ptr, 0, size); |
---|
197 | return ptr; |
---|
198 | } |
---|
199 | else if (nomemok) |
---|
200 | return Nullch; |
---|
201 | else { |
---|
202 | PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; |
---|
203 | my_exit(1); |
---|
204 | } |
---|
205 | /*NOTREACHED*/ |
---|
206 | } |
---|
207 | |
---|
208 | #endif /* !MYMALLOC */ |
---|
209 | |
---|
210 | #ifdef LEAKTEST |
---|
211 | |
---|
212 | #define ALIGN sizeof(long) |
---|
213 | |
---|
214 | Malloc_t |
---|
215 | safexmalloc(x,size) |
---|
216 | I32 x; |
---|
217 | MEM_SIZE size; |
---|
218 | { |
---|
219 | register Malloc_t where; |
---|
220 | |
---|
221 | where = safemalloc(size + ALIGN); |
---|
222 | xcount[x]++; |
---|
223 | where[0] = x % 100; |
---|
224 | where[1] = x / 100; |
---|
225 | return where + ALIGN; |
---|
226 | } |
---|
227 | |
---|
228 | Malloc_t |
---|
229 | safexrealloc(where,size) |
---|
230 | Malloc_t where; |
---|
231 | MEM_SIZE size; |
---|
232 | { |
---|
233 | register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN); |
---|
234 | return new + ALIGN; |
---|
235 | } |
---|
236 | |
---|
237 | void |
---|
238 | safexfree(where) |
---|
239 | Malloc_t where; |
---|
240 | { |
---|
241 | I32 x; |
---|
242 | |
---|
243 | if (!where) |
---|
244 | return; |
---|
245 | where -= ALIGN; |
---|
246 | x = where[0] + 100 * where[1]; |
---|
247 | xcount[x]--; |
---|
248 | safefree(where); |
---|
249 | } |
---|
250 | |
---|
251 | Malloc_t |
---|
252 | safexcalloc(x,count,size) |
---|
253 | I32 x; |
---|
254 | MEM_SIZE count; |
---|
255 | MEM_SIZE size; |
---|
256 | { |
---|
257 | register Malloc_t where; |
---|
258 | |
---|
259 | where = safexmalloc(x, size * count + ALIGN); |
---|
260 | xcount[x]++; |
---|
261 | memset((void*)where + ALIGN, 0, size * count); |
---|
262 | where[0] = x % 100; |
---|
263 | where[1] = x / 100; |
---|
264 | return where + ALIGN; |
---|
265 | } |
---|
266 | |
---|
267 | static void |
---|
268 | xstat() |
---|
269 | { |
---|
270 | register I32 i; |
---|
271 | |
---|
272 | for (i = 0; i < MAXXCOUNT; i++) { |
---|
273 | if (xcount[i] > lastxcount[i]) { |
---|
274 | PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); |
---|
275 | lastxcount[i] = xcount[i]; |
---|
276 | } |
---|
277 | } |
---|
278 | } |
---|
279 | |
---|
280 | #endif /* LEAKTEST */ |
---|
281 | |
---|
282 | /* copy a string up to some (non-backslashed) delimiter, if any */ |
---|
283 | |
---|
284 | char * |
---|
285 | delimcpy(to, toend, from, fromend, delim, retlen) |
---|
286 | register char *to; |
---|
287 | register char *toend; |
---|
288 | register char *from; |
---|
289 | register char *fromend; |
---|
290 | register int delim; |
---|
291 | I32 *retlen; |
---|
292 | { |
---|
293 | register I32 tolen; |
---|
294 | for (tolen = 0; from < fromend; from++, tolen++) { |
---|
295 | if (*from == '\\') { |
---|
296 | if (from[1] == delim) |
---|
297 | from++; |
---|
298 | else { |
---|
299 | if (to < toend) |
---|
300 | *to++ = *from; |
---|
301 | tolen++; |
---|
302 | from++; |
---|
303 | } |
---|
304 | } |
---|
305 | else if (*from == delim) |
---|
306 | break; |
---|
307 | if (to < toend) |
---|
308 | *to++ = *from; |
---|
309 | } |
---|
310 | if (to < toend) |
---|
311 | *to = '\0'; |
---|
312 | *retlen = tolen; |
---|
313 | return from; |
---|
314 | } |
---|
315 | |
---|
316 | /* return ptr to little string in big string, NULL if not found */ |
---|
317 | /* This routine was donated by Corey Satten. */ |
---|
318 | |
---|
319 | char * |
---|
320 | instr(big, little) |
---|
321 | register char *big; |
---|
322 | register char *little; |
---|
323 | { |
---|
324 | register char *s, *x; |
---|
325 | register I32 first; |
---|
326 | |
---|
327 | if (!little) |
---|
328 | return big; |
---|
329 | first = *little++; |
---|
330 | if (!first) |
---|
331 | return big; |
---|
332 | while (*big) { |
---|
333 | if (*big++ != first) |
---|
334 | continue; |
---|
335 | for (x=big,s=little; *s; /**/ ) { |
---|
336 | if (!*x) |
---|
337 | return Nullch; |
---|
338 | if (*s++ != *x++) { |
---|
339 | s--; |
---|
340 | break; |
---|
341 | } |
---|
342 | } |
---|
343 | if (!*s) |
---|
344 | return big-1; |
---|
345 | } |
---|
346 | return Nullch; |
---|
347 | } |
---|
348 | |
---|
349 | /* same as instr but allow embedded nulls */ |
---|
350 | |
---|
351 | char * |
---|
352 | ninstr(big, bigend, little, lend) |
---|
353 | register char *big; |
---|
354 | register char *bigend; |
---|
355 | char *little; |
---|
356 | char *lend; |
---|
357 | { |
---|
358 | register char *s, *x; |
---|
359 | register I32 first = *little; |
---|
360 | register char *littleend = lend; |
---|
361 | |
---|
362 | if (!first && little >= littleend) |
---|
363 | return big; |
---|
364 | if (bigend - big < littleend - little) |
---|
365 | return Nullch; |
---|
366 | bigend -= littleend - little++; |
---|
367 | while (big <= bigend) { |
---|
368 | if (*big++ != first) |
---|
369 | continue; |
---|
370 | for (x=big,s=little; s < littleend; /**/ ) { |
---|
371 | if (*s++ != *x++) { |
---|
372 | s--; |
---|
373 | break; |
---|
374 | } |
---|
375 | } |
---|
376 | if (s >= littleend) |
---|
377 | return big-1; |
---|
378 | } |
---|
379 | return Nullch; |
---|
380 | } |
---|
381 | |
---|
382 | /* reverse of the above--find last substring */ |
---|
383 | |
---|
384 | char * |
---|
385 | rninstr(big, bigend, little, lend) |
---|
386 | register char *big; |
---|
387 | char *bigend; |
---|
388 | char *little; |
---|
389 | char *lend; |
---|
390 | { |
---|
391 | register char *bigbeg; |
---|
392 | register char *s, *x; |
---|
393 | register I32 first = *little; |
---|
394 | register char *littleend = lend; |
---|
395 | |
---|
396 | if (!first && little >= littleend) |
---|
397 | return bigend; |
---|
398 | bigbeg = big; |
---|
399 | big = bigend - (littleend - little++); |
---|
400 | while (big >= bigbeg) { |
---|
401 | if (*big-- != first) |
---|
402 | continue; |
---|
403 | for (x=big+2,s=little; s < littleend; /**/ ) { |
---|
404 | if (*s++ != *x++) { |
---|
405 | s--; |
---|
406 | break; |
---|
407 | } |
---|
408 | } |
---|
409 | if (s >= littleend) |
---|
410 | return big+1; |
---|
411 | } |
---|
412 | return Nullch; |
---|
413 | } |
---|
414 | |
---|
415 | /* |
---|
416 | * Set up for a new ctype locale. |
---|
417 | */ |
---|
418 | void |
---|
419 | perl_new_ctype(newctype) |
---|
420 | char *newctype; |
---|
421 | { |
---|
422 | #ifdef USE_LOCALE_CTYPE |
---|
423 | |
---|
424 | int i; |
---|
425 | |
---|
426 | for (i = 0; i < 256; i++) { |
---|
427 | if (isUPPER_LC(i)) |
---|
428 | fold_locale[i] = toLOWER_LC(i); |
---|
429 | else if (isLOWER_LC(i)) |
---|
430 | fold_locale[i] = toUPPER_LC(i); |
---|
431 | else |
---|
432 | fold_locale[i] = i; |
---|
433 | } |
---|
434 | |
---|
435 | #endif /* USE_LOCALE_CTYPE */ |
---|
436 | } |
---|
437 | |
---|
438 | /* |
---|
439 | * Set up for a new collation locale. |
---|
440 | */ |
---|
441 | void |
---|
442 | perl_new_collate(newcoll) |
---|
443 | char *newcoll; |
---|
444 | { |
---|
445 | #ifdef USE_LOCALE_COLLATE |
---|
446 | |
---|
447 | if (! newcoll) { |
---|
448 | if (collation_name) { |
---|
449 | ++collation_ix; |
---|
450 | Safefree(collation_name); |
---|
451 | collation_name = NULL; |
---|
452 | collation_standard = TRUE; |
---|
453 | collxfrm_base = 0; |
---|
454 | collxfrm_mult = 2; |
---|
455 | } |
---|
456 | return; |
---|
457 | } |
---|
458 | |
---|
459 | if (! collation_name || strNE(collation_name, newcoll)) { |
---|
460 | ++collation_ix; |
---|
461 | Safefree(collation_name); |
---|
462 | collation_name = savepv(newcoll); |
---|
463 | collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); |
---|
464 | |
---|
465 | { |
---|
466 | /* 2: at most so many chars ('a', 'b'). */ |
---|
467 | /* 50: surely no system expands a char more. */ |
---|
468 | #define XFRMBUFSIZE (2 * 50) |
---|
469 | char xbuf[XFRMBUFSIZE]; |
---|
470 | Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); |
---|
471 | Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); |
---|
472 | SSize_t mult = fb - fa; |
---|
473 | if (mult < 1) |
---|
474 | croak("strxfrm() gets absurd"); |
---|
475 | collxfrm_base = (fa > mult) ? (fa - mult) : 0; |
---|
476 | collxfrm_mult = mult; |
---|
477 | } |
---|
478 | } |
---|
479 | |
---|
480 | #endif /* USE_LOCALE_COLLATE */ |
---|
481 | } |
---|
482 | |
---|
483 | /* |
---|
484 | * Set up for a new numeric locale. |
---|
485 | */ |
---|
486 | void |
---|
487 | perl_new_numeric(newnum) |
---|
488 | char *newnum; |
---|
489 | { |
---|
490 | #ifdef USE_LOCALE_NUMERIC |
---|
491 | |
---|
492 | if (! newnum) { |
---|
493 | if (numeric_name) { |
---|
494 | Safefree(numeric_name); |
---|
495 | numeric_name = NULL; |
---|
496 | numeric_standard = TRUE; |
---|
497 | numeric_local = TRUE; |
---|
498 | } |
---|
499 | return; |
---|
500 | } |
---|
501 | |
---|
502 | if (! numeric_name || strNE(numeric_name, newnum)) { |
---|
503 | Safefree(numeric_name); |
---|
504 | numeric_name = savepv(newnum); |
---|
505 | numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); |
---|
506 | numeric_local = TRUE; |
---|
507 | } |
---|
508 | |
---|
509 | #endif /* USE_LOCALE_NUMERIC */ |
---|
510 | } |
---|
511 | |
---|
512 | void |
---|
513 | perl_set_numeric_standard() |
---|
514 | { |
---|
515 | #ifdef USE_LOCALE_NUMERIC |
---|
516 | |
---|
517 | if (! numeric_standard) { |
---|
518 | setlocale(LC_NUMERIC, "C"); |
---|
519 | numeric_standard = TRUE; |
---|
520 | numeric_local = FALSE; |
---|
521 | } |
---|
522 | |
---|
523 | #endif /* USE_LOCALE_NUMERIC */ |
---|
524 | } |
---|
525 | |
---|
526 | void |
---|
527 | perl_set_numeric_local() |
---|
528 | { |
---|
529 | #ifdef USE_LOCALE_NUMERIC |
---|
530 | |
---|
531 | if (! numeric_local) { |
---|
532 | setlocale(LC_NUMERIC, numeric_name); |
---|
533 | numeric_standard = FALSE; |
---|
534 | numeric_local = TRUE; |
---|
535 | } |
---|
536 | |
---|
537 | #endif /* USE_LOCALE_NUMERIC */ |
---|
538 | } |
---|
539 | |
---|
540 | |
---|
541 | /* |
---|
542 | * Initialize locale awareness. |
---|
543 | */ |
---|
544 | int |
---|
545 | perl_init_i18nl10n(printwarn) |
---|
546 | int printwarn; |
---|
547 | { |
---|
548 | int ok = 1; |
---|
549 | /* returns |
---|
550 | * 1 = set ok or not applicable, |
---|
551 | * 0 = fallback to C locale, |
---|
552 | * -1 = fallback to C locale failed |
---|
553 | */ |
---|
554 | |
---|
555 | #ifdef USE_LOCALE |
---|
556 | |
---|
557 | #ifdef USE_LOCALE_CTYPE |
---|
558 | char *curctype = NULL; |
---|
559 | #endif /* USE_LOCALE_CTYPE */ |
---|
560 | #ifdef USE_LOCALE_COLLATE |
---|
561 | char *curcoll = NULL; |
---|
562 | #endif /* USE_LOCALE_COLLATE */ |
---|
563 | #ifdef USE_LOCALE_NUMERIC |
---|
564 | char *curnum = NULL; |
---|
565 | #endif /* USE_LOCALE_NUMERIC */ |
---|
566 | char *lc_all = getenv("LC_ALL"); |
---|
567 | char *lang = getenv("LANG"); |
---|
568 | bool setlocale_failure = FALSE; |
---|
569 | |
---|
570 | #ifdef LOCALE_ENVIRON_REQUIRED |
---|
571 | |
---|
572 | /* |
---|
573 | * Ultrix setlocale(..., "") fails if there are no environment |
---|
574 | * variables from which to get a locale name. |
---|
575 | */ |
---|
576 | |
---|
577 | bool done = FALSE; |
---|
578 | |
---|
579 | #ifdef LC_ALL |
---|
580 | if (lang) { |
---|
581 | if (setlocale(LC_ALL, "")) |
---|
582 | done = TRUE; |
---|
583 | else |
---|
584 | setlocale_failure = TRUE; |
---|
585 | } |
---|
586 | if (!setlocale_failure) |
---|
587 | #endif /* LC_ALL */ |
---|
588 | { |
---|
589 | #ifdef USE_LOCALE_CTYPE |
---|
590 | if (! (curctype = setlocale(LC_CTYPE, |
---|
591 | (!done && (lang || getenv("LC_CTYPE"))) |
---|
592 | ? "" : Nullch))) |
---|
593 | setlocale_failure = TRUE; |
---|
594 | #endif /* USE_LOCALE_CTYPE */ |
---|
595 | #ifdef USE_LOCALE_COLLATE |
---|
596 | if (! (curcoll = setlocale(LC_COLLATE, |
---|
597 | (!done && (lang || getenv("LC_COLLATE"))) |
---|
598 | ? "" : Nullch))) |
---|
599 | setlocale_failure = TRUE; |
---|
600 | #endif /* USE_LOCALE_COLLATE */ |
---|
601 | #ifdef USE_LOCALE_NUMERIC |
---|
602 | if (! (curnum = setlocale(LC_NUMERIC, |
---|
603 | (!done && (lang || getenv("LC_NUMERIC"))) |
---|
604 | ? "" : Nullch))) |
---|
605 | setlocale_failure = TRUE; |
---|
606 | #endif /* USE_LOCALE_NUMERIC */ |
---|
607 | } |
---|
608 | |
---|
609 | #else /* !LOCALE_ENVIRON_REQUIRED */ |
---|
610 | |
---|
611 | #ifdef LC_ALL |
---|
612 | |
---|
613 | if (! setlocale(LC_ALL, "")) |
---|
614 | setlocale_failure = TRUE; |
---|
615 | else { |
---|
616 | #ifdef USE_LOCALE_CTYPE |
---|
617 | curctype = setlocale(LC_CTYPE, Nullch); |
---|
618 | #endif /* USE_LOCALE_CTYPE */ |
---|
619 | #ifdef USE_LOCALE_COLLATE |
---|
620 | curcoll = setlocale(LC_COLLATE, Nullch); |
---|
621 | #endif /* USE_LOCALE_COLLATE */ |
---|
622 | #ifdef USE_LOCALE_NUMERIC |
---|
623 | curnum = setlocale(LC_NUMERIC, Nullch); |
---|
624 | #endif /* USE_LOCALE_NUMERIC */ |
---|
625 | } |
---|
626 | |
---|
627 | #else /* !LC_ALL */ |
---|
628 | |
---|
629 | #ifdef USE_LOCALE_CTYPE |
---|
630 | if (! (curctype = setlocale(LC_CTYPE, ""))) |
---|
631 | setlocale_failure = TRUE; |
---|
632 | #endif /* USE_LOCALE_CTYPE */ |
---|
633 | #ifdef USE_LOCALE_COLLATE |
---|
634 | if (! (curcoll = setlocale(LC_COLLATE, ""))) |
---|
635 | setlocale_failure = TRUE; |
---|
636 | #endif /* USE_LOCALE_COLLATE */ |
---|
637 | #ifdef USE_LOCALE_NUMERIC |
---|
638 | if (! (curnum = setlocale(LC_NUMERIC, ""))) |
---|
639 | setlocale_failure = TRUE; |
---|
640 | #endif /* USE_LOCALE_NUMERIC */ |
---|
641 | |
---|
642 | #endif /* LC_ALL */ |
---|
643 | |
---|
644 | #endif /* !LOCALE_ENVIRON_REQUIRED */ |
---|
645 | |
---|
646 | if (setlocale_failure) { |
---|
647 | char *p; |
---|
648 | bool locwarn = (printwarn > 1 || |
---|
649 | printwarn && |
---|
650 | (!(p = getenv("PERL_BADLANG")) || atoi(p))); |
---|
651 | |
---|
652 | if (locwarn) { |
---|
653 | #ifdef LC_ALL |
---|
654 | |
---|
655 | PerlIO_printf(PerlIO_stderr(), |
---|
656 | "perl: warning: Setting locale failed.\n"); |
---|
657 | |
---|
658 | #else /* !LC_ALL */ |
---|
659 | |
---|
660 | PerlIO_printf(PerlIO_stderr(), |
---|
661 | "perl: warning: Setting locale failed for the categories:\n\t"); |
---|
662 | #ifdef USE_LOCALE_CTYPE |
---|
663 | if (! curctype) |
---|
664 | PerlIO_printf(PerlIO_stderr(), "LC_CTYPE "); |
---|
665 | #endif /* USE_LOCALE_CTYPE */ |
---|
666 | #ifdef USE_LOCALE_COLLATE |
---|
667 | if (! curcoll) |
---|
668 | PerlIO_printf(PerlIO_stderr(), "LC_COLLATE "); |
---|
669 | #endif /* USE_LOCALE_COLLATE */ |
---|
670 | #ifdef USE_LOCALE_NUMERIC |
---|
671 | if (! curnum) |
---|
672 | PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC "); |
---|
673 | #endif /* USE_LOCALE_NUMERIC */ |
---|
674 | PerlIO_printf(PerlIO_stderr(), "\n"); |
---|
675 | |
---|
676 | #endif /* LC_ALL */ |
---|
677 | |
---|
678 | PerlIO_printf(PerlIO_stderr(), |
---|
679 | "perl: warning: Please check that your locale settings:\n"); |
---|
680 | |
---|
681 | PerlIO_printf(PerlIO_stderr(), |
---|
682 | "\tLC_ALL = %c%s%c,\n", |
---|
683 | lc_all ? '"' : '(', |
---|
684 | lc_all ? lc_all : "unset", |
---|
685 | lc_all ? '"' : ')'); |
---|
686 | |
---|
687 | { |
---|
688 | char **e; |
---|
689 | for (e = environ; *e; e++) { |
---|
690 | if (strnEQ(*e, "LC_", 3) |
---|
691 | && strnNE(*e, "LC_ALL=", 7) |
---|
692 | && (p = strchr(*e, '='))) |
---|
693 | PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", |
---|
694 | (int)(p - *e), *e, p + 1); |
---|
695 | } |
---|
696 | } |
---|
697 | |
---|
698 | PerlIO_printf(PerlIO_stderr(), |
---|
699 | "\tLANG = %c%s%c\n", |
---|
700 | lang ? '"' : '(', |
---|
701 | lang ? lang : "unset", |
---|
702 | lang ? '"' : ')'); |
---|
703 | |
---|
704 | PerlIO_printf(PerlIO_stderr(), |
---|
705 | " are supported and installed on your system.\n"); |
---|
706 | } |
---|
707 | |
---|
708 | #ifdef LC_ALL |
---|
709 | |
---|
710 | if (setlocale(LC_ALL, "C")) { |
---|
711 | if (locwarn) |
---|
712 | PerlIO_printf(PerlIO_stderr(), |
---|
713 | "perl: warning: Falling back to the standard locale (\"C\").\n"); |
---|
714 | ok = 0; |
---|
715 | } |
---|
716 | else { |
---|
717 | if (locwarn) |
---|
718 | PerlIO_printf(PerlIO_stderr(), |
---|
719 | "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); |
---|
720 | ok = -1; |
---|
721 | } |
---|
722 | |
---|
723 | #else /* ! LC_ALL */ |
---|
724 | |
---|
725 | if (0 |
---|
726 | #ifdef USE_LOCALE_CTYPE |
---|
727 | || !(curctype || setlocale(LC_CTYPE, "C")) |
---|
728 | #endif /* USE_LOCALE_CTYPE */ |
---|
729 | #ifdef USE_LOCALE_COLLATE |
---|
730 | || !(curcoll || setlocale(LC_COLLATE, "C")) |
---|
731 | #endif /* USE_LOCALE_COLLATE */ |
---|
732 | #ifdef USE_LOCALE_NUMERIC |
---|
733 | || !(curnum || setlocale(LC_NUMERIC, "C")) |
---|
734 | #endif /* USE_LOCALE_NUMERIC */ |
---|
735 | ) |
---|
736 | { |
---|
737 | if (locwarn) |
---|
738 | PerlIO_printf(PerlIO_stderr(), |
---|
739 | "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); |
---|
740 | ok = -1; |
---|
741 | } |
---|
742 | |
---|
743 | #endif /* ! LC_ALL */ |
---|
744 | |
---|
745 | #ifdef USE_LOCALE_CTYPE |
---|
746 | curctype = setlocale(LC_CTYPE, Nullch); |
---|
747 | #endif /* USE_LOCALE_CTYPE */ |
---|
748 | #ifdef USE_LOCALE_COLLATE |
---|
749 | curcoll = setlocale(LC_COLLATE, Nullch); |
---|
750 | #endif /* USE_LOCALE_COLLATE */ |
---|
751 | #ifdef USE_LOCALE_NUMERIC |
---|
752 | curnum = setlocale(LC_NUMERIC, Nullch); |
---|
753 | #endif /* USE_LOCALE_NUMERIC */ |
---|
754 | } |
---|
755 | |
---|
756 | #ifdef USE_LOCALE_CTYPE |
---|
757 | perl_new_ctype(curctype); |
---|
758 | #endif /* USE_LOCALE_CTYPE */ |
---|
759 | |
---|
760 | #ifdef USE_LOCALE_COLLATE |
---|
761 | perl_new_collate(curcoll); |
---|
762 | #endif /* USE_LOCALE_COLLATE */ |
---|
763 | |
---|
764 | #ifdef USE_LOCALE_NUMERIC |
---|
765 | perl_new_numeric(curnum); |
---|
766 | #endif /* USE_LOCALE_NUMERIC */ |
---|
767 | |
---|
768 | #endif /* USE_LOCALE */ |
---|
769 | |
---|
770 | return ok; |
---|
771 | } |
---|
772 | |
---|
773 | /* Backwards compatibility. */ |
---|
774 | int |
---|
775 | perl_init_i18nl14n(printwarn) |
---|
776 | int printwarn; |
---|
777 | { |
---|
778 | return perl_init_i18nl10n(printwarn); |
---|
779 | } |
---|
780 | |
---|
781 | #ifdef USE_LOCALE_COLLATE |
---|
782 | |
---|
783 | /* |
---|
784 | * mem_collxfrm() is a bit like strxfrm() but with two important |
---|
785 | * differences. First, it handles embedded NULs. Second, it allocates |
---|
786 | * a bit more memory than needed for the transformed data itself. |
---|
787 | * The real transformed data begins at offset sizeof(collationix). |
---|
788 | * Please see sv_collxfrm() to see how this is used. |
---|
789 | */ |
---|
790 | char * |
---|
791 | mem_collxfrm(s, len, xlen) |
---|
792 | const char *s; |
---|
793 | STRLEN len; |
---|
794 | STRLEN *xlen; |
---|
795 | { |
---|
796 | char *xbuf; |
---|
797 | STRLEN xalloc, xin, xout; |
---|
798 | |
---|
799 | /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ |
---|
800 | /* the +1 is for the terminating NUL. */ |
---|
801 | |
---|
802 | xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1; |
---|
803 | New(171, xbuf, xalloc, char); |
---|
804 | if (! xbuf) |
---|
805 | goto bad; |
---|
806 | |
---|
807 | *(U32*)xbuf = collation_ix; |
---|
808 | xout = sizeof(collation_ix); |
---|
809 | for (xin = 0; xin < len; ) { |
---|
810 | SSize_t xused; |
---|
811 | |
---|
812 | for (;;) { |
---|
813 | xused = strxfrm(xbuf + xout, s + xin, xalloc - xout); |
---|
814 | if (xused == -1) |
---|
815 | goto bad; |
---|
816 | if (xused < xalloc - xout) |
---|
817 | break; |
---|
818 | xalloc = (2 * xalloc) + 1; |
---|
819 | Renew(xbuf, xalloc, char); |
---|
820 | if (! xbuf) |
---|
821 | goto bad; |
---|
822 | } |
---|
823 | |
---|
824 | xin += strlen(s + xin) + 1; |
---|
825 | xout += xused; |
---|
826 | |
---|
827 | /* Embedded NULs are understood but silently skipped |
---|
828 | * because they make no sense in locale collation. */ |
---|
829 | } |
---|
830 | |
---|
831 | xbuf[xout] = '\0'; |
---|
832 | *xlen = xout - sizeof(collation_ix); |
---|
833 | return xbuf; |
---|
834 | |
---|
835 | bad: |
---|
836 | Safefree(xbuf); |
---|
837 | *xlen = 0; |
---|
838 | return NULL; |
---|
839 | } |
---|
840 | |
---|
841 | #endif /* USE_LOCALE_COLLATE */ |
---|
842 | |
---|
843 | void |
---|
844 | fbm_compile(sv) |
---|
845 | SV *sv; |
---|
846 | { |
---|
847 | register unsigned char *s; |
---|
848 | register unsigned char *table; |
---|
849 | register U32 i; |
---|
850 | register U32 len = SvCUR(sv); |
---|
851 | I32 rarest = 0; |
---|
852 | U32 frequency = 256; |
---|
853 | |
---|
854 | if (len > 255) |
---|
855 | return; /* can't have offsets that big */ |
---|
856 | Sv_Grow(sv,len+258); |
---|
857 | table = (unsigned char*)(SvPVX(sv) + len + 1); |
---|
858 | s = table - 2; |
---|
859 | for (i = 0; i < 256; i++) { |
---|
860 | table[i] = len; |
---|
861 | } |
---|
862 | i = 0; |
---|
863 | while (s >= (unsigned char*)(SvPVX(sv))) |
---|
864 | { |
---|
865 | if (table[*s] == len) |
---|
866 | table[*s] = i; |
---|
867 | s--,i++; |
---|
868 | } |
---|
869 | sv_upgrade(sv, SVt_PVBM); |
---|
870 | sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ |
---|
871 | SvVALID_on(sv); |
---|
872 | |
---|
873 | s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ |
---|
874 | for (i = 0; i < len; i++) { |
---|
875 | if (freq[s[i]] < frequency) { |
---|
876 | rarest = i; |
---|
877 | frequency = freq[s[i]]; |
---|
878 | } |
---|
879 | } |
---|
880 | BmRARE(sv) = s[rarest]; |
---|
881 | BmPREVIOUS(sv) = rarest; |
---|
882 | DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); |
---|
883 | } |
---|
884 | |
---|
885 | char * |
---|
886 | fbm_instr(big, bigend, littlestr) |
---|
887 | unsigned char *big; |
---|
888 | register unsigned char *bigend; |
---|
889 | SV *littlestr; |
---|
890 | { |
---|
891 | register unsigned char *s; |
---|
892 | register I32 tmp; |
---|
893 | register I32 littlelen; |
---|
894 | register unsigned char *little; |
---|
895 | register unsigned char *table; |
---|
896 | register unsigned char *olds; |
---|
897 | register unsigned char *oldlittle; |
---|
898 | |
---|
899 | if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { |
---|
900 | STRLEN len; |
---|
901 | char *l = SvPV(littlestr,len); |
---|
902 | if (!len) |
---|
903 | return (char*)big; |
---|
904 | return ninstr((char*)big,(char*)bigend, l, l + len); |
---|
905 | } |
---|
906 | |
---|
907 | littlelen = SvCUR(littlestr); |
---|
908 | if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ |
---|
909 | if (littlelen > bigend - big) |
---|
910 | return Nullch; |
---|
911 | little = (unsigned char*)SvPVX(littlestr); |
---|
912 | s = bigend - littlelen; |
---|
913 | if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) |
---|
914 | return (char*)s; /* how sweet it is */ |
---|
915 | else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' |
---|
916 | && s > big) { |
---|
917 | s--; |
---|
918 | if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) |
---|
919 | return (char*)s; |
---|
920 | } |
---|
921 | return Nullch; |
---|
922 | } |
---|
923 | table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); |
---|
924 | if (--littlelen >= bigend - big) |
---|
925 | return Nullch; |
---|
926 | s = big + littlelen; |
---|
927 | oldlittle = little = table - 2; |
---|
928 | if (s < bigend) { |
---|
929 | top2: |
---|
930 | /*SUPPRESS 560*/ |
---|
931 | if (tmp = table[*s]) { |
---|
932 | #ifdef POINTERRIGOR |
---|
933 | if (bigend - s > tmp) { |
---|
934 | s += tmp; |
---|
935 | goto top2; |
---|
936 | } |
---|
937 | #else |
---|
938 | if ((s += tmp) < bigend) |
---|
939 | goto top2; |
---|
940 | #endif |
---|
941 | return Nullch; |
---|
942 | } |
---|
943 | else { |
---|
944 | tmp = littlelen; /* less expensive than calling strncmp() */ |
---|
945 | olds = s; |
---|
946 | while (tmp--) { |
---|
947 | if (*--s == *--little) |
---|
948 | continue; |
---|
949 | s = olds + 1; /* here we pay the price for failure */ |
---|
950 | little = oldlittle; |
---|
951 | if (s < bigend) /* fake up continue to outer loop */ |
---|
952 | goto top2; |
---|
953 | return Nullch; |
---|
954 | } |
---|
955 | return (char *)s; |
---|
956 | } |
---|
957 | } |
---|
958 | return Nullch; |
---|
959 | } |
---|
960 | |
---|
961 | char * |
---|
962 | screaminstr(bigstr, littlestr) |
---|
963 | SV *bigstr; |
---|
964 | SV *littlestr; |
---|
965 | { |
---|
966 | register unsigned char *s, *x; |
---|
967 | register unsigned char *big; |
---|
968 | register I32 pos; |
---|
969 | register I32 previous; |
---|
970 | register I32 first; |
---|
971 | register unsigned char *little; |
---|
972 | register unsigned char *bigend; |
---|
973 | register unsigned char *littleend; |
---|
974 | |
---|
975 | if ((pos = screamfirst[BmRARE(littlestr)]) < 0) |
---|
976 | return Nullch; |
---|
977 | little = (unsigned char *)(SvPVX(littlestr)); |
---|
978 | littleend = little + SvCUR(littlestr); |
---|
979 | first = *little++; |
---|
980 | previous = BmPREVIOUS(littlestr); |
---|
981 | big = (unsigned char *)(SvPVX(bigstr)); |
---|
982 | bigend = big + SvCUR(bigstr); |
---|
983 | while (pos < previous) { |
---|
984 | if (!(pos += screamnext[pos])) |
---|
985 | return Nullch; |
---|
986 | } |
---|
987 | #ifdef POINTERRIGOR |
---|
988 | do { |
---|
989 | if (big[pos-previous] != first) |
---|
990 | continue; |
---|
991 | for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { |
---|
992 | if (x >= bigend) |
---|
993 | return Nullch; |
---|
994 | if (*s++ != *x++) { |
---|
995 | s--; |
---|
996 | break; |
---|
997 | } |
---|
998 | } |
---|
999 | if (s == littleend) |
---|
1000 | return (char *)(big+pos-previous); |
---|
1001 | } while ( pos += screamnext[pos] ); |
---|
1002 | #else /* !POINTERRIGOR */ |
---|
1003 | big -= previous; |
---|
1004 | do { |
---|
1005 | if (big[pos] != first) |
---|
1006 | continue; |
---|
1007 | for (x=big+pos+1,s=little; s < littleend; /**/ ) { |
---|
1008 | if (x >= bigend) |
---|
1009 | return Nullch; |
---|
1010 | if (*s++ != *x++) { |
---|
1011 | s--; |
---|
1012 | break; |
---|
1013 | } |
---|
1014 | } |
---|
1015 | if (s == littleend) |
---|
1016 | return (char *)(big+pos); |
---|
1017 | } while ( pos += screamnext[pos] ); |
---|
1018 | #endif /* POINTERRIGOR */ |
---|
1019 | return Nullch; |
---|
1020 | } |
---|
1021 | |
---|
1022 | I32 |
---|
1023 | ibcmp(s1, s2, len) |
---|
1024 | char *s1, *s2; |
---|
1025 | register I32 len; |
---|
1026 | { |
---|
1027 | register U8 *a = (U8 *)s1; |
---|
1028 | register U8 *b = (U8 *)s2; |
---|
1029 | while (len--) { |
---|
1030 | if (*a != *b && *a != fold[*b]) |
---|
1031 | return 1; |
---|
1032 | a++,b++; |
---|
1033 | } |
---|
1034 | return 0; |
---|
1035 | } |
---|
1036 | |
---|
1037 | I32 |
---|
1038 | ibcmp_locale(s1, s2, len) |
---|
1039 | char *s1, *s2; |
---|
1040 | register I32 len; |
---|
1041 | { |
---|
1042 | register U8 *a = (U8 *)s1; |
---|
1043 | register U8 *b = (U8 *)s2; |
---|
1044 | while (len--) { |
---|
1045 | if (*a != *b && *a != fold_locale[*b]) |
---|
1046 | return 1; |
---|
1047 | a++,b++; |
---|
1048 | } |
---|
1049 | return 0; |
---|
1050 | } |
---|
1051 | |
---|
1052 | /* copy a string to a safe spot */ |
---|
1053 | |
---|
1054 | char * |
---|
1055 | savepv(sv) |
---|
1056 | char *sv; |
---|
1057 | { |
---|
1058 | register char *newaddr; |
---|
1059 | |
---|
1060 | New(902,newaddr,strlen(sv)+1,char); |
---|
1061 | (void)strcpy(newaddr,sv); |
---|
1062 | return newaddr; |
---|
1063 | } |
---|
1064 | |
---|
1065 | /* same thing but with a known length */ |
---|
1066 | |
---|
1067 | char * |
---|
1068 | savepvn(sv, len) |
---|
1069 | char *sv; |
---|
1070 | register I32 len; |
---|
1071 | { |
---|
1072 | register char *newaddr; |
---|
1073 | |
---|
1074 | New(903,newaddr,len+1,char); |
---|
1075 | Copy(sv,newaddr,len,char); /* might not be null terminated */ |
---|
1076 | newaddr[len] = '\0'; /* is now */ |
---|
1077 | return newaddr; |
---|
1078 | } |
---|
1079 | |
---|
1080 | /* the SV for form() and mess() is not kept in an arena */ |
---|
1081 | |
---|
1082 | static SV * |
---|
1083 | mess_alloc() |
---|
1084 | { |
---|
1085 | SV *sv; |
---|
1086 | XPVMG *any; |
---|
1087 | |
---|
1088 | /* Create as PVMG now, to avoid any upgrading later */ |
---|
1089 | New(905, sv, 1, SV); |
---|
1090 | Newz(905, any, 1, XPVMG); |
---|
1091 | SvFLAGS(sv) = SVt_PVMG; |
---|
1092 | SvANY(sv) = (void*)any; |
---|
1093 | SvREFCNT(sv) = 1 << 30; /* practically infinite */ |
---|
1094 | return sv; |
---|
1095 | } |
---|
1096 | |
---|
1097 | #ifdef I_STDARG |
---|
1098 | char * |
---|
1099 | form(const char* pat, ...) |
---|
1100 | #else |
---|
1101 | /*VARARGS0*/ |
---|
1102 | char * |
---|
1103 | form(pat, va_alist) |
---|
1104 | const char *pat; |
---|
1105 | va_dcl |
---|
1106 | #endif |
---|
1107 | { |
---|
1108 | va_list args; |
---|
1109 | #ifdef I_STDARG |
---|
1110 | va_start(args, pat); |
---|
1111 | #else |
---|
1112 | va_start(args); |
---|
1113 | #endif |
---|
1114 | if (!mess_sv) |
---|
1115 | mess_sv = mess_alloc(); |
---|
1116 | sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
---|
1117 | va_end(args); |
---|
1118 | return SvPVX(mess_sv); |
---|
1119 | } |
---|
1120 | |
---|
1121 | char * |
---|
1122 | mess(pat, args) |
---|
1123 | const char *pat; |
---|
1124 | va_list *args; |
---|
1125 | { |
---|
1126 | SV *sv; |
---|
1127 | static char dgd[] = " during global destruction.\n"; |
---|
1128 | |
---|
1129 | if (!mess_sv) |
---|
1130 | mess_sv = mess_alloc(); |
---|
1131 | sv = mess_sv; |
---|
1132 | sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); |
---|
1133 | if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { |
---|
1134 | if (dirty) |
---|
1135 | sv_catpv(sv, dgd); |
---|
1136 | else { |
---|
1137 | if (curcop->cop_line) |
---|
1138 | sv_catpvf(sv, " at %_ line %ld", |
---|
1139 | GvSV(curcop->cop_filegv), (long)curcop->cop_line); |
---|
1140 | if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { |
---|
1141 | bool line_mode = (RsSIMPLE(rs) && |
---|
1142 | SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); |
---|
1143 | sv_catpvf(sv, ", <%s> %s %ld", |
---|
1144 | last_in_gv == argvgv ? "" : GvNAME(last_in_gv), |
---|
1145 | line_mode ? "line" : "chunk", |
---|
1146 | (long)IoLINES(GvIOp(last_in_gv))); |
---|
1147 | } |
---|
1148 | sv_catpv(sv, ".\n"); |
---|
1149 | } |
---|
1150 | } |
---|
1151 | return SvPVX(sv); |
---|
1152 | } |
---|
1153 | |
---|
1154 | #ifdef I_STDARG |
---|
1155 | OP * |
---|
1156 | die(const char* pat, ...) |
---|
1157 | #else |
---|
1158 | /*VARARGS0*/ |
---|
1159 | OP * |
---|
1160 | die(pat, va_alist) |
---|
1161 | const char *pat; |
---|
1162 | va_dcl |
---|
1163 | #endif |
---|
1164 | { |
---|
1165 | va_list args; |
---|
1166 | char *message; |
---|
1167 | I32 oldrunlevel = runlevel; |
---|
1168 | int was_in_eval = in_eval; |
---|
1169 | HV *stash; |
---|
1170 | GV *gv; |
---|
1171 | CV *cv; |
---|
1172 | |
---|
1173 | /* We have to switch back to mainstack or die_where may try to pop |
---|
1174 | * the eval block from the wrong stack if die is being called from a |
---|
1175 | * signal handler. - dkindred@cs.cmu.edu */ |
---|
1176 | if (curstack != mainstack) { |
---|
1177 | dSP; |
---|
1178 | SWITCHSTACK(curstack, mainstack); |
---|
1179 | } |
---|
1180 | |
---|
1181 | #ifdef I_STDARG |
---|
1182 | va_start(args, pat); |
---|
1183 | #else |
---|
1184 | va_start(args); |
---|
1185 | #endif |
---|
1186 | message = mess(pat, &args); |
---|
1187 | va_end(args); |
---|
1188 | |
---|
1189 | if (diehook) { |
---|
1190 | /* sv_2cv might call croak() */ |
---|
1191 | SV *olddiehook = diehook; |
---|
1192 | ENTER; |
---|
1193 | SAVESPTR(diehook); |
---|
1194 | diehook = Nullsv; |
---|
1195 | cv = sv_2cv(olddiehook, &stash, &gv, 0); |
---|
1196 | LEAVE; |
---|
1197 | if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { |
---|
1198 | dSP; |
---|
1199 | SV *msg; |
---|
1200 | |
---|
1201 | ENTER; |
---|
1202 | msg = newSVpv(message, 0); |
---|
1203 | SvREADONLY_on(msg); |
---|
1204 | SAVEFREESV(msg); |
---|
1205 | |
---|
1206 | PUSHMARK(sp); |
---|
1207 | XPUSHs(msg); |
---|
1208 | PUTBACK; |
---|
1209 | perl_call_sv((SV*)cv, G_DISCARD); |
---|
1210 | |
---|
1211 | LEAVE; |
---|
1212 | } |
---|
1213 | } |
---|
1214 | |
---|
1215 | restartop = die_where(message); |
---|
1216 | if ((!restartop && was_in_eval) || oldrunlevel > 1) |
---|
1217 | JMPENV_JUMP(3); |
---|
1218 | return restartop; |
---|
1219 | } |
---|
1220 | |
---|
1221 | #ifdef I_STDARG |
---|
1222 | void |
---|
1223 | croak(const char* pat, ...) |
---|
1224 | #else |
---|
1225 | /*VARARGS0*/ |
---|
1226 | void |
---|
1227 | croak(pat, va_alist) |
---|
1228 | char *pat; |
---|
1229 | va_dcl |
---|
1230 | #endif |
---|
1231 | { |
---|
1232 | va_list args; |
---|
1233 | char *message; |
---|
1234 | HV *stash; |
---|
1235 | GV *gv; |
---|
1236 | CV *cv; |
---|
1237 | |
---|
1238 | #ifdef I_STDARG |
---|
1239 | va_start(args, pat); |
---|
1240 | #else |
---|
1241 | va_start(args); |
---|
1242 | #endif |
---|
1243 | message = mess(pat, &args); |
---|
1244 | va_end(args); |
---|
1245 | if (diehook) { |
---|
1246 | /* sv_2cv might call croak() */ |
---|
1247 | SV *olddiehook = diehook; |
---|
1248 | ENTER; |
---|
1249 | SAVESPTR(diehook); |
---|
1250 | diehook = Nullsv; |
---|
1251 | cv = sv_2cv(olddiehook, &stash, &gv, 0); |
---|
1252 | LEAVE; |
---|
1253 | if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { |
---|
1254 | dSP; |
---|
1255 | SV *msg; |
---|
1256 | |
---|
1257 | ENTER; |
---|
1258 | msg = newSVpv(message, 0); |
---|
1259 | SvREADONLY_on(msg); |
---|
1260 | SAVEFREESV(msg); |
---|
1261 | |
---|
1262 | PUSHMARK(sp); |
---|
1263 | XPUSHs(msg); |
---|
1264 | PUTBACK; |
---|
1265 | perl_call_sv((SV*)cv, G_DISCARD); |
---|
1266 | |
---|
1267 | LEAVE; |
---|
1268 | } |
---|
1269 | } |
---|
1270 | if (in_eval) { |
---|
1271 | restartop = die_where(message); |
---|
1272 | JMPENV_JUMP(3); |
---|
1273 | } |
---|
1274 | PerlIO_puts(PerlIO_stderr(),message); |
---|
1275 | (void)PerlIO_flush(PerlIO_stderr()); |
---|
1276 | my_failure_exit(); |
---|
1277 | } |
---|
1278 | |
---|
1279 | void |
---|
1280 | #ifdef I_STDARG |
---|
1281 | warn(const char* pat,...) |
---|
1282 | #else |
---|
1283 | /*VARARGS0*/ |
---|
1284 | warn(pat,va_alist) |
---|
1285 | const char *pat; |
---|
1286 | va_dcl |
---|
1287 | #endif |
---|
1288 | { |
---|
1289 | va_list args; |
---|
1290 | char *message; |
---|
1291 | HV *stash; |
---|
1292 | GV *gv; |
---|
1293 | CV *cv; |
---|
1294 | |
---|
1295 | #ifdef I_STDARG |
---|
1296 | va_start(args, pat); |
---|
1297 | #else |
---|
1298 | va_start(args); |
---|
1299 | #endif |
---|
1300 | message = mess(pat, &args); |
---|
1301 | va_end(args); |
---|
1302 | |
---|
1303 | if (warnhook) { |
---|
1304 | /* sv_2cv might call warn() */ |
---|
1305 | SV *oldwarnhook = warnhook; |
---|
1306 | ENTER; |
---|
1307 | SAVESPTR(warnhook); |
---|
1308 | warnhook = Nullsv; |
---|
1309 | cv = sv_2cv(oldwarnhook, &stash, &gv, 0); |
---|
1310 | LEAVE; |
---|
1311 | if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { |
---|
1312 | dSP; |
---|
1313 | SV *msg; |
---|
1314 | |
---|
1315 | ENTER; |
---|
1316 | msg = newSVpv(message, 0); |
---|
1317 | SvREADONLY_on(msg); |
---|
1318 | SAVEFREESV(msg); |
---|
1319 | |
---|
1320 | PUSHMARK(sp); |
---|
1321 | XPUSHs(msg); |
---|
1322 | PUTBACK; |
---|
1323 | perl_call_sv((SV*)cv, G_DISCARD); |
---|
1324 | |
---|
1325 | LEAVE; |
---|
1326 | return; |
---|
1327 | } |
---|
1328 | } |
---|
1329 | PerlIO_puts(PerlIO_stderr(),message); |
---|
1330 | #ifdef LEAKTEST |
---|
1331 | DEBUG_L(xstat()); |
---|
1332 | #endif |
---|
1333 | (void)PerlIO_flush(PerlIO_stderr()); |
---|
1334 | } |
---|
1335 | |
---|
1336 | #ifndef VMS /* VMS' my_setenv() is in VMS.c */ |
---|
1337 | #ifndef WIN32 |
---|
1338 | void |
---|
1339 | my_setenv(nam,val) |
---|
1340 | char *nam, *val; |
---|
1341 | { |
---|
1342 | register I32 i=setenv_getix(nam); /* where does it go? */ |
---|
1343 | |
---|
1344 | if (environ == origenviron) { /* need we copy environment? */ |
---|
1345 | I32 j; |
---|
1346 | I32 max; |
---|
1347 | char **tmpenv; |
---|
1348 | |
---|
1349 | /*SUPPRESS 530*/ |
---|
1350 | for (max = i; environ[max]; max++) ; |
---|
1351 | New(901,tmpenv, max+2, char*); |
---|
1352 | for (j=0; j<max; j++) /* copy environment */ |
---|
1353 | tmpenv[j] = savepv(environ[j]); |
---|
1354 | tmpenv[max] = Nullch; |
---|
1355 | environ = tmpenv; /* tell exec where it is now */ |
---|
1356 | } |
---|
1357 | if (!val) { |
---|
1358 | Safefree(environ[i]); |
---|
1359 | while (environ[i]) { |
---|
1360 | environ[i] = environ[i+1]; |
---|
1361 | i++; |
---|
1362 | } |
---|
1363 | return; |
---|
1364 | } |
---|
1365 | if (!environ[i]) { /* does not exist yet */ |
---|
1366 | Renew(environ, i+2, char*); /* just expand it a bit */ |
---|
1367 | environ[i+1] = Nullch; /* make sure it's null terminated */ |
---|
1368 | } |
---|
1369 | else |
---|
1370 | Safefree(environ[i]); |
---|
1371 | New(904, environ[i], strlen(nam) + strlen(val) + 2, char); |
---|
1372 | #ifndef MSDOS |
---|
1373 | (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ |
---|
1374 | #else |
---|
1375 | /* MS-DOS requires environment variable names to be in uppercase */ |
---|
1376 | /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but |
---|
1377 | * some utilities and applications may break because they only look |
---|
1378 | * for upper case strings. (Fixed strupr() bug here.)] |
---|
1379 | */ |
---|
1380 | strcpy(environ[i],nam); strupr(environ[i]); |
---|
1381 | (void)sprintf(environ[i] + strlen(nam),"=%s",val); |
---|
1382 | #endif /* MSDOS */ |
---|
1383 | } |
---|
1384 | |
---|
1385 | #else /* if WIN32 */ |
---|
1386 | |
---|
1387 | void |
---|
1388 | my_setenv(nam,val) |
---|
1389 | char *nam, *val; |
---|
1390 | { |
---|
1391 | |
---|
1392 | #ifdef USE_WIN32_RTL_ENV |
---|
1393 | |
---|
1394 | register char *envstr; |
---|
1395 | STRLEN namlen = strlen(nam); |
---|
1396 | STRLEN vallen; |
---|
1397 | char *oldstr = environ[setenv_getix(nam)]; |
---|
1398 | |
---|
1399 | /* putenv() has totally broken semantics in both the Borland |
---|
1400 | * and Microsoft CRTLs. They either store the passed pointer in |
---|
1401 | * the environment without making a copy, or make a copy and don't |
---|
1402 | * free it. And on top of that, they dont free() old entries that |
---|
1403 | * are being replaced/deleted. This means the caller must |
---|
1404 | * free any old entries somehow, or we end up with a memory |
---|
1405 | * leak every time my_setenv() is called. One might think |
---|
1406 | * one could directly manipulate environ[], like the UNIX code |
---|
1407 | * above, but direct changes to environ are not allowed when |
---|
1408 | * calling putenv(), since the RTLs maintain an internal |
---|
1409 | * *copy* of environ[]. Bad, bad, *bad* stink. |
---|
1410 | * GSAR 97-06-07 |
---|
1411 | */ |
---|
1412 | |
---|
1413 | if (!val) { |
---|
1414 | if (!oldstr) |
---|
1415 | return; |
---|
1416 | val = ""; |
---|
1417 | vallen = 0; |
---|
1418 | } |
---|
1419 | else |
---|
1420 | vallen = strlen(val); |
---|
1421 | New(904, envstr, namlen + vallen + 3, char); |
---|
1422 | (void)sprintf(envstr,"%s=%s",nam,val); |
---|
1423 | (void)putenv(envstr); |
---|
1424 | if (oldstr) |
---|
1425 | Safefree(oldstr); |
---|
1426 | #ifdef _MSC_VER |
---|
1427 | Safefree(envstr); /* MSVCRT leaks without this */ |
---|
1428 | #endif |
---|
1429 | |
---|
1430 | #else /* !USE_WIN32_RTL_ENV */ |
---|
1431 | |
---|
1432 | /* The sane way to deal with the environment. |
---|
1433 | * Has these advantages over putenv() & co.: |
---|
1434 | * * enables us to store a truly empty value in the |
---|
1435 | * environment (like in UNIX). |
---|
1436 | * * we don't have to deal with RTL globals, bugs and leaks. |
---|
1437 | * * Much faster. |
---|
1438 | * Why you may want to enable USE_WIN32_RTL_ENV: |
---|
1439 | * * environ[] and RTL functions will not reflect changes, |
---|
1440 | * which might be an issue if extensions want to access |
---|
1441 | * the env. via RTL. This cuts both ways, since RTL will |
---|
1442 | * not see changes made by extensions that call the Win32 |
---|
1443 | * functions directly, either. |
---|
1444 | * GSAR 97-06-07 |
---|
1445 | */ |
---|
1446 | SetEnvironmentVariable(nam,val); |
---|
1447 | |
---|
1448 | #endif |
---|
1449 | } |
---|
1450 | |
---|
1451 | #endif /* WIN32 */ |
---|
1452 | |
---|
1453 | I32 |
---|
1454 | setenv_getix(nam) |
---|
1455 | char *nam; |
---|
1456 | { |
---|
1457 | register I32 i, len = strlen(nam); |
---|
1458 | |
---|
1459 | for (i = 0; environ[i]; i++) { |
---|
1460 | if ( |
---|
1461 | #ifdef WIN32 |
---|
1462 | strnicmp(environ[i],nam,len) == 0 |
---|
1463 | #else |
---|
1464 | strnEQ(environ[i],nam,len) |
---|
1465 | #endif |
---|
1466 | && environ[i][len] == '=') |
---|
1467 | break; /* strnEQ must come first to avoid */ |
---|
1468 | } /* potential SEGV's */ |
---|
1469 | return i; |
---|
1470 | } |
---|
1471 | |
---|
1472 | #endif /* !VMS */ |
---|
1473 | |
---|
1474 | #ifdef UNLINK_ALL_VERSIONS |
---|
1475 | I32 |
---|
1476 | unlnk(f) /* unlink all versions of a file */ |
---|
1477 | char *f; |
---|
1478 | { |
---|
1479 | I32 i; |
---|
1480 | |
---|
1481 | for (i = 0; unlink(f) >= 0; i++) ; |
---|
1482 | return i ? 0 : -1; |
---|
1483 | } |
---|
1484 | #endif |
---|
1485 | |
---|
1486 | #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) |
---|
1487 | char * |
---|
1488 | my_bcopy(from,to,len) |
---|
1489 | register char *from; |
---|
1490 | register char *to; |
---|
1491 | register I32 len; |
---|
1492 | { |
---|
1493 | char *retval = to; |
---|
1494 | |
---|
1495 | if (from - to >= 0) { |
---|
1496 | while (len--) |
---|
1497 | *to++ = *from++; |
---|
1498 | } |
---|
1499 | else { |
---|
1500 | to += len; |
---|
1501 | from += len; |
---|
1502 | while (len--) |
---|
1503 | *(--to) = *(--from); |
---|
1504 | } |
---|
1505 | return retval; |
---|
1506 | } |
---|
1507 | #endif |
---|
1508 | |
---|
1509 | #ifndef HAS_MEMSET |
---|
1510 | void * |
---|
1511 | my_memset(loc,ch,len) |
---|
1512 | register char *loc; |
---|
1513 | register I32 ch; |
---|
1514 | register I32 len; |
---|
1515 | { |
---|
1516 | char *retval = loc; |
---|
1517 | |
---|
1518 | while (len--) |
---|
1519 | *loc++ = ch; |
---|
1520 | return retval; |
---|
1521 | } |
---|
1522 | #endif |
---|
1523 | |
---|
1524 | #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) |
---|
1525 | char * |
---|
1526 | my_bzero(loc,len) |
---|
1527 | register char *loc; |
---|
1528 | register I32 len; |
---|
1529 | { |
---|
1530 | char *retval = loc; |
---|
1531 | |
---|
1532 | while (len--) |
---|
1533 | *loc++ = 0; |
---|
1534 | return retval; |
---|
1535 | } |
---|
1536 | #endif |
---|
1537 | |
---|
1538 | #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) |
---|
1539 | I32 |
---|
1540 | my_memcmp(s1,s2,len) |
---|
1541 | char *s1; |
---|
1542 | char *s2; |
---|
1543 | register I32 len; |
---|
1544 | { |
---|
1545 | register U8 *a = (U8 *)s1; |
---|
1546 | register U8 *b = (U8 *)s2; |
---|
1547 | register I32 tmp; |
---|
1548 | |
---|
1549 | while (len--) { |
---|
1550 | if (tmp = *a++ - *b++) |
---|
1551 | return tmp; |
---|
1552 | } |
---|
1553 | return 0; |
---|
1554 | } |
---|
1555 | #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ |
---|
1556 | |
---|
1557 | #if defined(I_STDARG) || defined(I_VARARGS) |
---|
1558 | #ifndef HAS_VPRINTF |
---|
1559 | |
---|
1560 | #ifdef USE_CHAR_VSPRINTF |
---|
1561 | char * |
---|
1562 | #else |
---|
1563 | int |
---|
1564 | #endif |
---|
1565 | vsprintf(dest, pat, args) |
---|
1566 | char *dest; |
---|
1567 | const char *pat; |
---|
1568 | char *args; |
---|
1569 | { |
---|
1570 | FILE fakebuf; |
---|
1571 | |
---|
1572 | fakebuf._ptr = dest; |
---|
1573 | fakebuf._cnt = 32767; |
---|
1574 | #ifndef _IOSTRG |
---|
1575 | #define _IOSTRG 0 |
---|
1576 | #endif |
---|
1577 | fakebuf._flag = _IOWRT|_IOSTRG; |
---|
1578 | _doprnt(pat, args, &fakebuf); /* what a kludge */ |
---|
1579 | (void)putc('\0', &fakebuf); |
---|
1580 | #ifdef USE_CHAR_VSPRINTF |
---|
1581 | return(dest); |
---|
1582 | #else |
---|
1583 | return 0; /* perl doesn't use return value */ |
---|
1584 | #endif |
---|
1585 | } |
---|
1586 | |
---|
1587 | #endif /* HAS_VPRINTF */ |
---|
1588 | #endif /* I_VARARGS || I_STDARGS */ |
---|
1589 | |
---|
1590 | #ifdef MYSWAP |
---|
1591 | #if BYTEORDER != 0x4321 |
---|
1592 | short |
---|
1593 | #ifndef CAN_PROTOTYPE |
---|
1594 | my_swap(s) |
---|
1595 | short s; |
---|
1596 | #else |
---|
1597 | my_swap(short s) |
---|
1598 | #endif |
---|
1599 | { |
---|
1600 | #if (BYTEORDER & 1) == 0 |
---|
1601 | short result; |
---|
1602 | |
---|
1603 | result = ((s & 255) << 8) + ((s >> 8) & 255); |
---|
1604 | return result; |
---|
1605 | #else |
---|
1606 | return s; |
---|
1607 | #endif |
---|
1608 | } |
---|
1609 | |
---|
1610 | long |
---|
1611 | #ifndef CAN_PROTOTYPE |
---|
1612 | my_htonl(l) |
---|
1613 | register long l; |
---|
1614 | #else |
---|
1615 | my_htonl(long l) |
---|
1616 | #endif |
---|
1617 | { |
---|
1618 | union { |
---|
1619 | long result; |
---|
1620 | char c[sizeof(long)]; |
---|
1621 | } u; |
---|
1622 | |
---|
1623 | #if BYTEORDER == 0x1234 |
---|
1624 | u.c[0] = (l >> 24) & 255; |
---|
1625 | u.c[1] = (l >> 16) & 255; |
---|
1626 | u.c[2] = (l >> 8) & 255; |
---|
1627 | u.c[3] = l & 255; |
---|
1628 | return u.result; |
---|
1629 | #else |
---|
1630 | #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) |
---|
1631 | croak("Unknown BYTEORDER\n"); |
---|
1632 | #else |
---|
1633 | register I32 o; |
---|
1634 | register I32 s; |
---|
1635 | |
---|
1636 | for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { |
---|
1637 | u.c[o & 0xf] = (l >> s) & 255; |
---|
1638 | } |
---|
1639 | return u.result; |
---|
1640 | #endif |
---|
1641 | #endif |
---|
1642 | } |
---|
1643 | |
---|
1644 | long |
---|
1645 | #ifndef CAN_PROTOTYPE |
---|
1646 | my_ntohl(l) |
---|
1647 | register long l; |
---|
1648 | #else |
---|
1649 | my_ntohl(long l) |
---|
1650 | #endif |
---|
1651 | { |
---|
1652 | union { |
---|
1653 | long l; |
---|
1654 | char c[sizeof(long)]; |
---|
1655 | } u; |
---|
1656 | |
---|
1657 | #if BYTEORDER == 0x1234 |
---|
1658 | u.c[0] = (l >> 24) & 255; |
---|
1659 | u.c[1] = (l >> 16) & 255; |
---|
1660 | u.c[2] = (l >> 8) & 255; |
---|
1661 | u.c[3] = l & 255; |
---|
1662 | return u.l; |
---|
1663 | #else |
---|
1664 | #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) |
---|
1665 | croak("Unknown BYTEORDER\n"); |
---|
1666 | #else |
---|
1667 | register I32 o; |
---|
1668 | register I32 s; |
---|
1669 | |
---|
1670 | u.l = l; |
---|
1671 | l = 0; |
---|
1672 | for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { |
---|
1673 | l |= (u.c[o & 0xf] & 255) << s; |
---|
1674 | } |
---|
1675 | return l; |
---|
1676 | #endif |
---|
1677 | #endif |
---|
1678 | } |
---|
1679 | |
---|
1680 | #endif /* BYTEORDER != 0x4321 */ |
---|
1681 | #endif /* MYSWAP */ |
---|
1682 | |
---|
1683 | /* |
---|
1684 | * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. |
---|
1685 | * If these functions are defined, |
---|
1686 | * the BYTEORDER is neither 0x1234 nor 0x4321. |
---|
1687 | * However, this is not assumed. |
---|
1688 | * -DWS |
---|
1689 | */ |
---|
1690 | |
---|
1691 | #define HTOV(name,type) \ |
---|
1692 | type \ |
---|
1693 | name (n) \ |
---|
1694 | register type n; \ |
---|
1695 | { \ |
---|
1696 | union { \ |
---|
1697 | type value; \ |
---|
1698 | char c[sizeof(type)]; \ |
---|
1699 | } u; \ |
---|
1700 | register I32 i; \ |
---|
1701 | register I32 s; \ |
---|
1702 | for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ |
---|
1703 | u.c[i] = (n >> s) & 0xFF; \ |
---|
1704 | } \ |
---|
1705 | return u.value; \ |
---|
1706 | } |
---|
1707 | |
---|
1708 | #define VTOH(name,type) \ |
---|
1709 | type \ |
---|
1710 | name (n) \ |
---|
1711 | register type n; \ |
---|
1712 | { \ |
---|
1713 | union { \ |
---|
1714 | type value; \ |
---|
1715 | char c[sizeof(type)]; \ |
---|
1716 | } u; \ |
---|
1717 | register I32 i; \ |
---|
1718 | register I32 s; \ |
---|
1719 | u.value = n; \ |
---|
1720 | n = 0; \ |
---|
1721 | for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ |
---|
1722 | n += (u.c[i] & 0xFF) << s; \ |
---|
1723 | } \ |
---|
1724 | return n; \ |
---|
1725 | } |
---|
1726 | |
---|
1727 | #if defined(HAS_HTOVS) && !defined(htovs) |
---|
1728 | HTOV(htovs,short) |
---|
1729 | #endif |
---|
1730 | #if defined(HAS_HTOVL) && !defined(htovl) |
---|
1731 | HTOV(htovl,long) |
---|
1732 | #endif |
---|
1733 | #if defined(HAS_VTOHS) && !defined(vtohs) |
---|
1734 | VTOH(vtohs,short) |
---|
1735 | #endif |
---|
1736 | #if defined(HAS_VTOHL) && !defined(vtohl) |
---|
1737 | VTOH(vtohl,long) |
---|
1738 | #endif |
---|
1739 | |
---|
1740 | /* VMS' my_popen() is in VMS.c, same with OS/2. */ |
---|
1741 | #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) |
---|
1742 | PerlIO * |
---|
1743 | my_popen(cmd,mode) |
---|
1744 | char *cmd; |
---|
1745 | char *mode; |
---|
1746 | { |
---|
1747 | int p[2]; |
---|
1748 | register I32 this, that; |
---|
1749 | register I32 pid; |
---|
1750 | SV *sv; |
---|
1751 | I32 doexec = strNE(cmd,"-"); |
---|
1752 | |
---|
1753 | #ifdef OS2 |
---|
1754 | if (doexec) { |
---|
1755 | return my_syspopen(cmd,mode); |
---|
1756 | } |
---|
1757 | #endif |
---|
1758 | if (pipe(p) < 0) |
---|
1759 | return Nullfp; |
---|
1760 | this = (*mode == 'w'); |
---|
1761 | that = !this; |
---|
1762 | if (doexec && tainting) { |
---|
1763 | taint_env(); |
---|
1764 | taint_proper("Insecure %s%s", "EXEC"); |
---|
1765 | } |
---|
1766 | while ((pid = (doexec?vfork():fork())) < 0) { |
---|
1767 | if (errno != EAGAIN) { |
---|
1768 | close(p[this]); |
---|
1769 | if (!doexec) |
---|
1770 | croak("Can't fork"); |
---|
1771 | return Nullfp; |
---|
1772 | } |
---|
1773 | sleep(5); |
---|
1774 | } |
---|
1775 | if (pid == 0) { |
---|
1776 | GV* tmpgv; |
---|
1777 | |
---|
1778 | #define THIS that |
---|
1779 | #define THAT this |
---|
1780 | close(p[THAT]); |
---|
1781 | if (p[THIS] != (*mode == 'r')) { |
---|
1782 | dup2(p[THIS], *mode == 'r'); |
---|
1783 | close(p[THIS]); |
---|
1784 | } |
---|
1785 | if (doexec) { |
---|
1786 | #if !defined(HAS_FCNTL) || !defined(F_SETFD) |
---|
1787 | int fd; |
---|
1788 | |
---|
1789 | #ifndef NOFILE |
---|
1790 | #define NOFILE 20 |
---|
1791 | #endif |
---|
1792 | for (fd = maxsysfd + 1; fd < NOFILE; fd++) |
---|
1793 | close(fd); |
---|
1794 | #endif |
---|
1795 | do_exec(cmd); /* may or may not use the shell */ |
---|
1796 | _exit(1); |
---|
1797 | } |
---|
1798 | /*SUPPRESS 560*/ |
---|
1799 | if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) |
---|
1800 | sv_setiv(GvSV(tmpgv), (IV)getpid()); |
---|
1801 | forkprocess = 0; |
---|
1802 | hv_clear(pidstatus); /* we have no children */ |
---|
1803 | return Nullfp; |
---|
1804 | #undef THIS |
---|
1805 | #undef THAT |
---|
1806 | } |
---|
1807 | do_execfree(); /* free any memory malloced by child on vfork */ |
---|
1808 | close(p[that]); |
---|
1809 | if (p[that] < p[this]) { |
---|
1810 | dup2(p[this], p[that]); |
---|
1811 | close(p[this]); |
---|
1812 | p[this] = p[that]; |
---|
1813 | } |
---|
1814 | sv = *av_fetch(fdpid,p[this],TRUE); |
---|
1815 | (void)SvUPGRADE(sv,SVt_IV); |
---|
1816 | SvIVX(sv) = pid; |
---|
1817 | forkprocess = pid; |
---|
1818 | return PerlIO_fdopen(p[this], mode); |
---|
1819 | } |
---|
1820 | #else |
---|
1821 | #if defined(atarist) || defined(DJGPP) |
---|
1822 | FILE *popen(); |
---|
1823 | PerlIO * |
---|
1824 | my_popen(cmd,mode) |
---|
1825 | char *cmd; |
---|
1826 | char *mode; |
---|
1827 | { |
---|
1828 | /* Needs work for PerlIO ! */ |
---|
1829 | /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ |
---|
1830 | return popen(PerlIO_exportFILE(cmd, 0), mode); |
---|
1831 | } |
---|
1832 | #endif |
---|
1833 | |
---|
1834 | #endif /* !DOSISH */ |
---|
1835 | |
---|
1836 | #ifdef DUMP_FDS |
---|
1837 | dump_fds(s) |
---|
1838 | char *s; |
---|
1839 | { |
---|
1840 | int fd; |
---|
1841 | struct stat tmpstatbuf; |
---|
1842 | |
---|
1843 | PerlIO_printf(PerlIO_stderr(),"%s", s); |
---|
1844 | for (fd = 0; fd < 32; fd++) { |
---|
1845 | if (Fstat(fd,&tmpstatbuf) >= 0) |
---|
1846 | PerlIO_printf(PerlIO_stderr()," %d",fd); |
---|
1847 | } |
---|
1848 | PerlIO_printf(PerlIO_stderr(),"\n"); |
---|
1849 | } |
---|
1850 | #endif |
---|
1851 | |
---|
1852 | #ifndef HAS_DUP2 |
---|
1853 | int |
---|
1854 | dup2(oldfd,newfd) |
---|
1855 | int oldfd; |
---|
1856 | int newfd; |
---|
1857 | { |
---|
1858 | #if defined(HAS_FCNTL) && defined(F_DUPFD) |
---|
1859 | if (oldfd == newfd) |
---|
1860 | return oldfd; |
---|
1861 | close(newfd); |
---|
1862 | return fcntl(oldfd, F_DUPFD, newfd); |
---|
1863 | #else |
---|
1864 | #define DUP2_MAX_FDS 256 |
---|
1865 | int fdtmp[DUP2_MAX_FDS]; |
---|
1866 | I32 fdx = 0; |
---|
1867 | int fd; |
---|
1868 | |
---|
1869 | if (oldfd == newfd) |
---|
1870 | return oldfd; |
---|
1871 | close(newfd); |
---|
1872 | /* good enough for low fd's... */ |
---|
1873 | while ((fd = dup(oldfd)) != newfd && fd >= 0) { |
---|
1874 | if (fdx >= DUP2_MAX_FDS) { |
---|
1875 | close(fd); |
---|
1876 | fd = -1; |
---|
1877 | break; |
---|
1878 | } |
---|
1879 | fdtmp[fdx++] = fd; |
---|
1880 | } |
---|
1881 | while (fdx > 0) |
---|
1882 | close(fdtmp[--fdx]); |
---|
1883 | return fd; |
---|
1884 | #endif |
---|
1885 | } |
---|
1886 | #endif |
---|
1887 | |
---|
1888 | |
---|
1889 | #ifdef HAS_SIGACTION |
---|
1890 | |
---|
1891 | Sighandler_t |
---|
1892 | rsignal(signo, handler) |
---|
1893 | int signo; |
---|
1894 | Sighandler_t handler; |
---|
1895 | { |
---|
1896 | struct sigaction act, oact; |
---|
1897 | |
---|
1898 | act.sa_handler = handler; |
---|
1899 | sigemptyset(&act.sa_mask); |
---|
1900 | act.sa_flags = 0; |
---|
1901 | #ifdef SA_RESTART |
---|
1902 | act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ |
---|
1903 | #endif |
---|
1904 | if (sigaction(signo, &act, &oact) == -1) |
---|
1905 | return SIG_ERR; |
---|
1906 | else |
---|
1907 | return oact.sa_handler; |
---|
1908 | } |
---|
1909 | |
---|
1910 | Sighandler_t |
---|
1911 | rsignal_state(signo) |
---|
1912 | int signo; |
---|
1913 | { |
---|
1914 | struct sigaction oact; |
---|
1915 | |
---|
1916 | if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) |
---|
1917 | return SIG_ERR; |
---|
1918 | else |
---|
1919 | return oact.sa_handler; |
---|
1920 | } |
---|
1921 | |
---|
1922 | int |
---|
1923 | rsignal_save(signo, handler, save) |
---|
1924 | int signo; |
---|
1925 | Sighandler_t handler; |
---|
1926 | Sigsave_t *save; |
---|
1927 | { |
---|
1928 | struct sigaction act; |
---|
1929 | |
---|
1930 | act.sa_handler = handler; |
---|
1931 | sigemptyset(&act.sa_mask); |
---|
1932 | act.sa_flags = 0; |
---|
1933 | #ifdef SA_RESTART |
---|
1934 | act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ |
---|
1935 | #endif |
---|
1936 | return sigaction(signo, &act, save); |
---|
1937 | } |
---|
1938 | |
---|
1939 | int |
---|
1940 | rsignal_restore(signo, save) |
---|
1941 | int signo; |
---|
1942 | Sigsave_t *save; |
---|
1943 | { |
---|
1944 | return sigaction(signo, save, (struct sigaction *)NULL); |
---|
1945 | } |
---|
1946 | |
---|
1947 | #else /* !HAS_SIGACTION */ |
---|
1948 | |
---|
1949 | Sighandler_t |
---|
1950 | rsignal(signo, handler) |
---|
1951 | int signo; |
---|
1952 | Sighandler_t handler; |
---|
1953 | { |
---|
1954 | return signal(signo, handler); |
---|
1955 | } |
---|
1956 | |
---|
1957 | static int sig_trapped; |
---|
1958 | |
---|
1959 | static |
---|
1960 | Signal_t |
---|
1961 | sig_trap(signo) |
---|
1962 | int signo; |
---|
1963 | { |
---|
1964 | sig_trapped++; |
---|
1965 | } |
---|
1966 | |
---|
1967 | Sighandler_t |
---|
1968 | rsignal_state(signo) |
---|
1969 | int signo; |
---|
1970 | { |
---|
1971 | Sighandler_t oldsig; |
---|
1972 | |
---|
1973 | sig_trapped = 0; |
---|
1974 | oldsig = signal(signo, sig_trap); |
---|
1975 | signal(signo, oldsig); |
---|
1976 | if (sig_trapped) |
---|
1977 | kill(getpid(), signo); |
---|
1978 | return oldsig; |
---|
1979 | } |
---|
1980 | |
---|
1981 | int |
---|
1982 | rsignal_save(signo, handler, save) |
---|
1983 | int signo; |
---|
1984 | Sighandler_t handler; |
---|
1985 | Sigsave_t *save; |
---|
1986 | { |
---|
1987 | *save = signal(signo, handler); |
---|
1988 | return (*save == SIG_ERR) ? -1 : 0; |
---|
1989 | } |
---|
1990 | |
---|
1991 | int |
---|
1992 | rsignal_restore(signo, save) |
---|
1993 | int signo; |
---|
1994 | Sigsave_t *save; |
---|
1995 | { |
---|
1996 | return (signal(signo, *save) == SIG_ERR) ? -1 : 0; |
---|
1997 | } |
---|
1998 | |
---|
1999 | #endif /* !HAS_SIGACTION */ |
---|
2000 | |
---|
2001 | /* VMS' my_pclose() is in VMS.c; same with OS/2 */ |
---|
2002 | #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) |
---|
2003 | I32 |
---|
2004 | my_pclose(ptr) |
---|
2005 | PerlIO *ptr; |
---|
2006 | { |
---|
2007 | Sigsave_t hstat, istat, qstat; |
---|
2008 | int status; |
---|
2009 | SV **svp; |
---|
2010 | int pid; |
---|
2011 | bool close_failed; |
---|
2012 | int saved_errno; |
---|
2013 | #ifdef VMS |
---|
2014 | int saved_vaxc_errno; |
---|
2015 | #endif |
---|
2016 | |
---|
2017 | svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); |
---|
2018 | pid = (int)SvIVX(*svp); |
---|
2019 | SvREFCNT_dec(*svp); |
---|
2020 | *svp = &sv_undef; |
---|
2021 | #ifdef OS2 |
---|
2022 | if (pid == -1) { /* Opened by popen. */ |
---|
2023 | return my_syspclose(ptr); |
---|
2024 | } |
---|
2025 | #endif |
---|
2026 | if ((close_failed = (PerlIO_close(ptr) == EOF))) { |
---|
2027 | saved_errno = errno; |
---|
2028 | #ifdef VMS |
---|
2029 | saved_vaxc_errno = vaxc$errno; |
---|
2030 | #endif |
---|
2031 | } |
---|
2032 | #ifdef UTS |
---|
2033 | if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ |
---|
2034 | #endif |
---|
2035 | rsignal_save(SIGHUP, SIG_IGN, &hstat); |
---|
2036 | rsignal_save(SIGINT, SIG_IGN, &istat); |
---|
2037 | rsignal_save(SIGQUIT, SIG_IGN, &qstat); |
---|
2038 | do { |
---|
2039 | pid = wait4pid(pid, &status, 0); |
---|
2040 | } while (pid == -1 && errno == EINTR); |
---|
2041 | rsignal_restore(SIGHUP, &hstat); |
---|
2042 | rsignal_restore(SIGINT, &istat); |
---|
2043 | rsignal_restore(SIGQUIT, &qstat); |
---|
2044 | if (close_failed) { |
---|
2045 | SETERRNO(saved_errno, saved_vaxc_errno); |
---|
2046 | return -1; |
---|
2047 | } |
---|
2048 | return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status)); |
---|
2049 | } |
---|
2050 | #endif /* !DOSISH */ |
---|
2051 | |
---|
2052 | #if !defined(DOSISH) || defined(OS2) |
---|
2053 | I32 |
---|
2054 | wait4pid(pid,statusp,flags) |
---|
2055 | int pid; |
---|
2056 | int *statusp; |
---|
2057 | int flags; |
---|
2058 | { |
---|
2059 | SV *sv; |
---|
2060 | SV** svp; |
---|
2061 | char spid[TYPE_CHARS(int)]; |
---|
2062 | |
---|
2063 | if (!pid) |
---|
2064 | return -1; |
---|
2065 | if (pid > 0) { |
---|
2066 | sprintf(spid, "%d", pid); |
---|
2067 | svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE); |
---|
2068 | if (svp && *svp != &sv_undef) { |
---|
2069 | *statusp = SvIVX(*svp); |
---|
2070 | (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); |
---|
2071 | return pid; |
---|
2072 | } |
---|
2073 | } |
---|
2074 | else { |
---|
2075 | HE *entry; |
---|
2076 | |
---|
2077 | hv_iterinit(pidstatus); |
---|
2078 | if (entry = hv_iternext(pidstatus)) { |
---|
2079 | pid = atoi(hv_iterkey(entry,(I32*)statusp)); |
---|
2080 | sv = hv_iterval(pidstatus,entry); |
---|
2081 | *statusp = SvIVX(sv); |
---|
2082 | sprintf(spid, "%d", pid); |
---|
2083 | (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); |
---|
2084 | return pid; |
---|
2085 | } |
---|
2086 | } |
---|
2087 | #ifdef HAS_WAITPID |
---|
2088 | # ifdef HAS_WAITPID_RUNTIME |
---|
2089 | if (!HAS_WAITPID_RUNTIME) |
---|
2090 | goto hard_way; |
---|
2091 | # endif |
---|
2092 | return waitpid(pid,statusp,flags); |
---|
2093 | #endif |
---|
2094 | #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) |
---|
2095 | return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); |
---|
2096 | #endif |
---|
2097 | #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) |
---|
2098 | hard_way: |
---|
2099 | { |
---|
2100 | I32 result; |
---|
2101 | if (flags) |
---|
2102 | croak("Can't do waitpid with flags"); |
---|
2103 | else { |
---|
2104 | while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) |
---|
2105 | pidgone(result,*statusp); |
---|
2106 | if (result < 0) |
---|
2107 | *statusp = -1; |
---|
2108 | } |
---|
2109 | return result; |
---|
2110 | } |
---|
2111 | #endif |
---|
2112 | } |
---|
2113 | #endif /* !DOSISH */ |
---|
2114 | |
---|
2115 | void |
---|
2116 | /*SUPPRESS 590*/ |
---|
2117 | pidgone(pid,status) |
---|
2118 | int pid; |
---|
2119 | int status; |
---|
2120 | { |
---|
2121 | register SV *sv; |
---|
2122 | char spid[TYPE_CHARS(int)]; |
---|
2123 | |
---|
2124 | sprintf(spid, "%d", pid); |
---|
2125 | sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); |
---|
2126 | (void)SvUPGRADE(sv,SVt_IV); |
---|
2127 | SvIVX(sv) = status; |
---|
2128 | return; |
---|
2129 | } |
---|
2130 | |
---|
2131 | #if defined(atarist) || defined(OS2) || defined(DJGPP) |
---|
2132 | int pclose(); |
---|
2133 | #ifdef HAS_FORK |
---|
2134 | int /* Cannot prototype with I32 |
---|
2135 | in os2ish.h. */ |
---|
2136 | my_syspclose(ptr) |
---|
2137 | #else |
---|
2138 | I32 |
---|
2139 | my_pclose(ptr) |
---|
2140 | #endif |
---|
2141 | PerlIO *ptr; |
---|
2142 | { |
---|
2143 | /* Needs work for PerlIO ! */ |
---|
2144 | FILE *f = PerlIO_findFILE(ptr); |
---|
2145 | I32 result = pclose(f); |
---|
2146 | PerlIO_releaseFILE(ptr,f); |
---|
2147 | return result; |
---|
2148 | } |
---|
2149 | #endif |
---|
2150 | |
---|
2151 | void |
---|
2152 | repeatcpy(to,from,len,count) |
---|
2153 | register char *to; |
---|
2154 | register char *from; |
---|
2155 | I32 len; |
---|
2156 | register I32 count; |
---|
2157 | { |
---|
2158 | register I32 todo; |
---|
2159 | register char *frombase = from; |
---|
2160 | |
---|
2161 | if (len == 1) { |
---|
2162 | todo = *from; |
---|
2163 | while (count-- > 0) |
---|
2164 | *to++ = todo; |
---|
2165 | return; |
---|
2166 | } |
---|
2167 | while (count-- > 0) { |
---|
2168 | for (todo = len; todo > 0; todo--) { |
---|
2169 | *to++ = *from++; |
---|
2170 | } |
---|
2171 | from = frombase; |
---|
2172 | } |
---|
2173 | } |
---|
2174 | |
---|
2175 | #ifndef CASTNEGFLOAT |
---|
2176 | U32 |
---|
2177 | cast_ulong(f) |
---|
2178 | double f; |
---|
2179 | { |
---|
2180 | long along; |
---|
2181 | |
---|
2182 | #if CASTFLAGS & 2 |
---|
2183 | # define BIGDOUBLE 2147483648.0 |
---|
2184 | if (f >= BIGDOUBLE) |
---|
2185 | return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; |
---|
2186 | #endif |
---|
2187 | if (f >= 0.0) |
---|
2188 | return (unsigned long)f; |
---|
2189 | along = (long)f; |
---|
2190 | return (unsigned long)along; |
---|
2191 | } |
---|
2192 | # undef BIGDOUBLE |
---|
2193 | #endif |
---|
2194 | |
---|
2195 | #ifndef CASTI32 |
---|
2196 | |
---|
2197 | /* Unfortunately, on some systems the cast_uv() function doesn't |
---|
2198 | work with the system-supplied definition of ULONG_MAX. The |
---|
2199 | comparison (f >= ULONG_MAX) always comes out true. It must be a |
---|
2200 | problem with the compiler constant folding. |
---|
2201 | |
---|
2202 | In any case, this workaround should be fine on any two's complement |
---|
2203 | system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your |
---|
2204 | ccflags. |
---|
2205 | --Andy Dougherty <doughera@lafcol.lafayette.edu> |
---|
2206 | */ |
---|
2207 | |
---|
2208 | /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead |
---|
2209 | of LONG_(MIN/MAX). |
---|
2210 | -- Kenneth Albanowski <kjahds@kjahds.com> |
---|
2211 | */ |
---|
2212 | |
---|
2213 | #ifndef MY_UV_MAX |
---|
2214 | # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) |
---|
2215 | #endif |
---|
2216 | |
---|
2217 | I32 |
---|
2218 | cast_i32(f) |
---|
2219 | double f; |
---|
2220 | { |
---|
2221 | if (f >= I32_MAX) |
---|
2222 | return (I32) I32_MAX; |
---|
2223 | if (f <= I32_MIN) |
---|
2224 | return (I32) I32_MIN; |
---|
2225 | return (I32) f; |
---|
2226 | } |
---|
2227 | |
---|
2228 | IV |
---|
2229 | cast_iv(f) |
---|
2230 | double f; |
---|
2231 | { |
---|
2232 | if (f >= IV_MAX) |
---|
2233 | return (IV) IV_MAX; |
---|
2234 | if (f <= IV_MIN) |
---|
2235 | return (IV) IV_MIN; |
---|
2236 | return (IV) f; |
---|
2237 | } |
---|
2238 | |
---|
2239 | UV |
---|
2240 | cast_uv(f) |
---|
2241 | double f; |
---|
2242 | { |
---|
2243 | if (f >= MY_UV_MAX) |
---|
2244 | return (UV) MY_UV_MAX; |
---|
2245 | return (UV) f; |
---|
2246 | } |
---|
2247 | |
---|
2248 | #endif |
---|
2249 | |
---|
2250 | #ifndef HAS_RENAME |
---|
2251 | I32 |
---|
2252 | same_dirent(a,b) |
---|
2253 | char *a; |
---|
2254 | char *b; |
---|
2255 | { |
---|
2256 | char *fa = strrchr(a,'/'); |
---|
2257 | char *fb = strrchr(b,'/'); |
---|
2258 | struct stat tmpstatbuf1; |
---|
2259 | struct stat tmpstatbuf2; |
---|
2260 | SV *tmpsv = sv_newmortal(); |
---|
2261 | |
---|
2262 | if (fa) |
---|
2263 | fa++; |
---|
2264 | else |
---|
2265 | fa = a; |
---|
2266 | if (fb) |
---|
2267 | fb++; |
---|
2268 | else |
---|
2269 | fb = b; |
---|
2270 | if (strNE(a,b)) |
---|
2271 | return FALSE; |
---|
2272 | if (fa == a) |
---|
2273 | sv_setpv(tmpsv, "."); |
---|
2274 | else |
---|
2275 | sv_setpvn(tmpsv, a, fa - a); |
---|
2276 | if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) |
---|
2277 | return FALSE; |
---|
2278 | if (fb == b) |
---|
2279 | sv_setpv(tmpsv, "."); |
---|
2280 | else |
---|
2281 | sv_setpvn(tmpsv, b, fb - b); |
---|
2282 | if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) |
---|
2283 | return FALSE; |
---|
2284 | return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && |
---|
2285 | tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; |
---|
2286 | } |
---|
2287 | #endif /* !HAS_RENAME */ |
---|
2288 | |
---|
2289 | UV |
---|
2290 | scan_oct(start, len, retlen) |
---|
2291 | char *start; |
---|
2292 | I32 len; |
---|
2293 | I32 *retlen; |
---|
2294 | { |
---|
2295 | register char *s = start; |
---|
2296 | register UV retval = 0; |
---|
2297 | bool overflowed = FALSE; |
---|
2298 | |
---|
2299 | while (len && *s >= '0' && *s <= '7') { |
---|
2300 | register UV n = retval << 3; |
---|
2301 | if (!overflowed && (n >> 3) != retval) { |
---|
2302 | warn("Integer overflow in octal number"); |
---|
2303 | overflowed = TRUE; |
---|
2304 | } |
---|
2305 | retval = n | (*s++ - '0'); |
---|
2306 | len--; |
---|
2307 | } |
---|
2308 | if (dowarn && len && (*s == '8' || *s == '9')) |
---|
2309 | warn("Illegal octal digit ignored"); |
---|
2310 | *retlen = s - start; |
---|
2311 | return retval; |
---|
2312 | } |
---|
2313 | |
---|
2314 | UV |
---|
2315 | scan_hex(start, len, retlen) |
---|
2316 | char *start; |
---|
2317 | I32 len; |
---|
2318 | I32 *retlen; |
---|
2319 | { |
---|
2320 | register char *s = start; |
---|
2321 | register UV retval = 0; |
---|
2322 | bool overflowed = FALSE; |
---|
2323 | char *tmp; |
---|
2324 | |
---|
2325 | while (len-- && *s && (tmp = strchr(hexdigit, *s))) { |
---|
2326 | register UV n = retval << 4; |
---|
2327 | if (!overflowed && (n >> 4) != retval) { |
---|
2328 | warn("Integer overflow in hex number"); |
---|
2329 | overflowed = TRUE; |
---|
2330 | } |
---|
2331 | retval = n | (tmp - hexdigit) & 15; |
---|
2332 | s++; |
---|
2333 | } |
---|
2334 | *retlen = s - start; |
---|
2335 | return retval; |
---|
2336 | } |
---|
2337 | |
---|
2338 | |
---|
2339 | #ifdef HUGE_VAL |
---|
2340 | /* |
---|
2341 | * This hack is to force load of "huge" support from libm.a |
---|
2342 | * So it is in perl for (say) POSIX to use. |
---|
2343 | * Needed for SunOS with Sun's 'acc' for example. |
---|
2344 | */ |
---|
2345 | double |
---|
2346 | Perl_huge() |
---|
2347 | { |
---|
2348 | return HUGE_VAL; |
---|
2349 | } |
---|
2350 | #endif |
---|