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