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