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