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