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