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