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