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