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