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