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