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