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