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

Revision 17035, 89.2 KB checked in by zacheiss, 23 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r17034, which included commits to RCS files with non-trunk default branches.
Line 
1/*    util.c
2 *
3 *    Copyright (c) 1991-2001, 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#define PERL_IN_UTIL_C
17#include "perl.h"
18
19#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
20#include <signal.h>
21#endif
22
23#ifndef SIG_ERR
24# define SIG_ERR ((Sighandler_t) -1)
25#endif
26
27#ifdef I_VFORK
28#  include <vfork.h>
29#endif
30
31/* Put this after #includes because fork and vfork prototypes may
32   conflict.
33*/
34#ifndef HAS_VFORK
35#   define vfork fork
36#endif
37
38#ifdef I_SYS_WAIT
39#  include <sys/wait.h>
40#endif
41
42#ifdef I_LOCALE
43#  include <locale.h>
44#endif
45
46#define FLUSH
47
48#ifdef LEAKTEST
49
50long xcount[MAXXCOUNT];
51long lastxcount[MAXXCOUNT];
52long xycount[MAXXCOUNT][MAXYCOUNT];
53long lastxycount[MAXXCOUNT][MAXYCOUNT];
54
55#endif
56
57#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
58#  define FD_CLOEXEC 1                  /* NeXT needs this */
59#endif
60
61/* paranoid version of system's 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
70Perl_safesysmalloc(MEM_SIZE size)
71{
72    dTHX;
73    Malloc_t ptr;
74#ifdef HAS_64K_LIMIT
75        if (size > 0xffff) {
76            PerlIO_printf(Perl_error_log,
77                          "Allocation too large: %lx\n", size) FLUSH;
78            my_exit(1);
79        }
80#endif /* HAS_64K_LIMIT */
81#ifdef DEBUGGING
82    if ((long)size < 0)
83        Perl_croak_nocontext("panic: malloc");
84#endif
85    ptr = PerlMem_malloc(size?size:1);  /* malloc(0) is NASTY on our system */
86    PERL_ALLOC_CHECK(ptr);
87    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
88    if (ptr != Nullch)
89        return ptr;
90    else if (PL_nomemok)
91        return Nullch;
92    else {
93        PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
94        my_exit(1);
95        return Nullch;
96    }
97    /*NOTREACHED*/
98}
99
100/* paranoid version of system's realloc() */
101
102Malloc_t
103Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
104{
105    dTHX;
106    Malloc_t ptr;
107#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
108    Malloc_t PerlMem_realloc();
109#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
110
111#ifdef HAS_64K_LIMIT
112    if (size > 0xffff) {
113        PerlIO_printf(Perl_error_log,
114                      "Reallocation too large: %lx\n", size) FLUSH;
115        my_exit(1);
116    }
117#endif /* HAS_64K_LIMIT */
118    if (!size) {
119        safesysfree(where);
120        return NULL;
121    }
122
123    if (!where)
124        return safesysmalloc(size);
125#ifdef DEBUGGING
126    if ((long)size < 0)
127        Perl_croak_nocontext("panic: realloc");
128#endif
129    ptr = PerlMem_realloc(where,size);
130    PERL_ALLOC_CHECK(ptr);
131 
132    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
133    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
134
135    if (ptr != Nullch)
136        return ptr;
137    else if (PL_nomemok)
138        return Nullch;
139    else {
140        PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
141        my_exit(1);
142        return Nullch;
143    }
144    /*NOTREACHED*/
145}
146
147/* safe version of system's free() */
148
149Free_t
150Perl_safesysfree(Malloc_t where)
151{
152#ifdef PERL_IMPLICIT_SYS
153    dTHX;
154#endif
155    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
156    if (where) {
157        /*SUPPRESS 701*/
158        PerlMem_free(where);
159    }
160}
161
162/* safe version of system's calloc() */
163
164Malloc_t
165Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
166{
167    dTHX;
168    Malloc_t ptr;
169
170#ifdef HAS_64K_LIMIT
171    if (size * count > 0xffff) {
172        PerlIO_printf(Perl_error_log,
173                      "Allocation too large: %lx\n", size * count) FLUSH;
174        my_exit(1);
175    }
176#endif /* HAS_64K_LIMIT */
177#ifdef DEBUGGING
178    if ((long)size < 0 || (long)count < 0)
179        Perl_croak_nocontext("panic: calloc");
180#endif
181    size *= count;
182    ptr = PerlMem_malloc(size?size:1);  /* malloc(0) is NASTY on our system */
183    PERL_ALLOC_CHECK(ptr);
184    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
185    if (ptr != Nullch) {
186        memset((void*)ptr, 0, size);
187        return ptr;
188    }
189    else if (PL_nomemok)
190        return Nullch;
191    else {
192        PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
193        my_exit(1);
194        return Nullch;
195    }
196    /*NOTREACHED*/
197}
198
199#ifdef LEAKTEST
200
201struct mem_test_strut {
202    union {
203        long type;
204        char c[2];
205    } u;
206    long size;
207};
208
209#    define ALIGN sizeof(struct mem_test_strut)
210
211#    define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
212#    define typeof_chunk(ch) \
213        (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
214#    define set_typeof_chunk(ch,t) \
215        (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
216#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE                            \
217                          ? MAXYCOUNT - 1                               \
218                          : ( (size) > 40                               \
219                              ? ((size) - 1)/8 + 5                      \
220                              : ((size) - 1)/4))
221
222Malloc_t
223Perl_safexmalloc(I32 x, MEM_SIZE size)
224{
225    register char* where = (char*)safemalloc(size + ALIGN);
226
227    xcount[x] += size;
228    xycount[x][SIZE_TO_Y(size)]++;
229    set_typeof_chunk(where, x);
230    sizeof_chunk(where) = size;
231    return (Malloc_t)(where + ALIGN);
232}
233
234Malloc_t
235Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
236{
237    char *where = (char*)wh;
238
239    if (!wh)
240        return safexmalloc(0,size);
241   
242    {
243        MEM_SIZE old = sizeof_chunk(where - ALIGN);
244        int t = typeof_chunk(where - ALIGN);
245        register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
246   
247        xycount[t][SIZE_TO_Y(old)]--;
248        xycount[t][SIZE_TO_Y(size)]++;
249        xcount[t] += size - old;
250        sizeof_chunk(new) = size;
251        return (Malloc_t)(new + ALIGN);
252    }
253}
254
255void
256Perl_safexfree(Malloc_t wh)
257{
258    I32 x;
259    char *where = (char*)wh;
260    MEM_SIZE size;
261   
262    if (!where)
263        return;
264    where -= ALIGN;
265    size = sizeof_chunk(where);
266    x = where[0] + 100 * where[1];
267    xcount[x] -= size;
268    xycount[x][SIZE_TO_Y(size)]--;
269    safefree(where);
270}
271
272Malloc_t
273Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
274{
275    register char * where = (char*)safexmalloc(x, size * count + ALIGN);
276    xcount[x] += size;
277    xycount[x][SIZE_TO_Y(size)]++;
278    memset((void*)(where + ALIGN), 0, size * count);
279    set_typeof_chunk(where, x);
280    sizeof_chunk(where) = size;
281    return (Malloc_t)(where + ALIGN);
282}
283
284STATIC void
285S_xstat(pTHX_ int flag)
286{
287    register I32 i, j, total = 0;
288    I32 subtot[MAXYCOUNT];
289
290    for (j = 0; j < MAXYCOUNT; j++) {
291        subtot[j] = 0;
292    }
293   
294    PerlIO_printf(Perl_debug_log, "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
295    for (i = 0; i < MAXXCOUNT; i++) {
296        total += xcount[i];
297        for (j = 0; j < MAXYCOUNT; j++) {
298            subtot[j] += xycount[i][j];
299        }
300        if (flag == 0
301            ? xcount[i]                 /* Have something */
302            : (flag == 2
303               ? xcount[i] != lastxcount[i] /* Changed */
304               : xcount[i] > lastxcount[i])) { /* Growed */
305            PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
306                          flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
307            lastxcount[i] = xcount[i];
308            for (j = 0; j < MAXYCOUNT; j++) {
309                if ( flag == 0
310                     ? xycount[i][j]    /* Have something */
311                     : (flag == 2
312                        ? xycount[i][j] != lastxycount[i][j] /* Changed */
313                        : xycount[i][j] > lastxycount[i][j])) { /* Growed */
314                    PerlIO_printf(Perl_debug_log,"%3ld ",
315                                  flag == 2
316                                  ? xycount[i][j] - lastxycount[i][j]
317                                  : xycount[i][j]);
318                    lastxycount[i][j] = xycount[i][j];
319                } else {
320                    PerlIO_printf(Perl_debug_log, "  . ", xycount[i][j]);
321                }
322            }
323            PerlIO_printf(Perl_debug_log, "\n");
324        }
325    }
326    if (flag != 2) {
327        PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
328        for (j = 0; j < MAXYCOUNT; j++) {
329            if (subtot[j]) {
330                PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
331            } else {
332                PerlIO_printf(Perl_debug_log, "  . ");
333            }
334        }
335        PerlIO_printf(Perl_debug_log, "\n");   
336    }
337}
338
339#endif /* LEAKTEST */
340
341/* copy a string up to some (non-backslashed) delimiter, if any */
342
343char *
344Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
345{
346    register I32 tolen;
347    for (tolen = 0; from < fromend; from++, tolen++) {
348        if (*from == '\\') {
349            if (from[1] == delim)
350                from++;
351            else {
352                if (to < toend)
353                    *to++ = *from;
354                tolen++;
355                from++;
356            }
357        }
358        else if (*from == delim)
359            break;
360        if (to < toend)
361            *to++ = *from;
362    }
363    if (to < toend)
364        *to = '\0';
365    *retlen = tolen;
366    return from;
367}
368
369/* return ptr to little string in big string, NULL if not found */
370/* This routine was donated by Corey Satten. */
371
372char *
373Perl_instr(pTHX_ register const char *big, register const char *little)
374{
375    register const char *s, *x;
376    register I32 first;
377
378    if (!little)
379        return (char*)big;
380    first = *little++;
381    if (!first)
382        return (char*)big;
383    while (*big) {
384        if (*big++ != first)
385            continue;
386        for (x=big,s=little; *s; /**/ ) {
387            if (!*x)
388                return Nullch;
389            if (*s++ != *x++) {
390                s--;
391                break;
392            }
393        }
394        if (!*s)
395            return (char*)(big-1);
396    }
397    return Nullch;
398}
399
400/* same as instr but allow embedded nulls */
401
402char *
403Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
404{
405    register const char *s, *x;
406    register I32 first = *little;
407    register const char *littleend = lend;
408
409    if (!first && little >= littleend)
410        return (char*)big;
411    if (bigend - big < littleend - little)
412        return Nullch;
413    bigend -= littleend - little++;
414    while (big <= bigend) {
415        if (*big++ != first)
416            continue;
417        for (x=big,s=little; s < littleend; /**/ ) {
418            if (*s++ != *x++) {
419                s--;
420                break;
421            }
422        }
423        if (s >= littleend)
424            return (char*)(big-1);
425    }
426    return Nullch;
427}
428
429/* reverse of the above--find last substring */
430
431char *
432Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
433{
434    register const char *bigbeg;
435    register const char *s, *x;
436    register I32 first = *little;
437    register const char *littleend = lend;
438
439    if (!first && little >= littleend)
440        return (char*)bigend;
441    bigbeg = big;
442    big = bigend - (littleend - little++);
443    while (big >= bigbeg) {
444        if (*big-- != first)
445            continue;
446        for (x=big+2,s=little; s < littleend; /**/ ) {
447            if (*s++ != *x++) {
448                s--;
449                break;
450            }
451        }
452        if (s >= littleend)
453            return (char*)(big+1);
454    }
455    return Nullch;
456}
457
458/*
459 * Set up for a new ctype locale.
460 */
461void
462Perl_new_ctype(pTHX_ char *newctype)
463{
464#ifdef USE_LOCALE_CTYPE
465
466    int i;
467
468    for (i = 0; i < 256; i++) {
469        if (isUPPER_LC(i))
470            PL_fold_locale[i] = toLOWER_LC(i);
471        else if (isLOWER_LC(i))
472            PL_fold_locale[i] = toUPPER_LC(i);
473        else
474            PL_fold_locale[i] = i;
475    }
476
477#endif /* USE_LOCALE_CTYPE */
478}
479
480/*
481 * Standardize the locale name from a string returned by 'setlocale'.
482 *
483 * The standard return value of setlocale() is either
484 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
485 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
486 *     (the space-separated values represent the various sublocales,
487 *      in some unspecificed order)
488 *
489 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
490 * which is harmful for further use of the string in setlocale().
491 *
492 */
493STATIC char *
494S_stdize_locale(pTHX_ char *locs)
495{
496    char *s;
497    bool okay = TRUE;
498
499    if ((s = strchr(locs, '='))) {
500        char *t;
501
502        okay = FALSE;
503        if ((t = strchr(s, '.'))) {
504            char *u;
505
506            if ((u = strchr(t, '\n'))) {
507
508                if (u[1] == 0) {
509                    STRLEN len = u - s;
510                    Move(s + 1, locs, len, char);
511                    locs[len] = 0;
512                    okay = TRUE;
513                }
514            }
515        }
516    }
517
518    if (!okay)
519        Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
520
521    return locs;
522}
523
524/*
525 * Set up for a new collation locale.
526 */
527void
528Perl_new_collate(pTHX_ char *newcoll)
529{
530#ifdef USE_LOCALE_COLLATE
531
532    if (! newcoll) {
533        if (PL_collation_name) {
534            ++PL_collation_ix;
535            Safefree(PL_collation_name);
536            PL_collation_name = NULL;
537        }
538        PL_collation_standard = TRUE;
539        PL_collxfrm_base = 0;
540        PL_collxfrm_mult = 2;
541        return;
542    }
543
544    if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
545        ++PL_collation_ix;
546        Safefree(PL_collation_name);
547        PL_collation_name = stdize_locale(savepv(newcoll));
548        PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
549
550        {
551          /*  2: at most so many chars ('a', 'b'). */
552          /* 50: surely no system expands a char more. */
553#define XFRMBUFSIZE  (2 * 50)
554          char xbuf[XFRMBUFSIZE];
555          Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
556          Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
557          SSize_t mult = fb - fa;
558          if (mult < 1)
559              Perl_croak(aTHX_ "strxfrm() gets absurd");
560          PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
561          PL_collxfrm_mult = mult;
562        }
563    }
564
565#endif /* USE_LOCALE_COLLATE */
566}
567
568void
569Perl_set_numeric_radix(pTHX)
570{
571#ifdef USE_LOCALE_NUMERIC
572# ifdef HAS_LOCALECONV
573    struct lconv* lc;
574
575    lc = localeconv();
576    if (lc && lc->decimal_point) {
577        if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
578            SvREFCNT_dec(PL_numeric_radix_sv);
579            PL_numeric_radix_sv = 0;
580        }
581        else {
582            if (PL_numeric_radix_sv)
583                sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
584            else
585                PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
586        }
587    }
588    else
589        PL_numeric_radix_sv = 0;
590# endif /* HAS_LOCALECONV */
591#endif /* USE_LOCALE_NUMERIC */
592}
593
594/*
595 * Set up for a new numeric locale.
596 */
597void
598Perl_new_numeric(pTHX_ char *newnum)
599{
600#ifdef USE_LOCALE_NUMERIC
601
602    if (! newnum) {
603        if (PL_numeric_name) {
604            Safefree(PL_numeric_name);
605            PL_numeric_name = NULL;
606        }
607        PL_numeric_standard = TRUE;
608        PL_numeric_local = TRUE;
609        return;
610    }
611
612    if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
613        Safefree(PL_numeric_name);
614        PL_numeric_name = stdize_locale(savepv(newnum));
615        PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
616        PL_numeric_local = TRUE;
617        set_numeric_radix();
618    }
619
620#endif /* USE_LOCALE_NUMERIC */
621}
622
623void
624Perl_set_numeric_standard(pTHX)
625{
626#ifdef USE_LOCALE_NUMERIC
627
628    if (! PL_numeric_standard) {
629        setlocale(LC_NUMERIC, "C");
630        PL_numeric_standard = TRUE;
631        PL_numeric_local = FALSE;
632        set_numeric_radix();
633    }
634
635#endif /* USE_LOCALE_NUMERIC */
636}
637
638void
639Perl_set_numeric_local(pTHX)
640{
641#ifdef USE_LOCALE_NUMERIC
642
643    if (! PL_numeric_local) {
644        setlocale(LC_NUMERIC, PL_numeric_name);
645        PL_numeric_standard = FALSE;
646        PL_numeric_local = TRUE;
647        set_numeric_radix();
648    }
649
650#endif /* USE_LOCALE_NUMERIC */
651}
652
653/*
654 * Initialize locale awareness.
655 */
656int
657Perl_init_i18nl10n(pTHX_ int printwarn)
658{
659    int ok = 1;
660    /* returns
661     *    1 = set ok or not applicable,
662     *    0 = fallback to C locale,
663     *   -1 = fallback to C locale failed
664     */
665
666#if defined(USE_LOCALE)
667
668#ifdef USE_LOCALE_CTYPE
669    char *curctype   = NULL;
670#endif /* USE_LOCALE_CTYPE */
671#ifdef USE_LOCALE_COLLATE
672    char *curcoll    = NULL;
673#endif /* USE_LOCALE_COLLATE */
674#ifdef USE_LOCALE_NUMERIC
675    char *curnum     = NULL;
676#endif /* USE_LOCALE_NUMERIC */
677#ifdef __GLIBC__
678    char *language   = PerlEnv_getenv("LANGUAGE");
679#endif
680    char *lc_all     = PerlEnv_getenv("LC_ALL");
681    char *lang       = PerlEnv_getenv("LANG");
682    bool setlocale_failure = FALSE;
683
684#ifdef LOCALE_ENVIRON_REQUIRED
685
686    /*
687     * Ultrix setlocale(..., "") fails if there are no environment
688     * variables from which to get a locale name.
689     */
690
691    bool done = FALSE;
692
693#ifdef LC_ALL
694    if (lang) {
695        if (setlocale(LC_ALL, ""))
696            done = TRUE;
697        else
698            setlocale_failure = TRUE;
699    }
700    if (!setlocale_failure) {
701#ifdef USE_LOCALE_CTYPE
702        if (! (curctype =
703               setlocale(LC_CTYPE,
704                         (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
705                                    ? "" : Nullch)))
706            setlocale_failure = TRUE;
707        else
708            curctype = savepv(curctype);
709#endif /* USE_LOCALE_CTYPE */
710#ifdef USE_LOCALE_COLLATE
711        if (! (curcoll =
712               setlocale(LC_COLLATE,
713                         (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
714                                   ? "" : Nullch)))
715            setlocale_failure = TRUE;
716        else
717            curcoll = savepv(curcoll);
718#endif /* USE_LOCALE_COLLATE */
719#ifdef USE_LOCALE_NUMERIC
720        if (! (curnum =
721               setlocale(LC_NUMERIC,
722                         (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
723                                  ? "" : Nullch)))
724            setlocale_failure = TRUE;
725        else
726            curnum = savepv(curnum);
727#endif /* USE_LOCALE_NUMERIC */
728    }
729
730#endif /* LC_ALL */
731
732#endif /* !LOCALE_ENVIRON_REQUIRED */
733
734#ifdef LC_ALL
735    if (! setlocale(LC_ALL, ""))
736        setlocale_failure = TRUE;
737#endif /* LC_ALL */
738
739    if (!setlocale_failure) {
740#ifdef USE_LOCALE_CTYPE
741        if (! (curctype = setlocale(LC_CTYPE, "")))
742            setlocale_failure = TRUE;
743        else
744            curctype = savepv(curctype);
745#endif /* USE_LOCALE_CTYPE */
746#ifdef USE_LOCALE_COLLATE
747        if (! (curcoll = setlocale(LC_COLLATE, "")))
748            setlocale_failure = TRUE;
749        else
750            curcoll = savepv(curcoll);
751#endif /* USE_LOCALE_COLLATE */
752#ifdef USE_LOCALE_NUMERIC
753        if (! (curnum = setlocale(LC_NUMERIC, "")))
754            setlocale_failure = TRUE;
755        else
756            curnum = savepv(curnum);
757#endif /* USE_LOCALE_NUMERIC */
758    }
759
760    if (setlocale_failure) {
761        char *p;
762        bool locwarn = (printwarn > 1 ||
763                        (printwarn &&
764                         (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
765
766        if (locwarn) {
767#ifdef LC_ALL
768 
769            PerlIO_printf(Perl_error_log,
770               "perl: warning: Setting locale failed.\n");
771
772#else /* !LC_ALL */
773 
774            PerlIO_printf(Perl_error_log,
775               "perl: warning: Setting locale failed for the categories:\n\t");
776#ifdef USE_LOCALE_CTYPE
777            if (! curctype)
778                PerlIO_printf(Perl_error_log, "LC_CTYPE ");
779#endif /* USE_LOCALE_CTYPE */
780#ifdef USE_LOCALE_COLLATE
781            if (! curcoll)
782                PerlIO_printf(Perl_error_log, "LC_COLLATE ");
783#endif /* USE_LOCALE_COLLATE */
784#ifdef USE_LOCALE_NUMERIC
785            if (! curnum)
786                PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
787#endif /* USE_LOCALE_NUMERIC */
788            PerlIO_printf(Perl_error_log, "\n");
789
790#endif /* LC_ALL */
791
792            PerlIO_printf(Perl_error_log,
793                "perl: warning: Please check that your locale settings:\n");
794
795#ifdef __GLIBC__
796            PerlIO_printf(Perl_error_log,
797                          "\tLANGUAGE = %c%s%c,\n",
798                          language ? '"' : '(',
799                          language ? language : "unset",
800                          language ? '"' : ')');
801#endif
802
803            PerlIO_printf(Perl_error_log,
804                          "\tLC_ALL = %c%s%c,\n",
805                          lc_all ? '"' : '(',
806                          lc_all ? lc_all : "unset",
807                          lc_all ? '"' : ')');
808
809#if defined(USE_ENVIRON_ARRAY)
810            {
811              char **e;
812              for (e = environ; *e; e++) {
813                  if (strnEQ(*e, "LC_", 3)
814                        && strnNE(*e, "LC_ALL=", 7)
815                        && (p = strchr(*e, '=')))
816                      PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
817                                    (int)(p - *e), *e, p + 1);
818              }
819            }
820#else
821            PerlIO_printf(Perl_error_log,
822                          "\t(possibly more locale environment variables)\n");
823#endif
824
825            PerlIO_printf(Perl_error_log,
826                          "\tLANG = %c%s%c\n",
827                          lang ? '"' : '(',
828                          lang ? lang : "unset",
829                          lang ? '"' : ')');
830
831            PerlIO_printf(Perl_error_log,
832                          "    are supported and installed on your system.\n");
833        }
834
835#ifdef LC_ALL
836
837        if (setlocale(LC_ALL, "C")) {
838            if (locwarn)
839                PerlIO_printf(Perl_error_log,
840      "perl: warning: Falling back to the standard locale (\"C\").\n");
841            ok = 0;
842        }
843        else {
844            if (locwarn)
845                PerlIO_printf(Perl_error_log,
846      "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
847            ok = -1;
848        }
849
850#else /* ! LC_ALL */
851
852        if (0
853#ifdef USE_LOCALE_CTYPE
854            || !(curctype || setlocale(LC_CTYPE, "C"))
855#endif /* USE_LOCALE_CTYPE */
856#ifdef USE_LOCALE_COLLATE
857            || !(curcoll || setlocale(LC_COLLATE, "C"))
858#endif /* USE_LOCALE_COLLATE */
859#ifdef USE_LOCALE_NUMERIC
860            || !(curnum || setlocale(LC_NUMERIC, "C"))
861#endif /* USE_LOCALE_NUMERIC */
862            )
863        {
864            if (locwarn)
865                PerlIO_printf(Perl_error_log,
866      "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
867            ok = -1;
868        }
869
870#endif /* ! LC_ALL */
871
872#ifdef USE_LOCALE_CTYPE
873        curctype = savepv(setlocale(LC_CTYPE, Nullch));
874#endif /* USE_LOCALE_CTYPE */
875#ifdef USE_LOCALE_COLLATE
876        curcoll = savepv(setlocale(LC_COLLATE, Nullch));
877#endif /* USE_LOCALE_COLLATE */
878#ifdef USE_LOCALE_NUMERIC
879        curnum = savepv(setlocale(LC_NUMERIC, Nullch));
880#endif /* USE_LOCALE_NUMERIC */
881    }
882    else {
883
884#ifdef USE_LOCALE_CTYPE
885    new_ctype(curctype);
886#endif /* USE_LOCALE_CTYPE */
887
888#ifdef USE_LOCALE_COLLATE
889    new_collate(curcoll);
890#endif /* USE_LOCALE_COLLATE */
891
892#ifdef USE_LOCALE_NUMERIC
893    new_numeric(curnum);
894#endif /* USE_LOCALE_NUMERIC */
895    }
896
897#endif /* USE_LOCALE */
898
899#ifdef USE_LOCALE_CTYPE
900    if (curctype != NULL)
901        Safefree(curctype);
902#endif /* USE_LOCALE_CTYPE */
903#ifdef USE_LOCALE_COLLATE
904    if (curcoll != NULL)
905        Safefree(curcoll);
906#endif /* USE_LOCALE_COLLATE */
907#ifdef USE_LOCALE_NUMERIC
908    if (curnum != NULL)
909        Safefree(curnum);
910#endif /* USE_LOCALE_NUMERIC */
911    return ok;
912}
913
914/* Backwards compatibility. */
915int
916Perl_init_i18nl14n(pTHX_ int printwarn)
917{
918    return init_i18nl10n(printwarn);
919}
920
921#ifdef USE_LOCALE_COLLATE
922
923/*
924 * mem_collxfrm() is a bit like strxfrm() but with two important
925 * differences. First, it handles embedded NULs. Second, it allocates
926 * a bit more memory than needed for the transformed data itself.
927 * The real transformed data begins at offset sizeof(collationix).
928 * Please see sv_collxfrm() to see how this is used.
929 */
930char *
931Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
932{
933    char *xbuf;
934    STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
935
936    /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
937    /* the +1 is for the terminating NUL. */
938
939    xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
940    New(171, xbuf, xAlloc, char);
941    if (! xbuf)
942        goto bad;
943
944    *(U32*)xbuf = PL_collation_ix;
945    xout = sizeof(PL_collation_ix);
946    for (xin = 0; xin < len; ) {
947        SSize_t xused;
948
949        for (;;) {
950            xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
951            if (xused == -1)
952                goto bad;
953            if (xused < xAlloc - xout)
954                break;
955            xAlloc = (2 * xAlloc) + 1;
956            Renew(xbuf, xAlloc, char);
957            if (! xbuf)
958                goto bad;
959        }
960
961        xin += strlen(s + xin) + 1;
962        xout += xused;
963
964        /* Embedded NULs are understood but silently skipped
965         * because they make no sense in locale collation. */
966    }
967
968    xbuf[xout] = '\0';
969    *xlen = xout - sizeof(PL_collation_ix);
970    return xbuf;
971
972  bad:
973    Safefree(xbuf);
974    *xlen = 0;
975    return NULL;
976}
977
978#endif /* USE_LOCALE_COLLATE */
979
980#define FBM_TABLE_OFFSET 2      /* Number of bytes between EOS and table*/
981
982/* As a space optimization, we do not compile tables for strings of length
983   0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
984   special-cased in fbm_instr().
985
986   If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
987
988/*
989=for apidoc fbm_compile
990
991Analyses the string in order to make fast searches on it using fbm_instr()
992-- the Boyer-Moore algorithm.
993
994=cut
995*/
996
997void
998Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
999{
1000    register U8 *s;
1001    register U8 *table;
1002    register U32 i;
1003    STRLEN len;
1004    I32 rarest = 0;
1005    U32 frequency = 256;
1006
1007    if (flags & FBMcf_TAIL)
1008        sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
1009    s = (U8*)SvPV_force(sv, len);
1010    (void)SvUPGRADE(sv, SVt_PVBM);
1011    if (len == 0)               /* TAIL might be on on a zero-length string. */
1012        return;
1013    if (len > 2) {
1014        U8 mlen;
1015        unsigned char *sb;
1016
1017        if (len > 255)
1018            mlen = 255;
1019        else
1020            mlen = (U8)len;
1021        Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
1022        table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
1023        s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
1024        memset((void*)table, mlen, 256);
1025        table[-1] = (U8)flags;
1026        i = 0;
1027        sb = s - mlen + 1;                      /* first char (maybe) */
1028        while (s >= sb) {
1029            if (table[*s] == mlen)
1030                table[*s] = (U8)i;
1031            s--, i++;
1032        }
1033    }
1034    sv_magic(sv, Nullsv, 'B', Nullch, 0);       /* deep magic */
1035    SvVALID_on(sv);
1036
1037    s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
1038    for (i = 0; i < len; i++) {
1039        if (PL_freq[s[i]] < frequency) {
1040            rarest = i;
1041            frequency = PL_freq[s[i]];
1042        }
1043    }
1044    BmRARE(sv) = s[rarest];
1045    BmPREVIOUS(sv) = rarest;
1046    BmUSEFUL(sv) = 100;                 /* Initial value */
1047    if (flags & FBMcf_TAIL)
1048        SvTAIL_on(sv);
1049    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
1050                          BmRARE(sv),BmPREVIOUS(sv)));
1051}
1052
1053/* If SvTAIL(littlestr), it has a fake '\n' at end. */
1054/* If SvTAIL is actually due to \Z or \z, this gives false positives
1055   if multiline */
1056
1057/*
1058=for apidoc fbm_instr
1059
1060Returns the location of the SV in the string delimited by C<str> and
1061C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
1062does not have to be fbm_compiled, but the search will not be as fast
1063then.
1064
1065=cut
1066*/
1067
1068char *
1069Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
1070{
1071    register unsigned char *s;
1072    STRLEN l;
1073    register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
1074    register STRLEN littlelen = l;
1075    register I32 multiline = flags & FBMrf_MULTILINE;
1076
1077    if (bigend - big < littlelen) {
1078        if ( SvTAIL(littlestr)
1079             && (bigend - big == littlelen - 1)
1080             && (littlelen == 1
1081                 || (*big == *little && memEQ(big, little, littlelen - 1))))
1082            return (char*)big;
1083        return Nullch;
1084    }
1085
1086    if (littlelen <= 2) {               /* Special-cased */
1087
1088        if (littlelen == 1) {
1089            if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
1090                /* Know that bigend != big.  */
1091                if (bigend[-1] == '\n')
1092                    return (char *)(bigend - 1);
1093                return (char *) bigend;
1094            }
1095            s = big;
1096            while (s < bigend) {
1097                if (*s == *little)
1098                    return (char *)s;
1099                s++;
1100            }
1101            if (SvTAIL(littlestr))
1102                return (char *) bigend;
1103            return Nullch;
1104        }
1105        if (!littlelen)
1106            return (char*)big;          /* Cannot be SvTAIL! */
1107
1108        /* littlelen is 2 */
1109        if (SvTAIL(littlestr) && !multiline) {
1110            if (bigend[-1] == '\n' && bigend[-2] == *little)
1111                return (char*)bigend - 2;
1112            if (bigend[-1] == *little)
1113                return (char*)bigend - 1;
1114            return Nullch;
1115        }
1116        {
1117            /* This should be better than FBM if c1 == c2, and almost
1118               as good otherwise: maybe better since we do less indirection.
1119               And we save a lot of memory by caching no table. */
1120            register unsigned char c1 = little[0];
1121            register unsigned char c2 = little[1];
1122
1123            s = big + 1;
1124            bigend--;
1125            if (c1 != c2) {
1126                while (s <= bigend) {
1127                    if (s[0] == c2) {
1128                        if (s[-1] == c1)
1129                            return (char*)s - 1;
1130                        s += 2;
1131                        continue;
1132                    }
1133                  next_chars:
1134                    if (s[0] == c1) {
1135                        if (s == bigend)
1136                            goto check_1char_anchor;
1137                        if (s[1] == c2)
1138                            return (char*)s;
1139                        else {
1140                            s++;
1141                            goto next_chars;
1142                        }
1143                    }
1144                    else
1145                        s += 2;
1146                }
1147                goto check_1char_anchor;
1148            }
1149            /* Now c1 == c2 */
1150            while (s <= bigend) {
1151                if (s[0] == c1) {
1152                    if (s[-1] == c1)
1153                        return (char*)s - 1;
1154                    if (s == bigend)
1155                        goto check_1char_anchor;
1156                    if (s[1] == c1)
1157                        return (char*)s;
1158                    s += 3;
1159                }
1160                else
1161                    s += 2;
1162            }
1163        }
1164      check_1char_anchor:               /* One char and anchor! */
1165        if (SvTAIL(littlestr) && (*bigend == *little))
1166            return (char *)bigend;      /* bigend is already decremented. */
1167        return Nullch;
1168    }
1169    if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
1170        s = bigend - littlelen;
1171        if (s >= big && bigend[-1] == '\n' && *s == *little
1172            /* Automatically of length > 2 */
1173            && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1174        {
1175            return (char*)s;            /* how sweet it is */
1176        }
1177        if (s[1] == *little
1178            && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
1179        {
1180            return (char*)s + 1;        /* how sweet it is */
1181        }
1182        return Nullch;
1183    }
1184    if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
1185        char *b = ninstr((char*)big,(char*)bigend,
1186                         (char*)little, (char*)little + littlelen);
1187
1188        if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
1189            /* Chop \n from littlestr: */
1190            s = bigend - littlelen + 1;
1191            if (*s == *little
1192                && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1193            {
1194                return (char*)s;
1195            }
1196            return Nullch;
1197        }
1198        return b;
1199    }
1200   
1201    {   /* Do actual FBM.  */
1202        register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
1203        register unsigned char *oldlittle;
1204
1205        if (littlelen > bigend - big)
1206            return Nullch;
1207        --littlelen;                    /* Last char found by table lookup */
1208
1209        s = big + littlelen;
1210        little += littlelen;            /* last char */
1211        oldlittle = little;
1212        if (s < bigend) {
1213            register I32 tmp;
1214
1215          top2:
1216            /*SUPPRESS 560*/
1217            if ((tmp = table[*s])) {
1218#ifdef POINTERRIGOR
1219                if (bigend - s > tmp) {
1220                    s += tmp;
1221                    goto top2;
1222                }
1223                s += tmp;
1224#else
1225                if ((s += tmp) < bigend)
1226                    goto top2;
1227#endif
1228                goto check_end;
1229            }
1230            else {              /* less expensive than calling strncmp() */
1231                register unsigned char *olds = s;
1232
1233                tmp = littlelen;
1234
1235                while (tmp--) {
1236                    if (*--s == *--little)
1237                        continue;
1238                    s = olds + 1;       /* here we pay the price for failure */
1239                    little = oldlittle;
1240                    if (s < bigend)     /* fake up continue to outer loop */
1241                        goto top2;
1242                    goto check_end;
1243                }
1244                return (char *)s;
1245            }
1246        }
1247      check_end:
1248        if ( s == bigend && (table[-1] & FBMcf_TAIL)
1249             && memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) )
1250            return (char*)bigend - littlelen;
1251        return Nullch;
1252    }
1253}
1254
1255/* start_shift, end_shift are positive quantities which give offsets
1256   of ends of some substring of bigstr.
1257   If `last' we want the last occurence.
1258   old_posp is the way of communication between consequent calls if
1259   the next call needs to find the .
1260   The initial *old_posp should be -1.
1261
1262   Note that we take into account SvTAIL, so one can get extra
1263   optimizations if _ALL flag is set.
1264 */
1265
1266/* If SvTAIL is actually due to \Z or \z, this gives false positives
1267   if PL_multiline.  In fact if !PL_multiline the autoritative answer
1268   is not supported yet. */
1269
1270char *
1271Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
1272{
1273    register unsigned char *s, *x;
1274    register unsigned char *big;
1275    register I32 pos;
1276    register I32 previous;
1277    register I32 first;
1278    register unsigned char *little;
1279    register I32 stop_pos;
1280    register unsigned char *littleend;
1281    I32 found = 0;
1282
1283    if (*old_posp == -1
1284        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
1285        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
1286      cant_find:
1287        if ( BmRARE(littlestr) == '\n'
1288             && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
1289            little = (unsigned char *)(SvPVX(littlestr));
1290            littleend = little + SvCUR(littlestr);
1291            first = *little++;
1292            goto check_tail;
1293        }
1294        return Nullch;
1295    }
1296
1297    little = (unsigned char *)(SvPVX(littlestr));
1298    littleend = little + SvCUR(littlestr);
1299    first = *little++;
1300    /* The value of pos we can start at: */
1301    previous = BmPREVIOUS(littlestr);
1302    big = (unsigned char *)(SvPVX(bigstr));
1303    /* The value of pos we can stop at: */
1304    stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
1305    if (previous + start_shift > stop_pos) {
1306        if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
1307            goto check_tail;
1308        return Nullch;
1309    }
1310    while (pos < previous + start_shift) {
1311        if (!(pos += PL_screamnext[pos]))
1312            goto cant_find;
1313    }
1314#ifdef POINTERRIGOR
1315    do {
1316        if (pos >= stop_pos) break;
1317        if (big[pos-previous] != first)
1318            continue;
1319        for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
1320            if (*s++ != *x++) {
1321                s--;
1322                break;
1323            }
1324        }
1325        if (s == littleend) {
1326            *old_posp = pos;
1327            if (!last) return (char *)(big+pos-previous);
1328            found = 1;
1329        }
1330    } while ( pos += PL_screamnext[pos] );
1331    return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
1332#else /* !POINTERRIGOR */
1333    big -= previous;
1334    do {
1335        if (pos >= stop_pos) break;
1336        if (big[pos] != first)
1337            continue;
1338        for (x=big+pos+1,s=little; s < littleend; /**/ ) {
1339            if (*s++ != *x++) {
1340                s--;
1341                break;
1342            }
1343        }
1344        if (s == littleend) {
1345            *old_posp = pos;
1346            if (!last) return (char *)(big+pos);
1347            found = 1;
1348        }
1349    } while ( pos += PL_screamnext[pos] );
1350    if (last && found)
1351        return (char *)(big+(*old_posp));
1352#endif /* POINTERRIGOR */
1353  check_tail:
1354    if (!SvTAIL(littlestr) || (end_shift > 0))
1355        return Nullch;
1356    /* Ignore the trailing "\n".  This code is not microoptimized */
1357    big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
1358    stop_pos = littleend - little;      /* Actual littlestr len */
1359    if (stop_pos == 0)
1360        return (char*)big;
1361    big -= stop_pos;
1362    if (*big == first
1363        && ((stop_pos == 1) || memEQ(big + 1, little, stop_pos - 1)))
1364        return (char*)big;
1365    return Nullch;
1366}
1367
1368I32
1369Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
1370{
1371    register U8 *a = (U8 *)s1;
1372    register U8 *b = (U8 *)s2;
1373    while (len--) {
1374        if (*a != *b && *a != PL_fold[*b])
1375            return 1;
1376        a++,b++;
1377    }
1378    return 0;
1379}
1380
1381I32
1382Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
1383{
1384    register U8 *a = (U8 *)s1;
1385    register U8 *b = (U8 *)s2;
1386    while (len--) {
1387        if (*a != *b && *a != PL_fold_locale[*b])
1388            return 1;
1389        a++,b++;
1390    }
1391    return 0;
1392}
1393
1394/* copy a string to a safe spot */
1395
1396/*
1397=for apidoc savepv
1398
1399Copy a string to a safe spot.  This does not use an SV.
1400
1401=cut
1402*/
1403
1404char *
1405Perl_savepv(pTHX_ const char *sv)
1406{
1407    register char *newaddr;
1408
1409    New(902,newaddr,strlen(sv)+1,char);
1410    (void)strcpy(newaddr,sv);
1411    return newaddr;
1412}
1413
1414/* same thing but with a known length */
1415
1416/*
1417=for apidoc savepvn
1418
1419Copy a string to a safe spot.  The C<len> indicates number of bytes to
1420copy.  This does not use an SV.
1421
1422=cut
1423*/
1424
1425char *
1426Perl_savepvn(pTHX_ const char *sv, register I32 len)
1427{
1428    register char *newaddr;
1429
1430    New(903,newaddr,len+1,char);
1431    Copy(sv,newaddr,len,char);          /* might not be null terminated */
1432    newaddr[len] = '\0';                /* is now */
1433    return newaddr;
1434}
1435
1436/* the SV for Perl_form() and mess() is not kept in an arena */
1437
1438STATIC SV *
1439S_mess_alloc(pTHX)
1440{
1441    SV *sv;
1442    XPVMG *any;
1443
1444    if (!PL_dirty)
1445        return sv_2mortal(newSVpvn("",0));
1446
1447    if (PL_mess_sv)
1448        return PL_mess_sv;
1449
1450    /* Create as PVMG now, to avoid any upgrading later */
1451    New(905, sv, 1, SV);
1452    Newz(905, any, 1, XPVMG);
1453    SvFLAGS(sv) = SVt_PVMG;
1454    SvANY(sv) = (void*)any;
1455    SvREFCNT(sv) = 1 << 30; /* practically infinite */
1456    PL_mess_sv = sv;
1457    return sv;
1458}
1459
1460#if defined(PERL_IMPLICIT_CONTEXT)
1461char *
1462Perl_form_nocontext(const char* pat, ...)
1463{
1464    dTHX;
1465    char *retval;
1466    va_list args;
1467    va_start(args, pat);
1468    retval = vform(pat, &args);
1469    va_end(args);
1470    return retval;
1471}
1472#endif /* PERL_IMPLICIT_CONTEXT */
1473
1474char *
1475Perl_form(pTHX_ const char* pat, ...)
1476{
1477    char *retval;
1478    va_list args;
1479    va_start(args, pat);
1480    retval = vform(pat, &args);
1481    va_end(args);
1482    return retval;
1483}
1484
1485char *
1486Perl_vform(pTHX_ const char *pat, va_list *args)
1487{
1488    SV *sv = mess_alloc();
1489    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1490    return SvPVX(sv);
1491}
1492
1493#if defined(PERL_IMPLICIT_CONTEXT)
1494SV *
1495Perl_mess_nocontext(const char *pat, ...)
1496{
1497    dTHX;
1498    SV *retval;
1499    va_list args;
1500    va_start(args, pat);
1501    retval = vmess(pat, &args);
1502    va_end(args);
1503    return retval;
1504}
1505#endif /* PERL_IMPLICIT_CONTEXT */
1506
1507SV *
1508Perl_mess(pTHX_ const char *pat, ...)
1509{
1510    SV *retval;
1511    va_list args;
1512    va_start(args, pat);
1513    retval = vmess(pat, &args);
1514    va_end(args);
1515    return retval;
1516}
1517
1518SV *
1519Perl_vmess(pTHX_ const char *pat, va_list *args)
1520{
1521    SV *sv = mess_alloc();
1522    static char dgd[] = " during global destruction.\n";
1523
1524    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1525    if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1526        if (CopLINE(PL_curcop))
1527            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1528                           CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
1529        if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1530            bool line_mode = (RsSIMPLE(PL_rs) &&
1531                              SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1532            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1533                      PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1534                      line_mode ? "line" : "chunk",
1535                      (IV)IoLINES(GvIOp(PL_last_in_gv)));
1536        }
1537#ifdef USE_THREADS
1538        if (thr->tid)
1539            Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1540#endif
1541        sv_catpv(sv, PL_dirty ? dgd : ".\n");
1542    }
1543    return sv;
1544}
1545
1546OP *
1547Perl_vdie(pTHX_ const char* pat, va_list *args)
1548{
1549    char *message;
1550    int was_in_eval = PL_in_eval;
1551    HV *stash;
1552    GV *gv;
1553    CV *cv;
1554    SV *msv;
1555    STRLEN msglen;
1556
1557    DEBUG_S(PerlIO_printf(Perl_debug_log,
1558                          "%p: die: curstack = %p, mainstack = %p\n",
1559                          thr, PL_curstack, PL_mainstack));
1560
1561    if (pat) {
1562        msv = vmess(pat, args);
1563        if (PL_errors && SvCUR(PL_errors)) {
1564            sv_catsv(PL_errors, msv);
1565            message = SvPV(PL_errors, msglen);
1566            SvCUR_set(PL_errors, 0);
1567        }
1568        else
1569            message = SvPV(msv,msglen);
1570    }
1571    else {
1572        message = Nullch;
1573        msglen = 0;
1574    }
1575
1576    DEBUG_S(PerlIO_printf(Perl_debug_log,
1577                          "%p: die: message = %s\ndiehook = %p\n",
1578                          thr, message, PL_diehook));
1579    if (PL_diehook) {
1580        /* sv_2cv might call Perl_croak() */
1581        SV *olddiehook = PL_diehook;
1582        ENTER;
1583        SAVESPTR(PL_diehook);
1584        PL_diehook = Nullsv;
1585        cv = sv_2cv(olddiehook, &stash, &gv, 0);
1586        LEAVE;
1587        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1588            dSP;
1589            SV *msg;
1590
1591            ENTER;
1592            save_re_context();
1593            if (message) {
1594                msg = newSVpvn(message, msglen);
1595                SvREADONLY_on(msg);
1596                SAVEFREESV(msg);
1597            }
1598            else {
1599                msg = ERRSV;
1600            }
1601
1602            PUSHSTACKi(PERLSI_DIEHOOK);
1603            PUSHMARK(SP);
1604            XPUSHs(msg);
1605            PUTBACK;
1606            call_sv((SV*)cv, G_DISCARD);
1607            POPSTACK;
1608            LEAVE;
1609        }
1610    }
1611
1612    PL_restartop = die_where(message, msglen);
1613    DEBUG_S(PerlIO_printf(Perl_debug_log,
1614          "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1615          thr, PL_restartop, was_in_eval, PL_top_env));
1616    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1617        JMPENV_JUMP(3);
1618    return PL_restartop;
1619}
1620
1621#if defined(PERL_IMPLICIT_CONTEXT)
1622OP *
1623Perl_die_nocontext(const char* pat, ...)
1624{
1625    dTHX;
1626    OP *o;
1627    va_list args;
1628    va_start(args, pat);
1629    o = vdie(pat, &args);
1630    va_end(args);
1631    return o;
1632}
1633#endif /* PERL_IMPLICIT_CONTEXT */
1634
1635OP *
1636Perl_die(pTHX_ const char* pat, ...)
1637{
1638    OP *o;
1639    va_list args;
1640    va_start(args, pat);
1641    o = vdie(pat, &args);
1642    va_end(args);
1643    return o;
1644}
1645
1646void
1647Perl_vcroak(pTHX_ const char* pat, va_list *args)
1648{
1649    char *message;
1650    HV *stash;
1651    GV *gv;
1652    CV *cv;
1653    SV *msv;
1654    STRLEN msglen;
1655
1656    if (pat) {
1657        msv = vmess(pat, args);
1658        if (PL_errors && SvCUR(PL_errors)) {
1659            sv_catsv(PL_errors, msv);
1660            message = SvPV(PL_errors, msglen);
1661            SvCUR_set(PL_errors, 0);
1662        }
1663        else
1664            message = SvPV(msv,msglen);
1665    }
1666    else {
1667        message = Nullch;
1668        msglen = 0;
1669    }
1670
1671    DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1672                          PTR2UV(thr), message));
1673
1674    if (PL_diehook) {
1675        /* sv_2cv might call Perl_croak() */
1676        SV *olddiehook = PL_diehook;
1677        ENTER;
1678        SAVESPTR(PL_diehook);
1679        PL_diehook = Nullsv;
1680        cv = sv_2cv(olddiehook, &stash, &gv, 0);
1681        LEAVE;
1682        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1683            dSP;
1684            SV *msg;
1685
1686            ENTER;
1687            save_re_context();
1688            if (message) {
1689                msg = newSVpvn(message, msglen);
1690                SvREADONLY_on(msg);
1691                SAVEFREESV(msg);
1692            }
1693            else {
1694                msg = ERRSV;
1695            }
1696
1697            PUSHSTACKi(PERLSI_DIEHOOK);
1698            PUSHMARK(SP);
1699            XPUSHs(msg);
1700            PUTBACK;
1701            call_sv((SV*)cv, G_DISCARD);
1702            POPSTACK;
1703            LEAVE;
1704        }
1705    }
1706    if (PL_in_eval) {
1707        PL_restartop = die_where(message, msglen);
1708        JMPENV_JUMP(3);
1709    }
1710    {
1711#ifdef USE_SFIO
1712        /* SFIO can really mess with your errno */
1713        int e = errno;
1714#endif
1715        PerlIO *serr = Perl_error_log;
1716
1717        PerlIO_write(serr, message, msglen);
1718        (void)PerlIO_flush(serr);
1719#ifdef USE_SFIO
1720        errno = e;
1721#endif
1722    }
1723    my_failure_exit();
1724}
1725
1726#if defined(PERL_IMPLICIT_CONTEXT)
1727void
1728Perl_croak_nocontext(const char *pat, ...)
1729{
1730    dTHX;
1731    va_list args;
1732    va_start(args, pat);
1733    vcroak(pat, &args);
1734    /* NOTREACHED */
1735    va_end(args);
1736}
1737#endif /* PERL_IMPLICIT_CONTEXT */
1738
1739/*
1740=for apidoc croak
1741
1742This is the XSUB-writer's interface to Perl's C<die> function.
1743Normally use this function the same way you use the C C<printf>
1744function.  See C<warn>.
1745
1746If you want to throw an exception object, assign the object to
1747C<$@> and then pass C<Nullch> to croak():
1748
1749   errsv = get_sv("@", TRUE);
1750   sv_setsv(errsv, exception_object);
1751   croak(Nullch);
1752
1753=cut
1754*/
1755
1756void
1757Perl_croak(pTHX_ const char *pat, ...)
1758{
1759    va_list args;
1760    va_start(args, pat);
1761    vcroak(pat, &args);
1762    /* NOTREACHED */
1763    va_end(args);
1764}
1765
1766void
1767Perl_vwarn(pTHX_ const char* pat, va_list *args)
1768{
1769    char *message;
1770    HV *stash;
1771    GV *gv;
1772    CV *cv;
1773    SV *msv;
1774    STRLEN msglen;
1775
1776    msv = vmess(pat, args);
1777    message = SvPV(msv, msglen);
1778
1779    if (PL_warnhook) {
1780        /* sv_2cv might call Perl_warn() */
1781        SV *oldwarnhook = PL_warnhook;
1782        ENTER;
1783        SAVESPTR(PL_warnhook);
1784        PL_warnhook = Nullsv;
1785        cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1786        LEAVE;
1787        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1788            dSP;
1789            SV *msg;
1790
1791            ENTER;
1792            save_re_context();
1793            msg = newSVpvn(message, msglen);
1794            SvREADONLY_on(msg);
1795            SAVEFREESV(msg);
1796
1797            PUSHSTACKi(PERLSI_WARNHOOK);
1798            PUSHMARK(SP);
1799            XPUSHs(msg);
1800            PUTBACK;
1801            call_sv((SV*)cv, G_DISCARD);
1802            POPSTACK;
1803            LEAVE;
1804            return;
1805        }
1806    }
1807    {
1808        PerlIO *serr = Perl_error_log;
1809
1810        PerlIO_write(serr, message, msglen);
1811#ifdef LEAKTEST
1812        DEBUG_L(*message == '!'
1813                ? (xstat(message[1]=='!'
1814                         ? (message[2]=='!' ? 2 : 1)
1815                         : 0)
1816                   , 0)
1817                : 0);
1818#endif
1819        (void)PerlIO_flush(serr);
1820    }
1821}
1822
1823#if defined(PERL_IMPLICIT_CONTEXT)
1824void
1825Perl_warn_nocontext(const char *pat, ...)
1826{
1827    dTHX;
1828    va_list args;
1829    va_start(args, pat);
1830    vwarn(pat, &args);
1831    va_end(args);
1832}
1833#endif /* PERL_IMPLICIT_CONTEXT */
1834
1835/*
1836=for apidoc warn
1837
1838This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
1839function the same way you use the C C<printf> function.  See
1840C<croak>.
1841
1842=cut
1843*/
1844
1845void
1846Perl_warn(pTHX_ const char *pat, ...)
1847{
1848    va_list args;
1849    va_start(args, pat);
1850    vwarn(pat, &args);
1851    va_end(args);
1852}
1853
1854#if defined(PERL_IMPLICIT_CONTEXT)
1855void
1856Perl_warner_nocontext(U32 err, const char *pat, ...)
1857{
1858    dTHX;
1859    va_list args;
1860    va_start(args, pat);
1861    vwarner(err, pat, &args);
1862    va_end(args);
1863}
1864#endif /* PERL_IMPLICIT_CONTEXT */
1865
1866void
1867Perl_warner(pTHX_ U32  err, const char* pat,...)
1868{
1869    va_list args;
1870    va_start(args, pat);
1871    vwarner(err, pat, &args);
1872    va_end(args);
1873}
1874
1875void
1876Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1877{
1878    char *message;
1879    HV *stash;
1880    GV *gv;
1881    CV *cv;
1882    SV *msv;
1883    STRLEN msglen;
1884
1885    msv = vmess(pat, args);
1886    message = SvPV(msv, msglen);
1887
1888    if (ckDEAD(err)) {
1889#ifdef USE_THREADS
1890        DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1891#endif /* USE_THREADS */
1892        if (PL_diehook) {
1893            /* sv_2cv might call Perl_croak() */
1894            SV *olddiehook = PL_diehook;
1895            ENTER;
1896            SAVESPTR(PL_diehook);
1897            PL_diehook = Nullsv;
1898            cv = sv_2cv(olddiehook, &stash, &gv, 0);
1899            LEAVE;
1900            if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1901                dSP;
1902                SV *msg;
1903 
1904                ENTER;
1905                save_re_context();
1906                msg = newSVpvn(message, msglen);
1907                SvREADONLY_on(msg);
1908                SAVEFREESV(msg);
1909 
1910                PUSHSTACKi(PERLSI_DIEHOOK);
1911                PUSHMARK(sp);
1912                XPUSHs(msg);
1913                PUTBACK;
1914                call_sv((SV*)cv, G_DISCARD);
1915                POPSTACK;
1916                LEAVE;
1917            }
1918        }
1919        if (PL_in_eval) {
1920            PL_restartop = die_where(message, msglen);
1921            JMPENV_JUMP(3);
1922        }
1923        {
1924            PerlIO *serr = Perl_error_log;
1925            PerlIO_write(serr, message, msglen);
1926            (void)PerlIO_flush(serr);
1927        }
1928        my_failure_exit();
1929
1930    }
1931    else {
1932        if (PL_warnhook) {
1933            /* sv_2cv might call Perl_warn() */
1934            SV *oldwarnhook = PL_warnhook;
1935            ENTER;
1936            SAVESPTR(PL_warnhook);
1937            PL_warnhook = Nullsv;
1938            cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1939            LEAVE;
1940            if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1941                dSP;
1942                SV *msg;
1943 
1944                ENTER;
1945                save_re_context();
1946                msg = newSVpvn(message, msglen);
1947                SvREADONLY_on(msg);
1948                SAVEFREESV(msg);
1949 
1950                PUSHSTACKi(PERLSI_WARNHOOK);
1951                PUSHMARK(sp);
1952                XPUSHs(msg);
1953                PUTBACK;
1954                call_sv((SV*)cv, G_DISCARD);
1955                POPSTACK;
1956                LEAVE;
1957                return;
1958            }
1959        }
1960        {
1961            PerlIO *serr = Perl_error_log;
1962            PerlIO_write(serr, message, msglen);
1963#ifdef LEAKTEST
1964            DEBUG_L(*message == '!'
1965                ? (xstat(message[1]=='!'
1966                         ? (message[2]=='!' ? 2 : 1)
1967                         : 0)
1968                   , 0)
1969                : 0);
1970#endif
1971            (void)PerlIO_flush(serr);
1972        }
1973    }
1974}
1975
1976#ifdef USE_ENVIRON_ARRAY
1977       /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
1978#if !defined(WIN32)
1979void
1980Perl_my_setenv(pTHX_ char *nam, char *val)
1981{
1982#ifndef PERL_USE_SAFE_PUTENV
1983    /* most putenv()s leak, so we manipulate environ directly */
1984    register I32 i=setenv_getix(nam);           /* where does it go? */
1985
1986    if (environ == PL_origenviron) {    /* need we copy environment? */
1987        I32 j;
1988        I32 max;
1989        char **tmpenv;
1990
1991        /*SUPPRESS 530*/
1992        for (max = i; environ[max]; max++) ;
1993        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1994        for (j=0; j<max; j++) {         /* copy environment */
1995            tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
1996            strcpy(tmpenv[j], environ[j]);
1997        }
1998        tmpenv[max] = Nullch;
1999        environ = tmpenv;               /* tell exec where it is now */
2000    }
2001    if (!val) {
2002        safesysfree(environ[i]);
2003        while (environ[i]) {
2004            environ[i] = environ[i+1];
2005            i++;
2006        }
2007        return;
2008    }
2009    if (!environ[i]) {                  /* does not exist yet */
2010        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2011        environ[i+1] = Nullch;  /* make sure it's null terminated */
2012    }
2013    else
2014        safesysfree(environ[i]);
2015    environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
2016
2017    (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
2018
2019#else   /* PERL_USE_SAFE_PUTENV */
2020#   if defined(__CYGWIN__)
2021    setenv(nam, val, 1);
2022#   else
2023    char *new_env;
2024
2025    new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
2026    (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
2027    (void)putenv(new_env);
2028#   endif /* __CYGWIN__ */
2029#endif  /* PERL_USE_SAFE_PUTENV */
2030}
2031
2032#else /* WIN32 */
2033
2034void
2035Perl_my_setenv(pTHX_ char *nam,char *val)
2036{
2037    register char *envstr;
2038    STRLEN len = strlen(nam) + 3;
2039    if (!val) {
2040        val = "";
2041    }
2042    len += strlen(val);
2043    New(904, envstr, len, char);
2044    (void)sprintf(envstr,"%s=%s",nam,val);
2045    (void)PerlEnv_putenv(envstr);
2046    Safefree(envstr);
2047}
2048
2049#endif /* WIN32 */
2050
2051I32
2052Perl_setenv_getix(pTHX_ char *nam)
2053{
2054    register I32 i, len = strlen(nam);
2055
2056    for (i = 0; environ[i]; i++) {
2057        if (
2058#ifdef WIN32
2059            strnicmp(environ[i],nam,len) == 0
2060#else
2061            strnEQ(environ[i],nam,len)
2062#endif
2063            && environ[i][len] == '=')
2064            break;                      /* strnEQ must come first to avoid */
2065    }                                   /* potential SEGV's */
2066    return i;
2067}
2068
2069#endif /* !VMS && !EPOC*/
2070
2071#ifdef UNLINK_ALL_VERSIONS
2072I32
2073Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
2074{
2075    I32 i;
2076
2077    for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
2078    return i ? 0 : -1;
2079}
2080#endif
2081
2082/* this is a drop-in replacement for bcopy() */
2083#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
2084char *
2085Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2086{
2087    char *retval = to;
2088
2089    if (from - to >= 0) {
2090        while (len--)
2091            *to++ = *from++;
2092    }
2093    else {
2094        to += len;
2095        from += len;
2096        while (len--)
2097            *(--to) = *(--from);
2098    }
2099    return retval;
2100}
2101#endif
2102
2103/* this is a drop-in replacement for memset() */
2104#ifndef HAS_MEMSET
2105void *
2106Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2107{
2108    char *retval = loc;
2109
2110    while (len--)
2111        *loc++ = ch;
2112    return retval;
2113}
2114#endif
2115
2116/* this is a drop-in replacement for bzero() */
2117#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2118char *
2119Perl_my_bzero(register char *loc, register I32 len)
2120{
2121    char *retval = loc;
2122
2123    while (len--)
2124        *loc++ = 0;
2125    return retval;
2126}
2127#endif
2128
2129/* this is a drop-in replacement for memcmp() */
2130#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2131I32
2132Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2133{
2134    register U8 *a = (U8 *)s1;
2135    register U8 *b = (U8 *)s2;
2136    register I32 tmp;
2137
2138    while (len--) {
2139        if (tmp = *a++ - *b++)
2140            return tmp;
2141    }
2142    return 0;
2143}
2144#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2145
2146#ifndef HAS_VPRINTF
2147
2148#ifdef USE_CHAR_VSPRINTF
2149char *
2150#else
2151int
2152#endif
2153vsprintf(char *dest, const char *pat, char *args)
2154{
2155    FILE fakebuf;
2156
2157    fakebuf._ptr = dest;
2158    fakebuf._cnt = 32767;
2159#ifndef _IOSTRG
2160#define _IOSTRG 0
2161#endif
2162    fakebuf._flag = _IOWRT|_IOSTRG;
2163    _doprnt(pat, args, &fakebuf);       /* what a kludge */
2164    (void)putc('\0', &fakebuf);
2165#ifdef USE_CHAR_VSPRINTF
2166    return(dest);
2167#else
2168    return 0;           /* perl doesn't use return value */
2169#endif
2170}
2171
2172#endif /* HAS_VPRINTF */
2173
2174#ifdef MYSWAP
2175#if BYTEORDER != 0x4321
2176short
2177Perl_my_swap(pTHX_ short s)
2178{
2179#if (BYTEORDER & 1) == 0
2180    short result;
2181
2182    result = ((s & 255) << 8) + ((s >> 8) & 255);
2183    return result;
2184#else
2185    return s;
2186#endif
2187}
2188
2189long
2190Perl_my_htonl(pTHX_ long l)
2191{
2192    union {
2193        long result;
2194        char c[sizeof(long)];
2195    } u;
2196
2197#if BYTEORDER == 0x1234
2198    u.c[0] = (l >> 24) & 255;
2199    u.c[1] = (l >> 16) & 255;
2200    u.c[2] = (l >> 8) & 255;
2201    u.c[3] = l & 255;
2202    return u.result;
2203#else
2204#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2205    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2206#else
2207    register I32 o;
2208    register I32 s;
2209
2210    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2211        u.c[o & 0xf] = (l >> s) & 255;
2212    }
2213    return u.result;
2214#endif
2215#endif
2216}
2217
2218long
2219Perl_my_ntohl(pTHX_ long l)
2220{
2221    union {
2222        long l;
2223        char c[sizeof(long)];
2224    } u;
2225
2226#if BYTEORDER == 0x1234
2227    u.c[0] = (l >> 24) & 255;
2228    u.c[1] = (l >> 16) & 255;
2229    u.c[2] = (l >> 8) & 255;
2230    u.c[3] = l & 255;
2231    return u.l;
2232#else
2233#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2234    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2235#else
2236    register I32 o;
2237    register I32 s;
2238
2239    u.l = l;
2240    l = 0;
2241    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2242        l |= (u.c[o & 0xf] & 255) << s;
2243    }
2244    return l;
2245#endif
2246#endif
2247}
2248
2249#endif /* BYTEORDER != 0x4321 */
2250#endif /* MYSWAP */
2251
2252/*
2253 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2254 * If these functions are defined,
2255 * the BYTEORDER is neither 0x1234 nor 0x4321.
2256 * However, this is not assumed.
2257 * -DWS
2258 */
2259
2260#define HTOV(name,type)                                         \
2261        type                                                    \
2262        name (register type n)                                  \
2263        {                                                       \
2264            union {                                             \
2265                type value;                                     \
2266                char c[sizeof(type)];                           \
2267            } u;                                                \
2268            register I32 i;                                     \
2269            register I32 s;                                     \
2270            for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
2271                u.c[i] = (n >> s) & 0xFF;                       \
2272            }                                                   \
2273            return u.value;                                     \
2274        }
2275
2276#define VTOH(name,type)                                         \
2277        type                                                    \
2278        name (register type n)                                  \
2279        {                                                       \
2280            union {                                             \
2281                type value;                                     \
2282                char c[sizeof(type)];                           \
2283            } u;                                                \
2284            register I32 i;                                     \
2285            register I32 s;                                     \
2286            u.value = n;                                        \
2287            n = 0;                                              \
2288            for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
2289                n += (u.c[i] & 0xFF) << s;                      \
2290            }                                                   \
2291            return n;                                           \
2292        }
2293
2294#if defined(HAS_HTOVS) && !defined(htovs)
2295HTOV(htovs,short)
2296#endif
2297#if defined(HAS_HTOVL) && !defined(htovl)
2298HTOV(htovl,long)
2299#endif
2300#if defined(HAS_VTOHS) && !defined(vtohs)
2301VTOH(vtohs,short)
2302#endif
2303#if defined(HAS_VTOHL) && !defined(vtohl)
2304VTOH(vtohl,long)
2305#endif
2306
2307    /* VMS' my_popen() is in VMS.c, same with OS/2. */
2308#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2309PerlIO *
2310Perl_my_popen(pTHX_ char *cmd, char *mode)
2311{
2312    int p[2];
2313    register I32 This, that;
2314    register Pid_t pid;
2315    SV *sv;
2316    I32 doexec = strNE(cmd,"-");
2317    I32 did_pipes = 0;
2318    int pp[2];
2319
2320    PERL_FLUSHALL_FOR_CHILD;
2321#ifdef OS2
2322    if (doexec) {
2323        return my_syspopen(aTHX_ cmd,mode);
2324    }
2325#endif
2326    This = (*mode == 'w');
2327    that = !This;
2328    if (doexec && PL_tainting) {
2329        taint_env();
2330        taint_proper("Insecure %s%s", "EXEC");
2331    }
2332    if (PerlProc_pipe(p) < 0)
2333        return Nullfp;
2334    if (doexec && PerlProc_pipe(pp) >= 0)
2335        did_pipes = 1;
2336    while ((pid = (doexec?vfork():fork())) < 0) {
2337        if (errno != EAGAIN) {
2338            PerlLIO_close(p[This]);
2339            if (did_pipes) {
2340                PerlLIO_close(pp[0]);
2341                PerlLIO_close(pp[1]);
2342            }
2343            if (!doexec)
2344                Perl_croak(aTHX_ "Can't fork");
2345            return Nullfp;
2346        }
2347        sleep(5);
2348    }
2349    if (pid == 0) {
2350        GV* tmpgv;
2351
2352#undef THIS
2353#undef THAT
2354#define THIS that
2355#define THAT This
2356        PerlLIO_close(p[THAT]);
2357        if (did_pipes) {
2358            PerlLIO_close(pp[0]);
2359#if defined(HAS_FCNTL) && defined(F_SETFD)
2360            fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2361#endif
2362        }
2363        if (p[THIS] != (*mode == 'r')) {
2364            PerlLIO_dup2(p[THIS], *mode == 'r');
2365            PerlLIO_close(p[THIS]);
2366        }
2367#ifndef OS2
2368        if (doexec) {
2369#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2370            int fd;
2371
2372#ifndef NOFILE
2373#define NOFILE 20
2374#endif
2375            for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2376                if (fd != pp[1])
2377                    PerlLIO_close(fd);
2378#endif
2379            do_exec3(cmd,pp[1],did_pipes);      /* may or may not use the shell */
2380            PerlProc__exit(1);
2381        }
2382#endif  /* defined OS2 */
2383        /*SUPPRESS 560*/
2384        if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
2385            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2386        PL_forkprocess = 0;
2387        hv_clear(PL_pidstatus); /* we have no children */
2388        return Nullfp;
2389#undef THIS
2390#undef THAT
2391    }
2392    do_execfree();      /* free any memory malloced by child on vfork */
2393    PerlLIO_close(p[that]);
2394    if (did_pipes)
2395        PerlLIO_close(pp[1]);
2396    if (p[that] < p[This]) {
2397        PerlLIO_dup2(p[This], p[that]);
2398        PerlLIO_close(p[This]);
2399        p[This] = p[that];
2400    }
2401    LOCK_FDPID_MUTEX;
2402    sv = *av_fetch(PL_fdpid,p[This],TRUE);
2403    UNLOCK_FDPID_MUTEX;
2404    (void)SvUPGRADE(sv,SVt_IV);
2405    SvIVX(sv) = pid;
2406    PL_forkprocess = pid;
2407    if (did_pipes && pid > 0) {
2408        int errkid;
2409        int n = 0, n1;
2410
2411        while (n < sizeof(int)) {
2412            n1 = PerlLIO_read(pp[0],
2413                              (void*)(((char*)&errkid)+n),
2414                              (sizeof(int)) - n);
2415            if (n1 <= 0)
2416                break;
2417            n += n1;
2418        }
2419        PerlLIO_close(pp[0]);
2420        did_pipes = 0;
2421        if (n) {                        /* Error */
2422            if (n != sizeof(int))
2423                Perl_croak(aTHX_ "panic: kid popen errno read");
2424            errno = errkid;             /* Propagate errno from kid */
2425            return Nullfp;
2426        }
2427    }
2428    if (did_pipes)
2429         PerlLIO_close(pp[0]);
2430    return PerlIO_fdopen(p[This], mode);
2431}
2432#else
2433#if defined(atarist) || defined(DJGPP)
2434FILE *popen();
2435PerlIO *
2436Perl_my_popen(pTHX_ char *cmd, char *mode)
2437{
2438    /* Needs work for PerlIO ! */
2439    /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
2440    PERL_FLUSHALL_FOR_CHILD;
2441    return popen(PerlIO_exportFILE(cmd, 0), mode);
2442}
2443#endif
2444
2445#endif /* !DOSISH */
2446
2447#ifdef DUMP_FDS
2448void
2449Perl_dump_fds(pTHX_ char *s)
2450{
2451    int fd;
2452    struct stat tmpstatbuf;
2453
2454    PerlIO_printf(Perl_debug_log,"%s", s);
2455    for (fd = 0; fd < 32; fd++) {
2456        if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2457            PerlIO_printf(Perl_debug_log," %d",fd);
2458    }
2459    PerlIO_printf(Perl_debug_log,"\n");
2460}
2461#endif  /* DUMP_FDS */
2462
2463#ifndef HAS_DUP2
2464int
2465dup2(int oldfd, int newfd)
2466{
2467#if defined(HAS_FCNTL) && defined(F_DUPFD)
2468    if (oldfd == newfd)
2469        return oldfd;
2470    PerlLIO_close(newfd);
2471    return fcntl(oldfd, F_DUPFD, newfd);
2472#else
2473#define DUP2_MAX_FDS 256
2474    int fdtmp[DUP2_MAX_FDS];
2475    I32 fdx = 0;
2476    int fd;
2477
2478    if (oldfd == newfd)
2479        return oldfd;
2480    PerlLIO_close(newfd);
2481    /* good enough for low fd's... */
2482    while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2483        if (fdx >= DUP2_MAX_FDS) {
2484            PerlLIO_close(fd);
2485            fd = -1;
2486            break;
2487        }
2488        fdtmp[fdx++] = fd;
2489    }
2490    while (fdx > 0)
2491        PerlLIO_close(fdtmp[--fdx]);
2492    return fd;
2493#endif
2494}
2495#endif
2496
2497
2498#ifdef HAS_SIGACTION
2499
2500Sighandler_t
2501Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2502{
2503    struct sigaction act, oact;
2504
2505    act.sa_handler = handler;
2506    sigemptyset(&act.sa_mask);
2507    act.sa_flags = 0;
2508#ifdef SA_RESTART
2509    act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2510#endif
2511#ifdef SA_NOCLDWAIT
2512    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2513        act.sa_flags |= SA_NOCLDWAIT;
2514#endif
2515    if (sigaction(signo, &act, &oact) == -1)
2516        return SIG_ERR;
2517    else
2518        return oact.sa_handler;
2519}
2520
2521Sighandler_t
2522Perl_rsignal_state(pTHX_ int signo)
2523{
2524    struct sigaction oact;
2525
2526    if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2527        return SIG_ERR;
2528    else
2529        return oact.sa_handler;
2530}
2531
2532int
2533Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2534{
2535    struct sigaction act;
2536
2537    act.sa_handler = handler;
2538    sigemptyset(&act.sa_mask);
2539    act.sa_flags = 0;
2540#ifdef SA_RESTART
2541    act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2542#endif
2543#ifdef SA_NOCLDWAIT
2544    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2545        act.sa_flags |= SA_NOCLDWAIT;
2546#endif
2547    return sigaction(signo, &act, save);
2548}
2549
2550int
2551Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2552{
2553    return sigaction(signo, save, (struct sigaction *)NULL);
2554}
2555
2556#else /* !HAS_SIGACTION */
2557
2558Sighandler_t
2559Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2560{
2561    return PerlProc_signal(signo, handler);
2562}
2563
2564static int sig_trapped;
2565
2566static
2567Signal_t
2568sig_trap(int signo)
2569{
2570    sig_trapped++;
2571}
2572
2573Sighandler_t
2574Perl_rsignal_state(pTHX_ int signo)
2575{
2576    Sighandler_t oldsig;
2577
2578    sig_trapped = 0;
2579    oldsig = PerlProc_signal(signo, sig_trap);
2580    PerlProc_signal(signo, oldsig);
2581    if (sig_trapped)
2582        PerlProc_kill(PerlProc_getpid(), signo);
2583    return oldsig;
2584}
2585
2586int
2587Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2588{
2589    *save = PerlProc_signal(signo, handler);
2590    return (*save == SIG_ERR) ? -1 : 0;
2591}
2592
2593int
2594Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2595{
2596    return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2597}
2598
2599#endif /* !HAS_SIGACTION */
2600
2601    /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2602#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2603I32
2604Perl_my_pclose(pTHX_ PerlIO *ptr)
2605{
2606    Sigsave_t hstat, istat, qstat;
2607    int status;
2608    SV **svp;
2609    Pid_t pid;
2610    Pid_t pid2;
2611    bool close_failed;
2612    int saved_errno;
2613#ifdef VMS
2614    int saved_vaxc_errno;
2615#endif
2616#ifdef WIN32
2617    int saved_win32_errno;
2618#endif
2619
2620    LOCK_FDPID_MUTEX;
2621    svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2622    UNLOCK_FDPID_MUTEX;
2623    pid = SvIVX(*svp);
2624    SvREFCNT_dec(*svp);
2625    *svp = &PL_sv_undef;
2626#ifdef OS2
2627    if (pid == -1) {                    /* Opened by popen. */
2628        return my_syspclose(ptr);
2629    }
2630#endif
2631    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2632        saved_errno = errno;
2633#ifdef VMS
2634        saved_vaxc_errno = vaxc$errno;
2635#endif
2636#ifdef WIN32
2637        saved_win32_errno = GetLastError();
2638#endif
2639    }
2640#ifdef UTS
2641    if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2642#endif
2643    rsignal_save(SIGHUP, SIG_IGN, &hstat);
2644    rsignal_save(SIGINT, SIG_IGN, &istat);
2645    rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2646    do {
2647        pid2 = wait4pid(pid, &status, 0);
2648    } while (pid2 == -1 && errno == EINTR);
2649    rsignal_restore(SIGHUP, &hstat);
2650    rsignal_restore(SIGINT, &istat);
2651    rsignal_restore(SIGQUIT, &qstat);
2652    if (close_failed) {
2653        SETERRNO(saved_errno, saved_vaxc_errno);
2654        return -1;
2655    }
2656    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2657}
2658#endif /* !DOSISH */
2659
2660#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
2661I32
2662Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2663{
2664    SV *sv;
2665    SV** svp;
2666    char spid[TYPE_CHARS(int)];
2667
2668    if (!pid)
2669        return -1;
2670#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2671    if (pid > 0) {
2672        sprintf(spid, "%"IVdf, (IV)pid);
2673        svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2674        if (svp && *svp != &PL_sv_undef) {
2675            *statusp = SvIVX(*svp);
2676            (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2677            return pid;
2678        }
2679    }
2680    else {
2681        HE *entry;
2682
2683        hv_iterinit(PL_pidstatus);
2684        if ((entry = hv_iternext(PL_pidstatus))) {
2685            pid = atoi(hv_iterkey(entry,(I32*)statusp));
2686            sv = hv_iterval(PL_pidstatus,entry);
2687            *statusp = SvIVX(sv);
2688            sprintf(spid, "%"IVdf, (IV)pid);
2689            (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2690            return pid;
2691        }
2692    }
2693#endif
2694#ifdef HAS_WAITPID
2695#  ifdef HAS_WAITPID_RUNTIME
2696    if (!HAS_WAITPID_RUNTIME)
2697        goto hard_way;
2698#  endif
2699    return PerlProc_waitpid(pid,statusp,flags);
2700#endif
2701#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2702    return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2703#endif
2704#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2705  hard_way:
2706    {
2707        I32 result;
2708        if (flags)
2709            Perl_croak(aTHX_ "Can't do waitpid with flags");
2710        else {
2711            while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2712                pidgone(result,*statusp);
2713            if (result < 0)
2714                *statusp = -1;
2715        }
2716        return result;
2717    }
2718#endif
2719}
2720#endif /* !DOSISH || OS2 || WIN32 */
2721
2722void
2723/*SUPPRESS 590*/
2724Perl_pidgone(pTHX_ Pid_t pid, int status)
2725{
2726    register SV *sv;
2727    char spid[TYPE_CHARS(int)];
2728
2729    sprintf(spid, "%"IVdf, (IV)pid);
2730    sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2731    (void)SvUPGRADE(sv,SVt_IV);
2732    SvIVX(sv) = status;
2733    return;
2734}
2735
2736#if defined(atarist) || defined(OS2) || defined(DJGPP)
2737int pclose();
2738#ifdef HAS_FORK
2739int                                     /* Cannot prototype with I32
2740                                           in os2ish.h. */
2741my_syspclose(PerlIO *ptr)
2742#else
2743I32
2744Perl_my_pclose(pTHX_ PerlIO *ptr)
2745#endif
2746{
2747    /* Needs work for PerlIO ! */
2748    FILE *f = PerlIO_findFILE(ptr);
2749    I32 result = pclose(f);
2750#if defined(DJGPP)
2751    result = (result << 8) & 0xff00;
2752#endif
2753    PerlIO_releaseFILE(ptr,f);
2754    return result;
2755}
2756#endif
2757
2758void
2759Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2760{
2761    register I32 todo;
2762    register const char *frombase = from;
2763
2764    if (len == 1) {
2765        register const char c = *from;
2766        while (count-- > 0)
2767            *to++ = c;
2768        return;
2769    }
2770    while (count-- > 0) {
2771        for (todo = len; todo > 0; todo--) {
2772            *to++ = *from++;
2773        }
2774        from = frombase;
2775    }
2776}
2777
2778U32
2779Perl_cast_ulong(pTHX_ NV f)
2780{
2781    long along;
2782
2783#if CASTFLAGS & 2
2784#   define BIGDOUBLE 2147483648.0
2785    if (f >= BIGDOUBLE)
2786        return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
2787#endif
2788    if (f >= 0.0)
2789        return (unsigned long)f;
2790    along = (long)f;
2791    return (unsigned long)along;
2792}
2793# undef BIGDOUBLE
2794
2795/* Unfortunately, on some systems the cast_uv() function doesn't
2796   work with the system-supplied definition of ULONG_MAX.  The
2797   comparison  (f >= ULONG_MAX) always comes out true.  It must be a
2798   problem with the compiler constant folding.
2799
2800   In any case, this workaround should be fine on any two's complement
2801   system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2802   ccflags.
2803               --Andy Dougherty      <doughera@lafcol.lafayette.edu>
2804*/
2805
2806/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2807   of LONG_(MIN/MAX).
2808                           -- Kenneth Albanowski <kjahds@kjahds.com>
2809*/                                     
2810
2811#ifndef MY_UV_MAX
2812#  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
2813#endif
2814
2815I32
2816Perl_cast_i32(pTHX_ NV f)
2817{
2818    if (f >= I32_MAX)
2819        return (I32) I32_MAX;
2820    if (f <= I32_MIN)
2821        return (I32) I32_MIN;
2822    return (I32) f;
2823}
2824
2825IV
2826Perl_cast_iv(pTHX_ NV f)
2827{
2828    if (f >= IV_MAX) {
2829        UV uv;
2830       
2831        if (f >= (NV)UV_MAX)
2832            return (IV) UV_MAX;
2833        uv = (UV) f;
2834        return (IV)uv;
2835    }
2836    if (f <= IV_MIN)
2837        return (IV) IV_MIN;
2838    return (IV) f;
2839}
2840
2841UV
2842Perl_cast_uv(pTHX_ NV f)
2843{
2844    if (f >= MY_UV_MAX)
2845        return (UV) MY_UV_MAX;
2846    if (f < 0) {
2847        IV iv;
2848       
2849        if (f < IV_MIN)
2850            return (UV)IV_MIN;
2851        iv = (IV) f;
2852        return (UV) iv;
2853    }
2854    return (UV) f;
2855}
2856
2857#ifndef HAS_RENAME
2858I32
2859Perl_same_dirent(pTHX_ char *a, char *b)
2860{
2861    char *fa = strrchr(a,'/');
2862    char *fb = strrchr(b,'/');
2863    struct stat tmpstatbuf1;
2864    struct stat tmpstatbuf2;
2865    SV *tmpsv = sv_newmortal();
2866
2867    if (fa)
2868        fa++;
2869    else
2870        fa = a;
2871    if (fb)
2872        fb++;
2873    else
2874        fb = b;
2875    if (strNE(a,b))
2876        return FALSE;
2877    if (fa == a)
2878        sv_setpv(tmpsv, ".");
2879    else
2880        sv_setpvn(tmpsv, a, fa - a);
2881    if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2882        return FALSE;
2883    if (fb == b)
2884        sv_setpv(tmpsv, ".");
2885    else
2886        sv_setpvn(tmpsv, b, fb - b);
2887    if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2888        return FALSE;
2889    return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2890           tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2891}
2892#endif /* !HAS_RENAME */
2893
2894NV
2895Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
2896{
2897    register char *s = start;
2898    register NV rnv = 0.0;
2899    register UV ruv = 0;
2900    register bool seenb = FALSE;
2901    register bool overflowed = FALSE;
2902
2903    for (; len-- && *s; s++) {
2904        if (!(*s == '0' || *s == '1')) {
2905            if (*s == '_' && len && *retlen
2906                && (s[1] == '0' || s[1] == '1'))
2907            {
2908                --len;
2909                ++s;
2910            }
2911            else if (seenb == FALSE && *s == 'b' && ruv == 0) {
2912                /* Disallow 0bbb0b0bbb... */
2913                seenb = TRUE;
2914                continue;
2915            }
2916            else {
2917                if (ckWARN(WARN_DIGIT))
2918                    Perl_warner(aTHX_ WARN_DIGIT,
2919                                "Illegal binary digit '%c' ignored", *s);
2920                break;
2921            }
2922        }
2923        if (!overflowed) {
2924            register UV xuv = ruv << 1;
2925
2926            if ((xuv >> 1) != ruv) {
2927                overflowed = TRUE;
2928                rnv = (NV) ruv;
2929                if (ckWARN_d(WARN_OVERFLOW))
2930                    Perl_warner(aTHX_ WARN_OVERFLOW,
2931                                "Integer overflow in binary number");
2932            }
2933            else
2934                ruv = xuv | (*s - '0');
2935        }
2936        if (overflowed) {
2937            rnv *= 2;
2938            /* If an NV has not enough bits in its mantissa to
2939             * represent an UV this summing of small low-order numbers
2940             * is a waste of time (because the NV cannot preserve
2941             * the low-order bits anyway): we could just remember when
2942             * did we overflow and in the end just multiply rnv by the
2943             * right amount. */
2944            rnv += (*s - '0');
2945        }
2946    }
2947    if (!overflowed)
2948        rnv = (NV) ruv;
2949    if (   ( overflowed && rnv > 4294967295.0)
2950#if UVSIZE > 4
2951        || (!overflowed && ruv > 0xffffffff  )
2952#endif
2953        ) {
2954        if (ckWARN(WARN_PORTABLE))
2955            Perl_warner(aTHX_ WARN_PORTABLE,
2956                        "Binary number > 0b11111111111111111111111111111111 non-portable");
2957    }
2958    *retlen = s - start;
2959    return rnv;
2960}
2961
2962NV
2963Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
2964{
2965    register char *s = start;
2966    register NV rnv = 0.0;
2967    register UV ruv = 0;
2968    register bool overflowed = FALSE;
2969
2970    for (; len-- && *s; s++) {
2971        if (!(*s >= '0' && *s <= '7')) {
2972            if (*s == '_' && len && *retlen
2973                && (s[1] >= '0' && s[1] <= '7'))
2974            {
2975                --len;
2976                ++s;
2977            }
2978            else {
2979                /* Allow \octal to work the DWIM way (that is, stop scanning
2980                 * as soon as non-octal characters are seen, complain only iff
2981                 * someone seems to want to use the digits eight and nine). */
2982                if (*s == '8' || *s == '9') {
2983                    if (ckWARN(WARN_DIGIT))
2984                        Perl_warner(aTHX_ WARN_DIGIT,
2985                                    "Illegal octal digit '%c' ignored", *s);
2986                }
2987                break;
2988            }
2989        }
2990        if (!overflowed) {
2991            register UV xuv = ruv << 3;
2992
2993            if ((xuv >> 3) != ruv) {
2994                overflowed = TRUE;
2995                rnv = (NV) ruv;
2996                if (ckWARN_d(WARN_OVERFLOW))
2997                    Perl_warner(aTHX_ WARN_OVERFLOW,
2998                                "Integer overflow in octal number");
2999            }
3000            else
3001                ruv = xuv | (*s - '0');
3002        }
3003        if (overflowed) {
3004            rnv *= 8.0;
3005            /* If an NV has not enough bits in its mantissa to
3006             * represent an UV this summing of small low-order numbers
3007             * is a waste of time (because the NV cannot preserve
3008             * the low-order bits anyway): we could just remember when
3009             * did we overflow and in the end just multiply rnv by the
3010             * right amount of 8-tuples. */
3011            rnv += (NV)(*s - '0');
3012        }
3013    }
3014    if (!overflowed)
3015        rnv = (NV) ruv;
3016    if (   ( overflowed && rnv > 4294967295.0)
3017#if UVSIZE > 4
3018        || (!overflowed && ruv > 0xffffffff  )
3019#endif
3020        ) {
3021        if (ckWARN(WARN_PORTABLE))
3022            Perl_warner(aTHX_ WARN_PORTABLE,
3023                        "Octal number > 037777777777 non-portable");
3024    }
3025    *retlen = s - start;
3026    return rnv;
3027}
3028
3029NV
3030Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
3031{
3032    register char *s = start;
3033    register NV rnv = 0.0;
3034    register UV ruv = 0;
3035    register bool seenx = FALSE;
3036    register bool overflowed = FALSE;
3037    char *hexdigit;
3038
3039    for (; len-- && *s; s++) {
3040        hexdigit = strchr((char *) PL_hexdigit, *s);
3041        if (!hexdigit) {
3042            if (*s == '_' && len && *retlen && s[1]
3043                && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
3044            {
3045                --len;
3046                ++s;
3047            }
3048            else if (seenx == FALSE && *s == 'x' && ruv == 0) {
3049                /* Disallow 0xxx0x0xxx... */
3050                seenx = TRUE;
3051                continue;
3052            }
3053            else {
3054                if (ckWARN(WARN_DIGIT))
3055                    Perl_warner(aTHX_ WARN_DIGIT,
3056                                "Illegal hexadecimal digit '%c' ignored", *s);
3057                break;
3058            }
3059        }
3060        if (!overflowed) {
3061            register UV xuv = ruv << 4;
3062
3063            if ((xuv >> 4) != ruv) {
3064                overflowed = TRUE;
3065                rnv = (NV) ruv;
3066                if (ckWARN_d(WARN_OVERFLOW))
3067                    Perl_warner(aTHX_ WARN_OVERFLOW,
3068                                "Integer overflow in hexadecimal number");
3069            }
3070            else
3071                ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
3072        }
3073        if (overflowed) {
3074            rnv *= 16.0;
3075            /* If an NV has not enough bits in its mantissa to
3076             * represent an UV this summing of small low-order numbers
3077             * is a waste of time (because the NV cannot preserve
3078             * the low-order bits anyway): we could just remember when
3079             * did we overflow and in the end just multiply rnv by the
3080             * right amount of 16-tuples. */
3081            rnv += (NV)((hexdigit - PL_hexdigit) & 15);
3082        }
3083    }
3084    if (!overflowed)
3085        rnv = (NV) ruv;
3086    if (   ( overflowed && rnv > 4294967295.0)
3087#if UVSIZE > 4
3088        || (!overflowed && ruv > 0xffffffff  )
3089#endif
3090        ) {
3091        if (ckWARN(WARN_PORTABLE))
3092            Perl_warner(aTHX_ WARN_PORTABLE,
3093                        "Hexadecimal number > 0xffffffff non-portable");
3094    }
3095    *retlen = s - start;
3096    return rnv;
3097}
3098
3099char*
3100Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
3101{
3102    char *xfound = Nullch;
3103    char *xfailed = Nullch;
3104    char tmpbuf[MAXPATHLEN];
3105    register char *s;
3106    I32 len;
3107    int retval;
3108#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3109#  define SEARCH_EXTS ".bat", ".cmd", NULL
3110#  define MAX_EXT_LEN 4
3111#endif
3112#ifdef OS2
3113#  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3114#  define MAX_EXT_LEN 4
3115#endif
3116#ifdef VMS
3117#  define SEARCH_EXTS ".pl", ".com", NULL
3118#  define MAX_EXT_LEN 4
3119#endif
3120    /* additional extensions to try in each dir if scriptname not found */
3121#ifdef SEARCH_EXTS
3122    char *exts[] = { SEARCH_EXTS };
3123    char **ext = search_ext ? search_ext : exts;
3124    int extidx = 0, i = 0;
3125    char *curext = Nullch;
3126#else
3127#  define MAX_EXT_LEN 0
3128#endif
3129
3130    /*
3131     * If dosearch is true and if scriptname does not contain path
3132     * delimiters, search the PATH for scriptname.
3133     *
3134     * If SEARCH_EXTS is also defined, will look for each
3135     * scriptname{SEARCH_EXTS} whenever scriptname is not found
3136     * while searching the PATH.
3137     *
3138     * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3139     * proceeds as follows:
3140     *   If DOSISH or VMSISH:
3141     *     + look for ./scriptname{,.foo,.bar}
3142     *     + search the PATH for scriptname{,.foo,.bar}
3143     *
3144     *   If !DOSISH:
3145     *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3146     *       this will not look in '.' if it's not in the PATH)
3147     */
3148    tmpbuf[0] = '\0';
3149
3150#ifdef VMS
3151#  ifdef ALWAYS_DEFTYPES
3152    len = strlen(scriptname);
3153    if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3154        int hasdir, idx = 0, deftypes = 1;
3155        bool seen_dot = 1;
3156
3157        hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
3158#  else
3159    if (dosearch) {
3160        int hasdir, idx = 0, deftypes = 1;
3161        bool seen_dot = 1;
3162
3163        hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
3164#  endif
3165        /* The first time through, just add SEARCH_EXTS to whatever we
3166         * already have, so we can check for default file types. */
3167        while (deftypes ||
3168               (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3169        {
3170            if (deftypes) {
3171                deftypes = 0;
3172                *tmpbuf = '\0';
3173            }
3174            if ((strlen(tmpbuf) + strlen(scriptname)
3175                 + MAX_EXT_LEN) >= sizeof tmpbuf)
3176                continue;       /* don't search dir with too-long name */
3177            strcat(tmpbuf, scriptname);
3178#else  /* !VMS */
3179
3180#ifdef DOSISH
3181    if (strEQ(scriptname, "-"))
3182        dosearch = 0;
3183    if (dosearch) {             /* Look in '.' first. */
3184        char *cur = scriptname;
3185#ifdef SEARCH_EXTS
3186        if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3187            while (ext[i])
3188                if (strEQ(ext[i++],curext)) {
3189                    extidx = -1;                /* already has an ext */
3190                    break;
3191                }
3192        do {
3193#endif
3194            DEBUG_p(PerlIO_printf(Perl_debug_log,
3195                                  "Looking for %s\n",cur));
3196            if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3197                && !S_ISDIR(PL_statbuf.st_mode)) {
3198                dosearch = 0;
3199                scriptname = cur;
3200#ifdef SEARCH_EXTS
3201                break;
3202#endif
3203            }
3204#ifdef SEARCH_EXTS
3205            if (cur == scriptname) {
3206                len = strlen(scriptname);
3207                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3208                    break;
3209                cur = strcpy(tmpbuf, scriptname);
3210            }
3211        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3212                 && strcpy(tmpbuf+len, ext[extidx++]));
3213#endif
3214    }
3215#endif
3216
3217#ifdef MACOS_TRADITIONAL
3218    if (dosearch && !strchr(scriptname, ':') &&
3219        (s = PerlEnv_getenv("Commands")))
3220#else
3221    if (dosearch && !strchr(scriptname, '/')
3222#ifdef DOSISH
3223                 && !strchr(scriptname, '\\')
3224#endif
3225                 && (s = PerlEnv_getenv("PATH")))
3226#endif
3227    {
3228        bool seen_dot = 0;
3229       
3230        PL_bufend = s + strlen(s);
3231        while (s < PL_bufend) {
3232#ifdef MACOS_TRADITIONAL
3233            s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3234                        ',',
3235                        &len);
3236#else
3237#if defined(atarist) || defined(DOSISH)
3238            for (len = 0; *s
3239#  ifdef atarist
3240                    && *s != ','
3241#  endif
3242                    && *s != ';'; len++, s++) {
3243                if (len < sizeof tmpbuf)
3244                    tmpbuf[len] = *s;
3245            }
3246            if (len < sizeof tmpbuf)
3247                tmpbuf[len] = '\0';
3248#else  /* ! (atarist || DOSISH) */
3249            s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3250                        ':',
3251                        &len);
3252#endif /* ! (atarist || DOSISH) */
3253#endif /* MACOS_TRADITIONAL */
3254            if (s < PL_bufend)
3255                s++;
3256            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3257                continue;       /* don't search dir with too-long name */
3258#ifdef MACOS_TRADITIONAL
3259            if (len && tmpbuf[len - 1] != ':')
3260                tmpbuf[len++] = ':';
3261#else
3262            if (len
3263#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3264                && tmpbuf[len - 1] != '/'
3265                && tmpbuf[len - 1] != '\\'
3266#endif
3267               )
3268                tmpbuf[len++] = '/';
3269            if (len == 2 && tmpbuf[0] == '.')
3270                seen_dot = 1;
3271#endif
3272            (void)strcpy(tmpbuf + len, scriptname);
3273#endif  /* !VMS */
3274
3275#ifdef SEARCH_EXTS
3276            len = strlen(tmpbuf);
3277            if (extidx > 0)     /* reset after previous loop */
3278                extidx = 0;
3279            do {
3280#endif
3281                DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3282                retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3283                if (S_ISDIR(PL_statbuf.st_mode)) {
3284                    retval = -1;
3285                }
3286#ifdef SEARCH_EXTS
3287            } while (  retval < 0               /* not there */
3288                    && extidx>=0 && ext[extidx] /* try an extension? */
3289                    && strcpy(tmpbuf+len, ext[extidx++])
3290                );
3291#endif
3292            if (retval < 0)
3293                continue;
3294            if (S_ISREG(PL_statbuf.st_mode)
3295                && cando(S_IRUSR,TRUE,&PL_statbuf)
3296#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3297                && cando(S_IXUSR,TRUE,&PL_statbuf)
3298#endif
3299                )
3300            {
3301                xfound = tmpbuf;              /* bingo! */
3302                break;
3303            }
3304            if (!xfailed)
3305                xfailed = savepv(tmpbuf);
3306        }
3307#ifndef DOSISH
3308        if (!xfound && !seen_dot && !xfailed &&
3309            (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3310             || S_ISDIR(PL_statbuf.st_mode)))
3311#endif
3312            seen_dot = 1;                       /* Disable message. */
3313        if (!xfound) {
3314            if (flags & 1) {                    /* do or die? */
3315                Perl_croak(aTHX_ "Can't %s %s%s%s",
3316                      (xfailed ? "execute" : "find"),
3317                      (xfailed ? xfailed : scriptname),
3318                      (xfailed ? "" : " on PATH"),
3319                      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3320            }
3321            scriptname = Nullch;
3322        }
3323        if (xfailed)
3324            Safefree(xfailed);
3325        scriptname = xfound;
3326    }
3327    return (scriptname ? savepv(scriptname) : Nullch);
3328}
3329
3330#ifndef PERL_GET_CONTEXT_DEFINED
3331
3332void *
3333Perl_get_context(void)
3334{
3335#if defined(USE_THREADS) || defined(USE_ITHREADS)
3336#  ifdef OLD_PTHREADS_API
3337    pthread_addr_t t;
3338    if (pthread_getspecific(PL_thr_key, &t))
3339        Perl_croak_nocontext("panic: pthread_getspecific");
3340    return (void*)t;
3341#  else
3342#  ifdef I_MACH_CTHREADS
3343    return (void*)cthread_data(cthread_self());
3344#  else
3345    return (void*)pthread_getspecific(PL_thr_key);
3346#  endif
3347#  endif
3348#else
3349    return (void*)NULL;
3350#endif
3351}
3352
3353void
3354Perl_set_context(void *t)
3355{
3356#if defined(USE_THREADS) || defined(USE_ITHREADS)
3357#  ifdef I_MACH_CTHREADS
3358    cthread_set_data(cthread_self(), t);
3359#  else
3360    if (pthread_setspecific(PL_thr_key, t))
3361        Perl_croak_nocontext("panic: pthread_setspecific");
3362#  endif
3363#endif
3364}
3365
3366#endif /* !PERL_GET_CONTEXT_DEFINED */
3367
3368#ifdef USE_THREADS
3369
3370#ifdef FAKE_THREADS
3371/* Very simplistic scheduler for now */
3372void
3373schedule(void)
3374{
3375    thr = thr->i.next_run;
3376}
3377
3378void
3379Perl_cond_init(pTHX_ perl_cond *cp)
3380{
3381    *cp = 0;
3382}
3383
3384void
3385Perl_cond_signal(pTHX_ perl_cond *cp)
3386{
3387    perl_os_thread t;
3388    perl_cond cond = *cp;
3389   
3390    if (!cond)
3391        return;
3392    t = cond->thread;
3393    /* Insert t in the runnable queue just ahead of us */
3394    t->i.next_run = thr->i.next_run;
3395    thr->i.next_run->i.prev_run = t;
3396    t->i.prev_run = thr;
3397    thr->i.next_run = t;
3398    thr->i.wait_queue = 0;
3399    /* Remove from the wait queue */
3400    *cp = cond->next;
3401    Safefree(cond);
3402}
3403
3404void
3405Perl_cond_broadcast(pTHX_ perl_cond *cp)
3406{
3407    perl_os_thread t;
3408    perl_cond cond, cond_next;
3409   
3410    for (cond = *cp; cond; cond = cond_next) {
3411        t = cond->thread;
3412        /* Insert t in the runnable queue just ahead of us */
3413        t->i.next_run = thr->i.next_run;
3414        thr->i.next_run->i.prev_run = t;
3415        t->i.prev_run = thr;
3416        thr->i.next_run = t;
3417        thr->i.wait_queue = 0;
3418        /* Remove from the wait queue */
3419        cond_next = cond->next;
3420        Safefree(cond);
3421    }
3422    *cp = 0;
3423}
3424
3425void
3426Perl_cond_wait(pTHX_ perl_cond *cp)
3427{
3428    perl_cond cond;
3429
3430    if (thr->i.next_run == thr)
3431        Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3432   
3433    New(666, cond, 1, struct perl_wait_queue);
3434    cond->thread = thr;
3435    cond->next = *cp;
3436    *cp = cond;
3437    thr->i.wait_queue = cond;
3438    /* Remove ourselves from runnable queue */
3439    thr->i.next_run->i.prev_run = thr->i.prev_run;
3440    thr->i.prev_run->i.next_run = thr->i.next_run;
3441}
3442#endif /* FAKE_THREADS */
3443
3444MAGIC *
3445Perl_condpair_magic(pTHX_ SV *sv)
3446{
3447    MAGIC *mg;
3448   
3449    SvUPGRADE(sv, SVt_PVMG);
3450    mg = mg_find(sv, 'm');
3451    if (!mg) {
3452        condpair_t *cp;
3453
3454        New(53, cp, 1, condpair_t);
3455        MUTEX_INIT(&cp->mutex);
3456        COND_INIT(&cp->owner_cond);
3457        COND_INIT(&cp->cond);
3458        cp->owner = 0;
3459        LOCK_CRED_MUTEX;                /* XXX need separate mutex? */
3460        mg = mg_find(sv, 'm');
3461        if (mg) {
3462            /* someone else beat us to initialising it */
3463            UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
3464            MUTEX_DESTROY(&cp->mutex);
3465            COND_DESTROY(&cp->owner_cond);
3466            COND_DESTROY(&cp->cond);
3467            Safefree(cp);
3468        }
3469        else {
3470            sv_magic(sv, Nullsv, 'm', 0, 0);
3471            mg = SvMAGIC(sv);
3472            mg->mg_ptr = (char *)cp;
3473            mg->mg_len = sizeof(cp);
3474            UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
3475            DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3476                                           "%p: condpair_magic %p\n", thr, sv));)
3477        }
3478    }
3479    return mg;
3480}
3481
3482SV *
3483Perl_sv_lock(pTHX_ SV *osv)
3484{
3485    MAGIC *mg;
3486    SV *sv = osv;
3487
3488    LOCK_SV_LOCK_MUTEX;
3489    if (SvROK(sv)) {
3490        sv = SvRV(sv);
3491    }
3492
3493    mg = condpair_magic(sv);
3494    MUTEX_LOCK(MgMUTEXP(mg));
3495    if (MgOWNER(mg) == thr)
3496        MUTEX_UNLOCK(MgMUTEXP(mg));
3497    else {
3498        while (MgOWNER(mg))
3499            COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3500        MgOWNER(mg) = thr;
3501        DEBUG_S(PerlIO_printf(Perl_debug_log,
3502                              "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3503                              PTR2UV(thr), PTR2UV(sv));)
3504        MUTEX_UNLOCK(MgMUTEXP(mg));
3505        SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3506    }
3507    UNLOCK_SV_LOCK_MUTEX;
3508    return sv;
3509}
3510
3511/*
3512 * Make a new perl thread structure using t as a prototype. Some of the
3513 * fields for the new thread are copied from the prototype thread, t,
3514 * so t should not be running in perl at the time this function is
3515 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3516 * thread calling new_struct_thread) clearly satisfies this constraint.
3517 */
3518struct perl_thread *
3519Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3520{
3521#if !defined(PERL_IMPLICIT_CONTEXT)
3522    struct perl_thread *thr;
3523#endif
3524    SV *sv;
3525    SV **svp;
3526    I32 i;
3527
3528    sv = newSVpvn("", 0);
3529    SvGROW(sv, sizeof(struct perl_thread) + 1);
3530    SvCUR_set(sv, sizeof(struct perl_thread));
3531    thr = (Thread) SvPVX(sv);
3532#ifdef DEBUGGING
3533    memset(thr, 0xab, sizeof(struct perl_thread));
3534    PL_markstack = 0;
3535    PL_scopestack = 0;
3536    PL_savestack = 0;
3537    PL_retstack = 0;
3538    PL_dirty = 0;
3539    PL_localizing = 0;
3540    Zero(&PL_hv_fetch_ent_mh, 1, HE);
3541    PL_efloatbuf = (char*)NULL;
3542    PL_efloatsize = 0;
3543#else
3544    Zero(thr, 1, struct perl_thread);
3545#endif
3546
3547    thr->oursv = sv;
3548    init_stacks();
3549
3550    PL_curcop = &PL_compiling;
3551    thr->interp = t->interp;
3552    thr->cvcache = newHV();
3553    thr->threadsv = newAV();
3554    thr->specific = newAV();
3555    thr->errsv = newSVpvn("", 0);
3556    thr->flags = THRf_R_JOINABLE;
3557    MUTEX_INIT(&thr->mutex);
3558
3559    JMPENV_BOOTSTRAP;
3560
3561    PL_in_eval = EVAL_NULL;     /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3562    PL_restartop = 0;
3563
3564    PL_statname = NEWSV(66,0);
3565    PL_errors = newSVpvn("", 0);
3566    PL_maxscream = -1;
3567    PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3568    PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3569    PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3570    PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3571    PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3572    PL_regindent = 0;
3573    PL_reginterp_cnt = 0;
3574    PL_lastscream = Nullsv;
3575    PL_screamfirst = 0;
3576    PL_screamnext = 0;
3577    PL_reg_start_tmp = 0;
3578    PL_reg_start_tmpl = 0;
3579    PL_reg_poscache = Nullch;
3580
3581    /* parent thread's data needs to be locked while we make copy */
3582    MUTEX_LOCK(&t->mutex);
3583
3584#ifdef PERL_FLEXIBLE_EXCEPTIONS
3585    PL_protect = t->Tprotect;
3586#endif
3587
3588    PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
3589    PL_defstash = t->Tdefstash;   /* XXX maybe these should */
3590    PL_curstash = t->Tcurstash;   /* always be set to main? */
3591
3592    PL_tainted = t->Ttainted;
3593    PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
3594    PL_nrs = newSVsv(t->Tnrs);
3595    PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv;
3596    PL_last_in_gv = Nullgv;
3597    PL_ofslen = t->Tofslen;
3598    PL_ofs = savepvn(t->Tofs, PL_ofslen);
3599    PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3600    PL_chopset = t->Tchopset;
3601    PL_bodytarget = newSVsv(t->Tbodytarget);
3602    PL_toptarget = newSVsv(t->Ttoptarget);
3603    if (t->Tformtarget == t->Ttoptarget)
3604        PL_formtarget = PL_toptarget;
3605    else
3606        PL_formtarget = PL_bodytarget;
3607
3608    /* Initialise all per-thread SVs that the template thread used */
3609    svp = AvARRAY(t->threadsv);
3610    for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3611        if (*svp && *svp != &PL_sv_undef) {
3612            SV *sv = newSVsv(*svp);
3613            av_store(thr->threadsv, i, sv);
3614            sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
3615            DEBUG_S(PerlIO_printf(Perl_debug_log,
3616                "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3617                                  (IV)i, t, thr));
3618        }
3619    }
3620    thr->threadsvp = AvARRAY(thr->threadsv);
3621
3622    MUTEX_LOCK(&PL_threads_mutex);
3623    PL_nthreads++;
3624    thr->tid = ++PL_threadnum;
3625    thr->next = t->next;
3626    thr->prev = t;
3627    t->next = thr;
3628    thr->next->prev = thr;
3629    MUTEX_UNLOCK(&PL_threads_mutex);
3630
3631    /* done copying parent's state */
3632    MUTEX_UNLOCK(&t->mutex);
3633
3634#ifdef HAVE_THREAD_INTERN
3635    Perl_init_thread_intern(thr);
3636#endif /* HAVE_THREAD_INTERN */
3637    return thr;
3638}
3639#endif /* USE_THREADS */
3640
3641#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
3642/*
3643 * This hack is to force load of "huge" support from libm.a
3644 * So it is in perl for (say) POSIX to use.
3645 * Needed for SunOS with Sun's 'acc' for example.
3646 */
3647NV
3648Perl_huge(void)
3649{
3650#   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
3651    return HUGE_VALL;
3652#   endif
3653    return HUGE_VAL;
3654}
3655#endif
3656
3657#ifdef PERL_GLOBAL_STRUCT
3658struct perl_vars *
3659Perl_GetVars(pTHX)
3660{
3661 return &PL_Vars;
3662}
3663#endif
3664
3665char **
3666Perl_get_op_names(pTHX)
3667{
3668 return PL_op_name;
3669}
3670
3671char **
3672Perl_get_op_descs(pTHX)
3673{
3674 return PL_op_desc;
3675}
3676
3677char *
3678Perl_get_no_modify(pTHX)
3679{
3680 return (char*)PL_no_modify;
3681}
3682
3683U32 *
3684Perl_get_opargs(pTHX)
3685{
3686 return PL_opargs;
3687}
3688
3689PPADDR_t*
3690Perl_get_ppaddr(pTHX)
3691{
3692 return &PL_ppaddr;
3693}
3694
3695#ifndef HAS_GETENV_LEN
3696char *
3697Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3698{
3699    char *env_trans = PerlEnv_getenv(env_elem);
3700    if (env_trans)
3701        *len = strlen(env_trans);
3702    return env_trans;
3703}
3704#endif
3705
3706
3707MGVTBL*
3708Perl_get_vtbl(pTHX_ int vtbl_id)
3709{
3710    MGVTBL* result = Null(MGVTBL*);
3711
3712    switch(vtbl_id) {
3713    case want_vtbl_sv:
3714        result = &PL_vtbl_sv;
3715        break;
3716    case want_vtbl_env:
3717        result = &PL_vtbl_env;
3718        break;
3719    case want_vtbl_envelem:
3720        result = &PL_vtbl_envelem;
3721        break;
3722    case want_vtbl_sig:
3723        result = &PL_vtbl_sig;
3724        break;
3725    case want_vtbl_sigelem:
3726        result = &PL_vtbl_sigelem;
3727        break;
3728    case want_vtbl_pack:
3729        result = &PL_vtbl_pack;
3730        break;
3731    case want_vtbl_packelem:
3732        result = &PL_vtbl_packelem;
3733        break;
3734    case want_vtbl_dbline:
3735        result = &PL_vtbl_dbline;
3736        break;
3737    case want_vtbl_isa:
3738        result = &PL_vtbl_isa;
3739        break;
3740    case want_vtbl_isaelem:
3741        result = &PL_vtbl_isaelem;
3742        break;
3743    case want_vtbl_arylen:
3744        result = &PL_vtbl_arylen;
3745        break;
3746    case want_vtbl_glob:
3747        result = &PL_vtbl_glob;
3748        break;
3749    case want_vtbl_mglob:
3750        result = &PL_vtbl_mglob;
3751        break;
3752    case want_vtbl_nkeys:
3753        result = &PL_vtbl_nkeys;
3754        break;
3755    case want_vtbl_taint:
3756        result = &PL_vtbl_taint;
3757        break;
3758    case want_vtbl_substr:
3759        result = &PL_vtbl_substr;
3760        break;
3761    case want_vtbl_vec:
3762        result = &PL_vtbl_vec;
3763        break;
3764    case want_vtbl_pos:
3765        result = &PL_vtbl_pos;
3766        break;
3767    case want_vtbl_bm:
3768        result = &PL_vtbl_bm;
3769        break;
3770    case want_vtbl_fm:
3771        result = &PL_vtbl_fm;
3772        break;
3773    case want_vtbl_uvar:
3774        result = &PL_vtbl_uvar;
3775        break;
3776#ifdef USE_THREADS
3777    case want_vtbl_mutex:
3778        result = &PL_vtbl_mutex;
3779        break;
3780#endif
3781    case want_vtbl_defelem:
3782        result = &PL_vtbl_defelem;
3783        break;
3784    case want_vtbl_regexp:
3785        result = &PL_vtbl_regexp;
3786        break;
3787    case want_vtbl_regdata:
3788        result = &PL_vtbl_regdata;
3789        break;
3790    case want_vtbl_regdatum:
3791        result = &PL_vtbl_regdatum;
3792        break;
3793#ifdef USE_LOCALE_COLLATE
3794    case want_vtbl_collxfrm:
3795        result = &PL_vtbl_collxfrm;
3796        break;
3797#endif
3798    case want_vtbl_amagic:
3799        result = &PL_vtbl_amagic;
3800        break;
3801    case want_vtbl_amagicelem:
3802        result = &PL_vtbl_amagicelem;
3803        break;
3804    case want_vtbl_backref:
3805        result = &PL_vtbl_backref;
3806        break;
3807    }
3808    return result;
3809}
3810
3811#if !defined(FFLUSH_NULL) && defined(HAS__FWALK)
3812static int S_fflush(FILE *fp);
3813
3814static int
3815S_fflush(FILE *fp)
3816{
3817    return fflush(fp);
3818}
3819#endif
3820
3821I32
3822Perl_my_fflush_all(pTHX)
3823{
3824#if defined(FFLUSH_NULL)
3825    return PerlIO_flush(NULL);
3826#else
3827# if defined(HAS__FWALK)
3828    /* undocumented, unprototyped, but very useful BSDism */
3829    extern void _fwalk(int (*)(FILE *));
3830    _fwalk(&S_fflush);
3831    return 0;
3832#   else
3833    long open_max = -1;
3834#  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3835#   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3836    open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3837#   else
3838#   if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3839    open_max = sysconf(_SC_OPEN_MAX);
3840#   else
3841#    ifdef FOPEN_MAX
3842    open_max = FOPEN_MAX;
3843#    else
3844#     ifdef OPEN_MAX
3845    open_max = OPEN_MAX;
3846#     else
3847#      ifdef _NFILE
3848    open_max = _NFILE;
3849#      endif
3850#     endif
3851#    endif
3852#   endif
3853#   endif
3854    if (open_max > 0) {
3855      long i;
3856      for (i = 0; i < open_max; i++)
3857            if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3858                STDIO_STREAM_ARRAY[i]._file < open_max &&
3859                STDIO_STREAM_ARRAY[i]._flag)
3860                PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3861      return 0;
3862    }
3863#  endif
3864    SETERRNO(EBADF,RMS$_IFI);
3865    return EOF;
3866# endif
3867#endif
3868}
3869
3870NV
3871Perl_my_atof(pTHX_ const char* s)
3872{
3873    NV x = 0.0;
3874#ifdef USE_LOCALE_NUMERIC
3875    if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
3876        NV y;
3877
3878        Perl_atof2(s, x);
3879        SET_NUMERIC_STANDARD();
3880        Perl_atof2(s, y);
3881        SET_NUMERIC_LOCAL();
3882        if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
3883            return y;
3884    }
3885    else
3886        Perl_atof2(s, x);
3887#else
3888    Perl_atof2(s, x);
3889#endif
3890    return x;
3891}
3892
3893void
3894Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3895{
3896    char *vile;
3897    I32   warn_type;
3898    char *func =
3899        op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3900        op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3901        PL_op_desc[op];
3902    char *pars = OP_IS_FILETEST(op) ? "" : "()";
3903    char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ?
3904                     "socket" : "filehandle";
3905    char *name = NULL;
3906
3907    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3908        vile = "closed";
3909        warn_type = WARN_CLOSED;
3910    }
3911    else {
3912        vile = "unopened";
3913        warn_type = WARN_UNOPENED;
3914    }
3915
3916    if (gv && isGV(gv)) {
3917        SV *sv = sv_newmortal();
3918        gv_efullname4(sv, gv, Nullch, FALSE);
3919        name = SvPVX(sv);
3920    }
3921
3922    if (name && *name) {
3923        Perl_warner(aTHX_ warn_type,
3924                    "%s%s on %s %s %s", func, pars, vile, type, name);
3925        if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3926            Perl_warner(aTHX_ warn_type,
3927                        "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3928                        func, pars, name);
3929    }
3930    else {
3931        Perl_warner(aTHX_ warn_type,
3932                    "%s%s on %s %s", func, pars, vile, type);
3933        if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3934            Perl_warner(aTHX_ warn_type,
3935                        "\t(Are you trying to call %s%s on dirhandle?)\n",
3936                        func, pars);
3937    }
3938}
3939
3940#ifdef EBCDIC
3941/* in ASCII order, not that it matters */
3942static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3943
3944int
3945Perl_ebcdic_control(pTHX_ int ch)
3946{
3947        if (ch > 'a') {
3948                char *ctlp;
3949 
3950               if (islower(ch))
3951                      ch = toupper(ch);
3952 
3953               if ((ctlp = strchr(controllablechars, ch)) == 0) {
3954                      Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3955               }
3956 
3957                if (ctlp == controllablechars)
3958                       return('\177'); /* DEL */
3959                else
3960                       return((unsigned char)(ctlp - controllablechars - 1));
3961        } else { /* Want uncontrol */
3962                if (ch == '\177' || ch == -1)
3963                        return('?');
3964                else if (ch == '\157')
3965                        return('\177');
3966                else if (ch == '\174')
3967                        return('\000');
3968                else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3969                        return('\036');
3970                else if (ch == '\155')
3971                        return('\037');
3972                else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3973                        return(controllablechars[ch+1]);
3974                else
3975                        Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3976        }
3977}
3978#endif
Note: See TracBrowser for help on using the repository browser.