source: trunk/third/perl/util.c @ 10724

Revision 10724, 47.0 KB checked in by ghudson, 27 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r10723, which included commits to RCS files with non-trunk default branches.
Line 
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
56static 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
69Malloc_t
70safemalloc(size)
71MEM_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
103Malloc_t
104saferealloc(where,size)
105Malloc_t where;
106MEM_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
153Free_t
154safefree(where)
155Malloc_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
170Malloc_t
171safecalloc(count, size)
172MEM_SIZE count;
173MEM_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(Perl_debug_log, "0x%x: (%05d) calloc %ld  x %ld bytes\n",ptr,an++,(long)count,(long)size));
192#else
193    DEBUG_m(PerlIO_printf(Perl_debug_log, "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
214Malloc_t
215safexmalloc(x,size)
216I32 x;
217MEM_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
228Malloc_t
229safexrealloc(where,size)
230Malloc_t where;
231MEM_SIZE size;
232{
233    register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
234    return new + ALIGN;
235}
236
237void
238safexfree(where)
239Malloc_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
251Malloc_t
252safexcalloc(x,count,size)
253I32 x;
254MEM_SIZE count;
255MEM_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
267static void
268xstat()
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
284char *
285delimcpy(to, toend, from, fromend, delim, retlen)
286register char *to;
287register char *toend;
288register char *from;
289register char *fromend;
290register int delim;
291I32 *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
319char *
320instr(big, little)
321register char *big;
322register 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
351char *
352ninstr(big, bigend, little, lend)
353register char *big;
354register char *bigend;
355char *little;
356char *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
384char *
385rninstr(big, bigend, little, lend)
386register char *big;
387char *bigend;
388char *little;
389char *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 */
418void
419perl_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 */
441void
442perl_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 */
486void
487perl_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
512void
513perl_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
526void
527perl_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 */
544int
545perl_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                                    (int)(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. */
774int
775perl_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 */
790char *
791mem_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
843void
844fbm_compile(sv)
845SV *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
885char *
886fbm_instr(big, bigend, littlestr)
887unsigned char *big;
888register unsigned char *bigend;
889SV *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
961char *
962screaminstr(bigstr, littlestr)
963SV *bigstr;
964SV *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
1022I32
1023ibcmp(s1, s2, len)
1024char *s1, *s2;
1025register 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
1037I32
1038ibcmp_locale(s1, s2, len)
1039char *s1, *s2;
1040register 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
1054char *
1055savepv(sv)
1056char *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
1067char *
1068savepvn(sv, len)
1069char *sv;
1070register 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
1082static SV *
1083mess_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
1098char *
1099form(const char* pat, ...)
1100#else
1101/*VARARGS0*/
1102char *
1103form(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
1121char *
1122mess(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        if (dirty)
1135            sv_catpv(sv, dgd);
1136        else {
1137            if (curcop->cop_line)
1138                sv_catpvf(sv, " at %_ line %ld",
1139                          GvSV(curcop->cop_filegv), (long)curcop->cop_line);
1140            if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
1141                bool line_mode = (RsSIMPLE(rs) &&
1142                                  SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
1143                sv_catpvf(sv, ", <%s> %s %ld",
1144                          last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
1145                          line_mode ? "line" : "chunk",
1146                          (long)IoLINES(GvIOp(last_in_gv)));
1147            }
1148            sv_catpv(sv, ".\n");
1149        }
1150    }
1151    return SvPVX(sv);
1152}
1153
1154#ifdef I_STDARG
1155OP *
1156die(const char* pat, ...)
1157#else
1158/*VARARGS0*/
1159OP *
1160die(pat, va_alist)
1161    const char *pat;
1162    va_dcl
1163#endif
1164{
1165    va_list args;
1166    char *message;
1167    I32 oldrunlevel = runlevel;
1168    int was_in_eval = in_eval;
1169    HV *stash;
1170    GV *gv;
1171    CV *cv;
1172
1173    /* We have to switch back to mainstack or die_where may try to pop
1174     * the eval block from the wrong stack if die is being called from a
1175     * signal handler.  - dkindred@cs.cmu.edu */
1176    if (curstack != mainstack) {
1177        dSP;
1178        SWITCHSTACK(curstack, mainstack);
1179    }
1180
1181#ifdef I_STDARG
1182    va_start(args, pat);
1183#else
1184    va_start(args);
1185#endif
1186    message = mess(pat, &args);
1187    va_end(args);
1188
1189    if (diehook) {
1190        /* sv_2cv might call croak() */
1191        SV *olddiehook = diehook;
1192        ENTER;
1193        SAVESPTR(diehook);
1194        diehook = Nullsv;
1195        cv = sv_2cv(olddiehook, &stash, &gv, 0);
1196        LEAVE;
1197        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1198            dSP;
1199            SV *msg;
1200
1201            ENTER;
1202            msg = newSVpv(message, 0);
1203            SvREADONLY_on(msg);
1204            SAVEFREESV(msg);
1205
1206            PUSHMARK(sp);
1207            XPUSHs(msg);
1208            PUTBACK;
1209            perl_call_sv((SV*)cv, G_DISCARD);
1210
1211            LEAVE;
1212        }
1213    }
1214
1215    restartop = die_where(message);
1216    if ((!restartop && was_in_eval) || oldrunlevel > 1)
1217        JMPENV_JUMP(3);
1218    return restartop;
1219}
1220
1221#ifdef I_STDARG
1222void
1223croak(const char* pat, ...)
1224#else
1225/*VARARGS0*/
1226void
1227croak(pat, va_alist)
1228    char *pat;
1229    va_dcl
1230#endif
1231{
1232    va_list args;
1233    char *message;
1234    HV *stash;
1235    GV *gv;
1236    CV *cv;
1237
1238#ifdef I_STDARG
1239    va_start(args, pat);
1240#else
1241    va_start(args);
1242#endif
1243    message = mess(pat, &args);
1244    va_end(args);
1245    if (diehook) {
1246        /* sv_2cv might call croak() */
1247        SV *olddiehook = diehook;
1248        ENTER;
1249        SAVESPTR(diehook);
1250        diehook = Nullsv;
1251        cv = sv_2cv(olddiehook, &stash, &gv, 0);
1252        LEAVE;
1253        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1254            dSP;
1255            SV *msg;
1256
1257            ENTER;
1258            msg = newSVpv(message, 0);
1259            SvREADONLY_on(msg);
1260            SAVEFREESV(msg);
1261
1262            PUSHMARK(sp);
1263            XPUSHs(msg);
1264            PUTBACK;
1265            perl_call_sv((SV*)cv, G_DISCARD);
1266
1267            LEAVE;
1268        }
1269    }
1270    if (in_eval) {
1271        restartop = die_where(message);
1272        JMPENV_JUMP(3);
1273    }
1274    PerlIO_puts(PerlIO_stderr(),message);
1275    (void)PerlIO_flush(PerlIO_stderr());
1276    my_failure_exit();
1277}
1278
1279void
1280#ifdef I_STDARG
1281warn(const char* pat,...)
1282#else
1283/*VARARGS0*/
1284warn(pat,va_alist)
1285    const char *pat;
1286    va_dcl
1287#endif
1288{
1289    va_list args;
1290    char *message;
1291    HV *stash;
1292    GV *gv;
1293    CV *cv;
1294
1295#ifdef I_STDARG
1296    va_start(args, pat);
1297#else
1298    va_start(args);
1299#endif
1300    message = mess(pat, &args);
1301    va_end(args);
1302
1303    if (warnhook) {
1304        /* sv_2cv might call warn() */
1305        SV *oldwarnhook = warnhook;
1306        ENTER;
1307        SAVESPTR(warnhook);
1308        warnhook = Nullsv;
1309        cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1310        LEAVE;
1311        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1312            dSP;
1313            SV *msg;
1314
1315            ENTER;
1316            msg = newSVpv(message, 0);
1317            SvREADONLY_on(msg);
1318            SAVEFREESV(msg);
1319
1320            PUSHMARK(sp);
1321            XPUSHs(msg);
1322            PUTBACK;
1323            perl_call_sv((SV*)cv, G_DISCARD);
1324
1325            LEAVE;
1326            return;
1327        }
1328    }
1329    PerlIO_puts(PerlIO_stderr(),message);
1330#ifdef LEAKTEST
1331    DEBUG_L(xstat());
1332#endif
1333    (void)PerlIO_flush(PerlIO_stderr());
1334}
1335
1336#ifndef VMS  /* VMS' my_setenv() is in VMS.c */
1337#ifndef WIN32
1338void
1339my_setenv(nam,val)
1340char *nam, *val;
1341{
1342    register I32 i=setenv_getix(nam);           /* where does it go? */
1343
1344    if (environ == origenviron) {       /* need we copy environment? */
1345        I32 j;
1346        I32 max;
1347        char **tmpenv;
1348
1349        /*SUPPRESS 530*/
1350        for (max = i; environ[max]; max++) ;
1351        New(901,tmpenv, max+2, char*);
1352        for (j=0; j<max; j++)           /* copy environment */
1353            tmpenv[j] = savepv(environ[j]);
1354        tmpenv[max] = Nullch;
1355        environ = tmpenv;               /* tell exec where it is now */
1356    }
1357    if (!val) {
1358        Safefree(environ[i]);
1359        while (environ[i]) {
1360            environ[i] = environ[i+1];
1361            i++;
1362        }
1363        return;
1364    }
1365    if (!environ[i]) {                  /* does not exist yet */
1366        Renew(environ, i+2, char*);     /* just expand it a bit */
1367        environ[i+1] = Nullch;  /* make sure it's null terminated */
1368    }
1369    else
1370        Safefree(environ[i]);
1371    New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
1372#ifndef MSDOS
1373    (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
1374#else
1375    /* MS-DOS requires environment variable names to be in uppercase */
1376    /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1377     * some utilities and applications may break because they only look
1378     * for upper case strings. (Fixed strupr() bug here.)]
1379     */
1380    strcpy(environ[i],nam); strupr(environ[i]);
1381    (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1382#endif /* MSDOS */
1383}
1384
1385#else /* if WIN32 */
1386
1387void
1388my_setenv(nam,val)
1389char *nam, *val;
1390{
1391
1392#ifdef USE_WIN32_RTL_ENV
1393
1394    register char *envstr;
1395    STRLEN namlen = strlen(nam);
1396    STRLEN vallen;
1397    char *oldstr = environ[setenv_getix(nam)];
1398
1399    /* putenv() has totally broken semantics in both the Borland
1400     * and Microsoft CRTLs.  They either store the passed pointer in
1401     * the environment without making a copy, or make a copy and don't
1402     * free it. And on top of that, they dont free() old entries that
1403     * are being replaced/deleted.  This means the caller must
1404     * free any old entries somehow, or we end up with a memory
1405     * leak every time my_setenv() is called.  One might think
1406     * one could directly manipulate environ[], like the UNIX code
1407     * above, but direct changes to environ are not allowed when
1408     * calling putenv(), since the RTLs maintain an internal
1409     * *copy* of environ[]. Bad, bad, *bad* stink.
1410     * GSAR 97-06-07
1411     */
1412
1413    if (!val) {
1414        if (!oldstr)
1415            return;
1416        val = "";
1417        vallen = 0;
1418    }
1419    else
1420        vallen = strlen(val);
1421    New(904, envstr, namlen + vallen + 3, char);
1422    (void)sprintf(envstr,"%s=%s",nam,val);
1423    (void)putenv(envstr);
1424    if (oldstr)
1425        Safefree(oldstr);
1426#ifdef _MSC_VER
1427    Safefree(envstr);           /* MSVCRT leaks without this */
1428#endif
1429
1430#else /* !USE_WIN32_RTL_ENV */
1431
1432    /* The sane way to deal with the environment.
1433     * Has these advantages over putenv() & co.:
1434     *  * enables us to store a truly empty value in the
1435     *    environment (like in UNIX).
1436     *  * we don't have to deal with RTL globals, bugs and leaks.
1437     *  * Much faster.
1438     * Why you may want to enable USE_WIN32_RTL_ENV:
1439     *  * environ[] and RTL functions will not reflect changes,
1440     *    which might be an issue if extensions want to access
1441     *    the env. via RTL.  This cuts both ways, since RTL will
1442     *    not see changes made by extensions that call the Win32
1443     *    functions directly, either.
1444     * GSAR 97-06-07
1445     */
1446    SetEnvironmentVariable(nam,val);
1447
1448#endif
1449}
1450
1451#endif /* WIN32 */
1452
1453I32
1454setenv_getix(nam)
1455char *nam;
1456{
1457    register I32 i, len = strlen(nam);
1458
1459    for (i = 0; environ[i]; i++) {
1460        if (
1461#ifdef WIN32
1462            strnicmp(environ[i],nam,len) == 0
1463#else
1464            strnEQ(environ[i],nam,len)
1465#endif
1466            && environ[i][len] == '=')
1467            break;                      /* strnEQ must come first to avoid */
1468    }                                   /* potential SEGV's */
1469    return i;
1470}
1471
1472#endif /* !VMS */
1473
1474#ifdef UNLINK_ALL_VERSIONS
1475I32
1476unlnk(f)        /* unlink all versions of a file */
1477char *f;
1478{
1479    I32 i;
1480
1481    for (i = 0; unlink(f) >= 0; i++) ;
1482    return i ? 0 : -1;
1483}
1484#endif
1485
1486#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
1487char *
1488my_bcopy(from,to,len)
1489register char *from;
1490register char *to;
1491register I32 len;
1492{
1493    char *retval = to;
1494
1495    if (from - to >= 0) {
1496        while (len--)
1497            *to++ = *from++;
1498    }
1499    else {
1500        to += len;
1501        from += len;
1502        while (len--)
1503            *(--to) = *(--from);
1504    }
1505    return retval;
1506}
1507#endif
1508
1509#ifndef HAS_MEMSET
1510void *
1511my_memset(loc,ch,len)
1512register char *loc;
1513register I32 ch;
1514register I32 len;
1515{
1516    char *retval = loc;
1517
1518    while (len--)
1519        *loc++ = ch;
1520    return retval;
1521}
1522#endif
1523
1524#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1525char *
1526my_bzero(loc,len)
1527register char *loc;
1528register I32 len;
1529{
1530    char *retval = loc;
1531
1532    while (len--)
1533        *loc++ = 0;
1534    return retval;
1535}
1536#endif
1537
1538#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1539I32
1540my_memcmp(s1,s2,len)
1541char *s1;
1542char *s2;
1543register I32 len;
1544{
1545    register U8 *a = (U8 *)s1;
1546    register U8 *b = (U8 *)s2;
1547    register I32 tmp;
1548
1549    while (len--) {
1550        if (tmp = *a++ - *b++)
1551            return tmp;
1552    }
1553    return 0;
1554}
1555#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1556
1557#if defined(I_STDARG) || defined(I_VARARGS)
1558#ifndef HAS_VPRINTF
1559
1560#ifdef USE_CHAR_VSPRINTF
1561char *
1562#else
1563int
1564#endif
1565vsprintf(dest, pat, args)
1566char *dest;
1567const char *pat;
1568char *args;
1569{
1570    FILE fakebuf;
1571
1572    fakebuf._ptr = dest;
1573    fakebuf._cnt = 32767;
1574#ifndef _IOSTRG
1575#define _IOSTRG 0
1576#endif
1577    fakebuf._flag = _IOWRT|_IOSTRG;
1578    _doprnt(pat, args, &fakebuf);       /* what a kludge */
1579    (void)putc('\0', &fakebuf);
1580#ifdef USE_CHAR_VSPRINTF
1581    return(dest);
1582#else
1583    return 0;           /* perl doesn't use return value */
1584#endif
1585}
1586
1587#endif /* HAS_VPRINTF */
1588#endif /* I_VARARGS || I_STDARGS */
1589
1590#ifdef MYSWAP
1591#if BYTEORDER != 0x4321
1592short
1593#ifndef CAN_PROTOTYPE
1594my_swap(s)
1595short s;
1596#else
1597my_swap(short s)
1598#endif
1599{
1600#if (BYTEORDER & 1) == 0
1601    short result;
1602
1603    result = ((s & 255) << 8) + ((s >> 8) & 255);
1604    return result;
1605#else
1606    return s;
1607#endif
1608}
1609
1610long
1611#ifndef CAN_PROTOTYPE
1612my_htonl(l)
1613register long l;
1614#else
1615my_htonl(long l)
1616#endif
1617{
1618    union {
1619        long result;
1620        char c[sizeof(long)];
1621    } u;
1622
1623#if BYTEORDER == 0x1234
1624    u.c[0] = (l >> 24) & 255;
1625    u.c[1] = (l >> 16) & 255;
1626    u.c[2] = (l >> 8) & 255;
1627    u.c[3] = l & 255;
1628    return u.result;
1629#else
1630#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1631    croak("Unknown BYTEORDER\n");
1632#else
1633    register I32 o;
1634    register I32 s;
1635
1636    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1637        u.c[o & 0xf] = (l >> s) & 255;
1638    }
1639    return u.result;
1640#endif
1641#endif
1642}
1643
1644long
1645#ifndef CAN_PROTOTYPE
1646my_ntohl(l)
1647register long l;
1648#else
1649my_ntohl(long l)
1650#endif
1651{
1652    union {
1653        long l;
1654        char c[sizeof(long)];
1655    } u;
1656
1657#if BYTEORDER == 0x1234
1658    u.c[0] = (l >> 24) & 255;
1659    u.c[1] = (l >> 16) & 255;
1660    u.c[2] = (l >> 8) & 255;
1661    u.c[3] = l & 255;
1662    return u.l;
1663#else
1664#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1665    croak("Unknown BYTEORDER\n");
1666#else
1667    register I32 o;
1668    register I32 s;
1669
1670    u.l = l;
1671    l = 0;
1672    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1673        l |= (u.c[o & 0xf] & 255) << s;
1674    }
1675    return l;
1676#endif
1677#endif
1678}
1679
1680#endif /* BYTEORDER != 0x4321 */
1681#endif /* MYSWAP */
1682
1683/*
1684 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1685 * If these functions are defined,
1686 * the BYTEORDER is neither 0x1234 nor 0x4321.
1687 * However, this is not assumed.
1688 * -DWS
1689 */
1690
1691#define HTOV(name,type)                                         \
1692        type                                                    \
1693        name (n)                                                \
1694        register type n;                                        \
1695        {                                                       \
1696            union {                                             \
1697                type value;                                     \
1698                char c[sizeof(type)];                           \
1699            } u;                                                \
1700            register I32 i;                                     \
1701            register I32 s;                                     \
1702            for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1703                u.c[i] = (n >> s) & 0xFF;                       \
1704            }                                                   \
1705            return u.value;                                     \
1706        }
1707
1708#define VTOH(name,type)                                         \
1709        type                                                    \
1710        name (n)                                                \
1711        register type n;                                        \
1712        {                                                       \
1713            union {                                             \
1714                type value;                                     \
1715                char c[sizeof(type)];                           \
1716            } u;                                                \
1717            register I32 i;                                     \
1718            register I32 s;                                     \
1719            u.value = n;                                        \
1720            n = 0;                                              \
1721            for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1722                n += (u.c[i] & 0xFF) << s;                      \
1723            }                                                   \
1724            return n;                                           \
1725        }
1726
1727#if defined(HAS_HTOVS) && !defined(htovs)
1728HTOV(htovs,short)
1729#endif
1730#if defined(HAS_HTOVL) && !defined(htovl)
1731HTOV(htovl,long)
1732#endif
1733#if defined(HAS_VTOHS) && !defined(vtohs)
1734VTOH(vtohs,short)
1735#endif
1736#if defined(HAS_VTOHL) && !defined(vtohl)
1737VTOH(vtohl,long)
1738#endif
1739
1740    /* VMS' my_popen() is in VMS.c, same with OS/2. */
1741#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
1742PerlIO *
1743my_popen(cmd,mode)
1744char    *cmd;
1745char    *mode;
1746{
1747    int p[2];
1748    register I32 this, that;
1749    register I32 pid;
1750    SV *sv;
1751    I32 doexec = strNE(cmd,"-");
1752
1753#ifdef OS2
1754    if (doexec) {
1755        return my_syspopen(cmd,mode);
1756    }
1757#endif
1758    if (pipe(p) < 0)
1759        return Nullfp;
1760    this = (*mode == 'w');
1761    that = !this;
1762    if (doexec && tainting) {
1763        taint_env();
1764        taint_proper("Insecure %s%s", "EXEC");
1765    }
1766    while ((pid = (doexec?vfork():fork())) < 0) {
1767        if (errno != EAGAIN) {
1768            close(p[this]);
1769            if (!doexec)
1770                croak("Can't fork");
1771            return Nullfp;
1772        }
1773        sleep(5);
1774    }
1775    if (pid == 0) {
1776        GV* tmpgv;
1777
1778#define THIS that
1779#define THAT this
1780        close(p[THAT]);
1781        if (p[THIS] != (*mode == 'r')) {
1782            dup2(p[THIS], *mode == 'r');
1783            close(p[THIS]);
1784        }
1785        if (doexec) {
1786#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1787            int fd;
1788
1789#ifndef NOFILE
1790#define NOFILE 20
1791#endif
1792            for (fd = maxsysfd + 1; fd < NOFILE; fd++)
1793                close(fd);
1794#endif
1795            do_exec(cmd);       /* may or may not use the shell */
1796            _exit(1);
1797        }
1798        /*SUPPRESS 560*/
1799        if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1800            sv_setiv(GvSV(tmpgv), (IV)getpid());
1801        forkprocess = 0;
1802        hv_clear(pidstatus);    /* we have no children */
1803        return Nullfp;
1804#undef THIS
1805#undef THAT
1806    }
1807    do_execfree();      /* free any memory malloced by child on vfork */
1808    close(p[that]);
1809    if (p[that] < p[this]) {
1810        dup2(p[this], p[that]);
1811        close(p[this]);
1812        p[this] = p[that];
1813    }
1814    sv = *av_fetch(fdpid,p[this],TRUE);
1815    (void)SvUPGRADE(sv,SVt_IV);
1816    SvIVX(sv) = pid;
1817    forkprocess = pid;
1818    return PerlIO_fdopen(p[this], mode);
1819}
1820#else
1821#if defined(atarist) || defined(DJGPP)
1822FILE *popen();
1823PerlIO *
1824my_popen(cmd,mode)
1825char    *cmd;
1826char    *mode;
1827{
1828    /* Needs work for PerlIO ! */
1829    /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
1830    return popen(PerlIO_exportFILE(cmd, 0), mode);
1831}
1832#endif
1833
1834#endif /* !DOSISH */
1835
1836#ifdef DUMP_FDS
1837dump_fds(s)
1838char *s;
1839{
1840    int fd;
1841    struct stat tmpstatbuf;
1842
1843    PerlIO_printf(PerlIO_stderr(),"%s", s);
1844    for (fd = 0; fd < 32; fd++) {
1845        if (Fstat(fd,&tmpstatbuf) >= 0)
1846            PerlIO_printf(PerlIO_stderr()," %d",fd);
1847    }
1848    PerlIO_printf(PerlIO_stderr(),"\n");
1849}
1850#endif
1851
1852#ifndef HAS_DUP2
1853int
1854dup2(oldfd,newfd)
1855int oldfd;
1856int newfd;
1857{
1858#if defined(HAS_FCNTL) && defined(F_DUPFD)
1859    if (oldfd == newfd)
1860        return oldfd;
1861    close(newfd);
1862    return fcntl(oldfd, F_DUPFD, newfd);
1863#else
1864#define DUP2_MAX_FDS 256
1865    int fdtmp[DUP2_MAX_FDS];
1866    I32 fdx = 0;
1867    int fd;
1868
1869    if (oldfd == newfd)
1870        return oldfd;
1871    close(newfd);
1872    /* good enough for low fd's... */
1873    while ((fd = dup(oldfd)) != newfd && fd >= 0) {
1874        if (fdx >= DUP2_MAX_FDS) {
1875            close(fd);
1876            fd = -1;
1877            break;
1878        }
1879        fdtmp[fdx++] = fd;
1880    }
1881    while (fdx > 0)
1882        close(fdtmp[--fdx]);
1883    return fd;
1884#endif
1885}
1886#endif
1887
1888
1889#ifdef HAS_SIGACTION
1890
1891Sighandler_t
1892rsignal(signo, handler)
1893int signo;
1894Sighandler_t handler;
1895{
1896    struct sigaction act, oact;
1897
1898    act.sa_handler = handler;
1899    sigemptyset(&act.sa_mask);
1900    act.sa_flags = 0;
1901#ifdef SA_RESTART
1902    act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1903#endif
1904    if (sigaction(signo, &act, &oact) == -1)
1905        return SIG_ERR;
1906    else
1907        return oact.sa_handler;
1908}
1909
1910Sighandler_t
1911rsignal_state(signo)
1912int signo;
1913{
1914    struct sigaction oact;
1915
1916    if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
1917        return SIG_ERR;
1918    else
1919        return oact.sa_handler;
1920}
1921
1922int
1923rsignal_save(signo, handler, save)
1924int signo;
1925Sighandler_t handler;
1926Sigsave_t *save;
1927{
1928    struct sigaction act;
1929
1930    act.sa_handler = handler;
1931    sigemptyset(&act.sa_mask);
1932    act.sa_flags = 0;
1933#ifdef SA_RESTART
1934    act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1935#endif
1936    return sigaction(signo, &act, save);
1937}
1938
1939int
1940rsignal_restore(signo, save)
1941int signo;
1942Sigsave_t *save;
1943{
1944    return sigaction(signo, save, (struct sigaction *)NULL);
1945}
1946
1947#else /* !HAS_SIGACTION */
1948
1949Sighandler_t
1950rsignal(signo, handler)
1951int signo;
1952Sighandler_t handler;
1953{
1954    return signal(signo, handler);
1955}
1956
1957static int sig_trapped;
1958
1959static
1960Signal_t
1961sig_trap(signo)
1962int signo;
1963{
1964    sig_trapped++;
1965}
1966
1967Sighandler_t
1968rsignal_state(signo)
1969int signo;
1970{
1971    Sighandler_t oldsig;
1972
1973    sig_trapped = 0;
1974    oldsig = signal(signo, sig_trap);
1975    signal(signo, oldsig);
1976    if (sig_trapped)
1977        kill(getpid(), signo);
1978    return oldsig;
1979}
1980
1981int
1982rsignal_save(signo, handler, save)
1983int signo;
1984Sighandler_t handler;
1985Sigsave_t *save;
1986{
1987    *save = signal(signo, handler);
1988    return (*save == SIG_ERR) ? -1 : 0;
1989}
1990
1991int
1992rsignal_restore(signo, save)
1993int signo;
1994Sigsave_t *save;
1995{
1996    return (signal(signo, *save) == SIG_ERR) ? -1 : 0;
1997}
1998
1999#endif /* !HAS_SIGACTION */
2000
2001    /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2002#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
2003I32
2004my_pclose(ptr)
2005PerlIO *ptr;
2006{
2007    Sigsave_t hstat, istat, qstat;
2008    int status;
2009    SV **svp;
2010    int pid;
2011    bool close_failed;
2012    int saved_errno;
2013#ifdef VMS
2014    int saved_vaxc_errno;
2015#endif
2016
2017    svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
2018    pid = (int)SvIVX(*svp);
2019    SvREFCNT_dec(*svp);
2020    *svp = &sv_undef;
2021#ifdef OS2
2022    if (pid == -1) {                    /* Opened by popen. */
2023        return my_syspclose(ptr);
2024    }
2025#endif
2026    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2027        saved_errno = errno;
2028#ifdef VMS
2029        saved_vaxc_errno = vaxc$errno;
2030#endif
2031    }
2032#ifdef UTS
2033    if(kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2034#endif
2035    rsignal_save(SIGHUP, SIG_IGN, &hstat);
2036    rsignal_save(SIGINT, SIG_IGN, &istat);
2037    rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2038    do {
2039        pid = wait4pid(pid, &status, 0);
2040    } while (pid == -1 && errno == EINTR);
2041    rsignal_restore(SIGHUP, &hstat);
2042    rsignal_restore(SIGINT, &istat);
2043    rsignal_restore(SIGQUIT, &qstat);
2044    if (close_failed) {
2045        SETERRNO(saved_errno, saved_vaxc_errno);
2046        return -1;
2047    }
2048    return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
2049}
2050#endif /* !DOSISH */
2051
2052#if  !defined(DOSISH) || defined(OS2)
2053I32
2054wait4pid(pid,statusp,flags)
2055int pid;
2056int *statusp;
2057int flags;
2058{
2059    SV *sv;
2060    SV** svp;
2061    char spid[TYPE_CHARS(int)];
2062
2063    if (!pid)
2064        return -1;
2065    if (pid > 0) {
2066        sprintf(spid, "%d", pid);
2067        svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
2068        if (svp && *svp != &sv_undef) {
2069            *statusp = SvIVX(*svp);
2070            (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
2071            return pid;
2072        }
2073    }
2074    else {
2075        HE *entry;
2076
2077        hv_iterinit(pidstatus);
2078        if (entry = hv_iternext(pidstatus)) {
2079            pid = atoi(hv_iterkey(entry,(I32*)statusp));
2080            sv = hv_iterval(pidstatus,entry);
2081            *statusp = SvIVX(sv);
2082            sprintf(spid, "%d", pid);
2083            (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
2084            return pid;
2085        }
2086    }
2087#ifdef HAS_WAITPID
2088#  ifdef HAS_WAITPID_RUNTIME
2089    if (!HAS_WAITPID_RUNTIME)
2090        goto hard_way;
2091#  endif
2092    return waitpid(pid,statusp,flags);
2093#endif
2094#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2095    return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2096#endif
2097#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2098  hard_way:
2099    {
2100        I32 result;
2101        if (flags)
2102            croak("Can't do waitpid with flags");
2103        else {
2104            while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
2105                pidgone(result,*statusp);
2106            if (result < 0)
2107                *statusp = -1;
2108        }
2109        return result;
2110    }
2111#endif
2112}
2113#endif /* !DOSISH */
2114
2115void
2116/*SUPPRESS 590*/
2117pidgone(pid,status)
2118int pid;
2119int status;
2120{
2121    register SV *sv;
2122    char spid[TYPE_CHARS(int)];
2123
2124    sprintf(spid, "%d", pid);
2125    sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
2126    (void)SvUPGRADE(sv,SVt_IV);
2127    SvIVX(sv) = status;
2128    return;
2129}
2130
2131#if defined(atarist) || defined(OS2) || defined(DJGPP)
2132int pclose();
2133#ifdef HAS_FORK
2134int                                     /* Cannot prototype with I32
2135                                           in os2ish.h. */
2136my_syspclose(ptr)
2137#else
2138I32
2139my_pclose(ptr)
2140#endif
2141PerlIO *ptr;
2142{
2143    /* Needs work for PerlIO ! */
2144    FILE *f = PerlIO_findFILE(ptr);
2145    I32 result = pclose(f);
2146    PerlIO_releaseFILE(ptr,f);
2147    return result;
2148}
2149#endif
2150
2151void
2152repeatcpy(to,from,len,count)
2153register char *to;
2154register char *from;
2155I32 len;
2156register I32 count;
2157{
2158    register I32 todo;
2159    register char *frombase = from;
2160
2161    if (len == 1) {
2162        todo = *from;
2163        while (count-- > 0)
2164            *to++ = todo;
2165        return;
2166    }
2167    while (count-- > 0) {
2168        for (todo = len; todo > 0; todo--) {
2169            *to++ = *from++;
2170        }
2171        from = frombase;
2172    }
2173}
2174
2175#ifndef CASTNEGFLOAT
2176U32
2177cast_ulong(f)
2178double f;
2179{
2180    long along;
2181
2182#if CASTFLAGS & 2
2183#   define BIGDOUBLE 2147483648.0
2184    if (f >= BIGDOUBLE)
2185        return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
2186#endif
2187    if (f >= 0.0)
2188        return (unsigned long)f;
2189    along = (long)f;
2190    return (unsigned long)along;
2191}
2192# undef BIGDOUBLE
2193#endif
2194
2195#ifndef CASTI32
2196
2197/* Unfortunately, on some systems the cast_uv() function doesn't
2198   work with the system-supplied definition of ULONG_MAX.  The
2199   comparison  (f >= ULONG_MAX) always comes out true.  It must be a
2200   problem with the compiler constant folding.
2201
2202   In any case, this workaround should be fine on any two's complement
2203   system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2204   ccflags.
2205               --Andy Dougherty      <doughera@lafcol.lafayette.edu>
2206*/
2207
2208/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2209   of LONG_(MIN/MAX).
2210                           -- Kenneth Albanowski <kjahds@kjahds.com>
2211*/                                     
2212
2213#ifndef MY_UV_MAX
2214#  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
2215#endif
2216
2217I32
2218cast_i32(f)
2219double f;
2220{
2221    if (f >= I32_MAX)
2222        return (I32) I32_MAX;
2223    if (f <= I32_MIN)
2224        return (I32) I32_MIN;
2225    return (I32) f;
2226}
2227
2228IV
2229cast_iv(f)
2230double f;
2231{
2232    if (f >= IV_MAX)
2233        return (IV) IV_MAX;
2234    if (f <= IV_MIN)
2235        return (IV) IV_MIN;
2236    return (IV) f;
2237}
2238
2239UV
2240cast_uv(f)
2241double f;
2242{
2243    if (f >= MY_UV_MAX)
2244        return (UV) MY_UV_MAX;
2245    return (UV) f;
2246}
2247
2248#endif
2249
2250#ifndef HAS_RENAME
2251I32
2252same_dirent(a,b)
2253char *a;
2254char *b;
2255{
2256    char *fa = strrchr(a,'/');
2257    char *fb = strrchr(b,'/');
2258    struct stat tmpstatbuf1;
2259    struct stat tmpstatbuf2;
2260    SV *tmpsv = sv_newmortal();
2261
2262    if (fa)
2263        fa++;
2264    else
2265        fa = a;
2266    if (fb)
2267        fb++;
2268    else
2269        fb = b;
2270    if (strNE(a,b))
2271        return FALSE;
2272    if (fa == a)
2273        sv_setpv(tmpsv, ".");
2274    else
2275        sv_setpvn(tmpsv, a, fa - a);
2276    if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2277        return FALSE;
2278    if (fb == b)
2279        sv_setpv(tmpsv, ".");
2280    else
2281        sv_setpvn(tmpsv, b, fb - b);
2282    if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2283        return FALSE;
2284    return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2285           tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2286}
2287#endif /* !HAS_RENAME */
2288
2289UV
2290scan_oct(start, len, retlen)
2291char *start;
2292I32 len;
2293I32 *retlen;
2294{
2295    register char *s = start;
2296    register UV retval = 0;
2297    bool overflowed = FALSE;
2298
2299    while (len && *s >= '0' && *s <= '7') {
2300        register UV n = retval << 3;
2301        if (!overflowed && (n >> 3) != retval) {
2302            warn("Integer overflow in octal number");
2303            overflowed = TRUE;
2304        }
2305        retval = n | (*s++ - '0');
2306        len--;
2307    }
2308    if (dowarn && len && (*s == '8' || *s == '9'))
2309        warn("Illegal octal digit ignored");
2310    *retlen = s - start;
2311    return retval;
2312}
2313
2314UV
2315scan_hex(start, len, retlen)
2316char *start;
2317I32 len;
2318I32 *retlen;
2319{
2320    register char *s = start;
2321    register UV retval = 0;
2322    bool overflowed = FALSE;
2323    char *tmp;
2324
2325    while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
2326        register UV n = retval << 4;
2327        if (!overflowed && (n >> 4) != retval) {
2328            warn("Integer overflow in hex number");
2329            overflowed = TRUE;
2330        }
2331        retval = n | (tmp - hexdigit) & 15;
2332        s++;
2333    }
2334    *retlen = s - start;
2335    return retval;
2336}
2337
2338
2339#ifdef HUGE_VAL
2340/*
2341 * This hack is to force load of "huge" support from libm.a
2342 * So it is in perl for (say) POSIX to use.
2343 * Needed for SunOS with Sun's 'acc' for example.
2344 */
2345double
2346Perl_huge()
2347{
2348 return HUGE_VAL;
2349}
2350#endif
Note: See TracBrowser for help on using the repository browser.