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