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