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

Revision 20075, 104.3 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
Line 
1/*    util.c
2 *
3 *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 *    2000, 2001, 2002, 2003, by Larry Wall and others
5 *
6 *    You may distribute under the terms of either the GNU General Public
7 *    License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content."  --Gandalf
14 */
15
16#include "EXTERN.h"
17#define PERL_IN_UTIL_C
18#include "perl.h"
19
20#ifndef PERL_MICRO
21#include <signal.h>
22#ifndef SIG_ERR
23# define SIG_ERR ((Sighandler_t) -1)
24#endif
25#endif
26
27#ifdef I_SYS_WAIT
28#  include <sys/wait.h>
29#endif
30
31#ifdef HAS_SELECT
32# ifdef I_SYS_SELECT
33#  include <sys/select.h>
34# endif
35#endif
36
37#define FLUSH
38
39#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
40#  define FD_CLOEXEC 1                  /* NeXT needs this */
41#endif
42
43/* NOTE:  Do not call the next three routines directly.  Use the macros
44 * in handy.h, so that we can easily redefine everything to do tracking of
45 * allocated hunks back to the original New to track down any memory leaks.
46 * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
47 */
48
49/* paranoid version of system's malloc() */
50
51Malloc_t
52Perl_safesysmalloc(MEM_SIZE size)
53{
54    dTHX;
55    Malloc_t ptr;
56#ifdef HAS_64K_LIMIT
57        if (size > 0xffff) {
58            PerlIO_printf(Perl_error_log,
59                          "Allocation too large: %lx\n", size) FLUSH;
60            my_exit(1);
61        }
62#endif /* HAS_64K_LIMIT */
63#ifdef DEBUGGING
64    if ((long)size < 0)
65        Perl_croak_nocontext("panic: malloc");
66#endif
67    ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
68    PERL_ALLOC_CHECK(ptr);
69    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
70    if (ptr != Nullch)
71        return ptr;
72    else if (PL_nomemok)
73        return Nullch;
74    else {
75        PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
76        my_exit(1);
77        return Nullch;
78    }
79    /*NOTREACHED*/
80}
81
82/* paranoid version of system's realloc() */
83
84Malloc_t
85Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
86{
87    dTHX;
88    Malloc_t ptr;
89#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
90    Malloc_t PerlMem_realloc();
91#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
92
93#ifdef HAS_64K_LIMIT
94    if (size > 0xffff) {
95        PerlIO_printf(Perl_error_log,
96                      "Reallocation too large: %lx\n", size) FLUSH;
97        my_exit(1);
98    }
99#endif /* HAS_64K_LIMIT */
100    if (!size) {
101        safesysfree(where);
102        return NULL;
103    }
104
105    if (!where)
106        return safesysmalloc(size);
107#ifdef DEBUGGING
108    if ((long)size < 0)
109        Perl_croak_nocontext("panic: realloc");
110#endif
111    ptr = (Malloc_t)PerlMem_realloc(where,size);
112    PERL_ALLOC_CHECK(ptr);
113
114    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
115    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
116
117    if (ptr != Nullch)
118        return ptr;
119    else if (PL_nomemok)
120        return Nullch;
121    else {
122        PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
123        my_exit(1);
124        return Nullch;
125    }
126    /*NOTREACHED*/
127}
128
129/* safe version of system's free() */
130
131Free_t
132Perl_safesysfree(Malloc_t where)
133{
134#ifdef PERL_IMPLICIT_SYS
135    dTHX;
136#endif
137    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
138    if (where) {
139        /*SUPPRESS 701*/
140        PerlMem_free(where);
141    }
142}
143
144/* safe version of system's calloc() */
145
146Malloc_t
147Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
148{
149    dTHX;
150    Malloc_t ptr;
151
152#ifdef HAS_64K_LIMIT
153    if (size * count > 0xffff) {
154        PerlIO_printf(Perl_error_log,
155                      "Allocation too large: %lx\n", size * count) FLUSH;
156        my_exit(1);
157    }
158#endif /* HAS_64K_LIMIT */
159#ifdef DEBUGGING
160    if ((long)size < 0 || (long)count < 0)
161        Perl_croak_nocontext("panic: calloc");
162#endif
163    size *= count;
164    ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
165    PERL_ALLOC_CHECK(ptr);
166    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));
167    if (ptr != Nullch) {
168        memset((void*)ptr, 0, size);
169        return ptr;
170    }
171    else if (PL_nomemok)
172        return Nullch;
173    else {
174        PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
175        my_exit(1);
176        return Nullch;
177    }
178    /*NOTREACHED*/
179}
180
181/* These must be defined when not using Perl's malloc for binary
182 * compatibility */
183
184#ifndef MYMALLOC
185
186Malloc_t Perl_malloc (MEM_SIZE nbytes)
187{
188    dTHXs;
189    return (Malloc_t)PerlMem_malloc(nbytes);
190}
191
192Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
193{
194    dTHXs;
195    return (Malloc_t)PerlMem_calloc(elements, size);
196}
197
198Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
199{
200    dTHXs;
201    return (Malloc_t)PerlMem_realloc(where, nbytes);
202}
203
204Free_t   Perl_mfree (Malloc_t where)
205{
206    dTHXs;
207    PerlMem_free(where);
208}
209
210#endif
211
212/* copy a string up to some (non-backslashed) delimiter, if any */
213
214char *
215Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
216{
217    register I32 tolen;
218    for (tolen = 0; from < fromend; from++, tolen++) {
219        if (*from == '\\') {
220            if (from[1] == delim)
221                from++;
222            else {
223                if (to < toend)
224                    *to++ = *from;
225                tolen++;
226                from++;
227            }
228        }
229        else if (*from == delim)
230            break;
231        if (to < toend)
232            *to++ = *from;
233    }
234    if (to < toend)
235        *to = '\0';
236    *retlen = tolen;
237    return from;
238}
239
240/* return ptr to little string in big string, NULL if not found */
241/* This routine was donated by Corey Satten. */
242
243char *
244Perl_instr(pTHX_ register const char *big, register const char *little)
245{
246    register const char *s, *x;
247    register I32 first;
248
249    if (!little)
250        return (char*)big;
251    first = *little++;
252    if (!first)
253        return (char*)big;
254    while (*big) {
255        if (*big++ != first)
256            continue;
257        for (x=big,s=little; *s; /**/ ) {
258            if (!*x)
259                return Nullch;
260            if (*s++ != *x++) {
261                s--;
262                break;
263            }
264        }
265        if (!*s)
266            return (char*)(big-1);
267    }
268    return Nullch;
269}
270
271/* same as instr but allow embedded nulls */
272
273char *
274Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
275{
276    register const char *s, *x;
277    register I32 first = *little;
278    register const char *littleend = lend;
279
280    if (!first && little >= littleend)
281        return (char*)big;
282    if (bigend - big < littleend - little)
283        return Nullch;
284    bigend -= littleend - little++;
285    while (big <= bigend) {
286        if (*big++ != first)
287            continue;
288        for (x=big,s=little; s < littleend; /**/ ) {
289            if (*s++ != *x++) {
290                s--;
291                break;
292            }
293        }
294        if (s >= littleend)
295            return (char*)(big-1);
296    }
297    return Nullch;
298}
299
300/* reverse of the above--find last substring */
301
302char *
303Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
304{
305    register const char *bigbeg;
306    register const char *s, *x;
307    register I32 first = *little;
308    register const char *littleend = lend;
309
310    if (!first && little >= littleend)
311        return (char*)bigend;
312    bigbeg = big;
313    big = bigend - (littleend - little++);
314    while (big >= bigbeg) {
315        if (*big-- != first)
316            continue;
317        for (x=big+2,s=little; s < littleend; /**/ ) {
318            if (*s++ != *x++) {
319                s--;
320                break;
321            }
322        }
323        if (s >= littleend)
324            return (char*)(big+1);
325    }
326    return Nullch;
327}
328
329#define FBM_TABLE_OFFSET 2      /* Number of bytes between EOS and table*/
330
331/* As a space optimization, we do not compile tables for strings of length
332   0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
333   special-cased in fbm_instr().
334
335   If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
336
337/*
338=head1 Miscellaneous Functions
339
340=for apidoc fbm_compile
341
342Analyses the string in order to make fast searches on it using fbm_instr()
343-- the Boyer-Moore algorithm.
344
345=cut
346*/
347
348void
349Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
350{
351    register U8 *s;
352    register U8 *table;
353    register U32 i;
354    STRLEN len;
355    I32 rarest = 0;
356    U32 frequency = 256;
357
358    if (flags & FBMcf_TAIL) {
359        MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
360        sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
361        if (mg && mg->mg_len >= 0)
362            mg->mg_len++;
363    }
364    s = (U8*)SvPV_force(sv, len);
365    (void)SvUPGRADE(sv, SVt_PVBM);
366    if (len == 0)               /* TAIL might be on a zero-length string. */
367        return;
368    if (len > 2) {
369        U8 mlen;
370        unsigned char *sb;
371
372        if (len > 255)
373            mlen = 255;
374        else
375            mlen = (U8)len;
376        Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
377        table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
378        s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
379        memset((void*)table, mlen, 256);
380        table[-1] = (U8)flags;
381        i = 0;
382        sb = s - mlen + 1;                      /* first char (maybe) */
383        while (s >= sb) {
384            if (table[*s] == mlen)
385                table[*s] = (U8)i;
386            s--, i++;
387        }
388    }
389    sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0);     /* deep magic */
390    SvVALID_on(sv);
391
392    s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
393    for (i = 0; i < len; i++) {
394        if (PL_freq[s[i]] < frequency) {
395            rarest = i;
396            frequency = PL_freq[s[i]];
397        }
398    }
399    BmRARE(sv) = s[rarest];
400    BmPREVIOUS(sv) = (U16)rarest;
401    BmUSEFUL(sv) = 100;                 /* Initial value */
402    if (flags & FBMcf_TAIL)
403        SvTAIL_on(sv);
404    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
405                          BmRARE(sv),BmPREVIOUS(sv)));
406}
407
408/* If SvTAIL(littlestr), it has a fake '\n' at end. */
409/* If SvTAIL is actually due to \Z or \z, this gives false positives
410   if multiline */
411
412/*
413=for apidoc fbm_instr
414
415Returns the location of the SV in the string delimited by C<str> and
416C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
417does not have to be fbm_compiled, but the search will not be as fast
418then.
419
420=cut
421*/
422
423char *
424Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
425{
426    register unsigned char *s;
427    STRLEN l;
428    register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
429    register STRLEN littlelen = l;
430    register I32 multiline = flags & FBMrf_MULTILINE;
431
432    if ((STRLEN)(bigend - big) < littlelen) {
433        if ( SvTAIL(littlestr)
434             && ((STRLEN)(bigend - big) == littlelen - 1)
435             && (littlelen == 1
436                 || (*big == *little &&
437                     memEQ((char *)big, (char *)little, littlelen - 1))))
438            return (char*)big;
439        return Nullch;
440    }
441
442    if (littlelen <= 2) {               /* Special-cased */
443
444        if (littlelen == 1) {
445            if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
446                /* Know that bigend != big.  */
447                if (bigend[-1] == '\n')
448                    return (char *)(bigend - 1);
449                return (char *) bigend;
450            }
451            s = big;
452            while (s < bigend) {
453                if (*s == *little)
454                    return (char *)s;
455                s++;
456            }
457            if (SvTAIL(littlestr))
458                return (char *) bigend;
459            return Nullch;
460        }
461        if (!littlelen)
462            return (char*)big;          /* Cannot be SvTAIL! */
463
464        /* littlelen is 2 */
465        if (SvTAIL(littlestr) && !multiline) {
466            if (bigend[-1] == '\n' && bigend[-2] == *little)
467                return (char*)bigend - 2;
468            if (bigend[-1] == *little)
469                return (char*)bigend - 1;
470            return Nullch;
471        }
472        {
473            /* This should be better than FBM if c1 == c2, and almost
474               as good otherwise: maybe better since we do less indirection.
475               And we save a lot of memory by caching no table. */
476            register unsigned char c1 = little[0];
477            register unsigned char c2 = little[1];
478
479            s = big + 1;
480            bigend--;
481            if (c1 != c2) {
482                while (s <= bigend) {
483                    if (s[0] == c2) {
484                        if (s[-1] == c1)
485                            return (char*)s - 1;
486                        s += 2;
487                        continue;
488                    }
489                  next_chars:
490                    if (s[0] == c1) {
491                        if (s == bigend)
492                            goto check_1char_anchor;
493                        if (s[1] == c2)
494                            return (char*)s;
495                        else {
496                            s++;
497                            goto next_chars;
498                        }
499                    }
500                    else
501                        s += 2;
502                }
503                goto check_1char_anchor;
504            }
505            /* Now c1 == c2 */
506            while (s <= bigend) {
507                if (s[0] == c1) {
508                    if (s[-1] == c1)
509                        return (char*)s - 1;
510                    if (s == bigend)
511                        goto check_1char_anchor;
512                    if (s[1] == c1)
513                        return (char*)s;
514                    s += 3;
515                }
516                else
517                    s += 2;
518            }
519        }
520      check_1char_anchor:               /* One char and anchor! */
521        if (SvTAIL(littlestr) && (*bigend == *little))
522            return (char *)bigend;      /* bigend is already decremented. */
523        return Nullch;
524    }
525    if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
526        s = bigend - littlelen;
527        if (s >= big && bigend[-1] == '\n' && *s == *little
528            /* Automatically of length > 2 */
529            && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
530        {
531            return (char*)s;            /* how sweet it is */
532        }
533        if (s[1] == *little
534            && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
535        {
536            return (char*)s + 1;        /* how sweet it is */
537        }
538        return Nullch;
539    }
540    if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
541        char *b = ninstr((char*)big,(char*)bigend,
542                         (char*)little, (char*)little + littlelen);
543
544        if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
545            /* Chop \n from littlestr: */
546            s = bigend - littlelen + 1;
547            if (*s == *little
548                && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
549            {
550                return (char*)s;
551            }
552            return Nullch;
553        }
554        return b;
555    }
556
557    {   /* Do actual FBM.  */
558        register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
559        register unsigned char *oldlittle;
560
561        if (littlelen > (STRLEN)(bigend - big))
562            return Nullch;
563        --littlelen;                    /* Last char found by table lookup */
564
565        s = big + littlelen;
566        little += littlelen;            /* last char */
567        oldlittle = little;
568        if (s < bigend) {
569            register I32 tmp;
570
571          top2:
572            /*SUPPRESS 560*/
573            if ((tmp = table[*s])) {
574                if ((s += tmp) < bigend)
575                    goto top2;
576                goto check_end;
577            }
578            else {              /* less expensive than calling strncmp() */
579                register unsigned char *olds = s;
580
581                tmp = littlelen;
582
583                while (tmp--) {
584                    if (*--s == *--little)
585                        continue;
586                    s = olds + 1;       /* here we pay the price for failure */
587                    little = oldlittle;
588                    if (s < bigend)     /* fake up continue to outer loop */
589                        goto top2;
590                    goto check_end;
591                }
592                return (char *)s;
593            }
594        }
595      check_end:
596        if ( s == bigend && (table[-1] & FBMcf_TAIL)
597             && memEQ((char *)(bigend - littlelen),
598                      (char *)(oldlittle - littlelen), littlelen) )
599            return (char*)bigend - littlelen;
600        return Nullch;
601    }
602}
603
604/* start_shift, end_shift are positive quantities which give offsets
605   of ends of some substring of bigstr.
606   If `last' we want the last occurrence.
607   old_posp is the way of communication between consequent calls if
608   the next call needs to find the .
609   The initial *old_posp should be -1.
610
611   Note that we take into account SvTAIL, so one can get extra
612   optimizations if _ALL flag is set.
613 */
614
615/* If SvTAIL is actually due to \Z or \z, this gives false positives
616   if PL_multiline.  In fact if !PL_multiline the authoritative answer
617   is not supported yet. */
618
619char *
620Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
621{
622    register unsigned char *s, *x;
623    register unsigned char *big;
624    register I32 pos;
625    register I32 previous;
626    register I32 first;
627    register unsigned char *little;
628    register I32 stop_pos;
629    register unsigned char *littleend;
630    I32 found = 0;
631
632    if (*old_posp == -1
633        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
634        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
635      cant_find:
636        if ( BmRARE(littlestr) == '\n'
637             && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
638            little = (unsigned char *)(SvPVX(littlestr));
639            littleend = little + SvCUR(littlestr);
640            first = *little++;
641            goto check_tail;
642        }
643        return Nullch;
644    }
645
646    little = (unsigned char *)(SvPVX(littlestr));
647    littleend = little + SvCUR(littlestr);
648    first = *little++;
649    /* The value of pos we can start at: */
650    previous = BmPREVIOUS(littlestr);
651    big = (unsigned char *)(SvPVX(bigstr));
652    /* The value of pos we can stop at: */
653    stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
654    if (previous + start_shift > stop_pos) {
655/*
656  stop_pos does not include SvTAIL in the count, so this check is incorrect
657  (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
658*/
659#if 0
660        if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
661            goto check_tail;
662#endif
663        return Nullch;
664    }
665    while (pos < previous + start_shift) {
666        if (!(pos += PL_screamnext[pos]))
667            goto cant_find;
668    }
669    big -= previous;
670    do {
671        if (pos >= stop_pos) break;
672        if (big[pos] != first)
673            continue;
674        for (x=big+pos+1,s=little; s < littleend; /**/ ) {
675            if (*s++ != *x++) {
676                s--;
677                break;
678            }
679        }
680        if (s == littleend) {
681            *old_posp = pos;
682            if (!last) return (char *)(big+pos);
683            found = 1;
684        }
685    } while ( pos += PL_screamnext[pos] );
686    if (last && found)
687        return (char *)(big+(*old_posp));
688  check_tail:
689    if (!SvTAIL(littlestr) || (end_shift > 0))
690        return Nullch;
691    /* Ignore the trailing "\n".  This code is not microoptimized */
692    big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
693    stop_pos = littleend - little;      /* Actual littlestr len */
694    if (stop_pos == 0)
695        return (char*)big;
696    big -= stop_pos;
697    if (*big == first
698        && ((stop_pos == 1) ||
699            memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
700        return (char*)big;
701    return Nullch;
702}
703
704I32
705Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
706{
707    register U8 *a = (U8 *)s1;
708    register U8 *b = (U8 *)s2;
709    while (len--) {
710        if (*a != *b && *a != PL_fold[*b])
711            return 1;
712        a++,b++;
713    }
714    return 0;
715}
716
717I32
718Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
719{
720    register U8 *a = (U8 *)s1;
721    register U8 *b = (U8 *)s2;
722    while (len--) {
723        if (*a != *b && *a != PL_fold_locale[*b])
724            return 1;
725        a++,b++;
726    }
727    return 0;
728}
729
730/* copy a string to a safe spot */
731
732/*
733=head1 Memory Management
734
735=for apidoc savepv
736
737Perl's version of C<strdup()>. Returns a pointer to a newly allocated
738string which is a duplicate of C<pv>. The size of the string is
739determined by C<strlen()>. The memory allocated for the new string can
740be freed with the C<Safefree()> function.
741
742=cut
743*/
744
745char *
746Perl_savepv(pTHX_ const char *pv)
747{
748    register char *newaddr = Nullch;
749    if (pv) {
750        New(902,newaddr,strlen(pv)+1,char);
751        (void)strcpy(newaddr,pv);
752    }
753    return newaddr;
754}
755
756/* same thing but with a known length */
757
758/*
759=for apidoc savepvn
760
761Perl's version of what C<strndup()> would be if it existed. Returns a
762pointer to a newly allocated string which is a duplicate of the first
763C<len> bytes from C<pv>. The memory allocated for the new string can be
764freed with the C<Safefree()> function.
765
766=cut
767*/
768
769char *
770Perl_savepvn(pTHX_ const char *pv, register I32 len)
771{
772    register char *newaddr;
773
774    New(903,newaddr,len+1,char);
775    /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
776    if (pv) {
777        Copy(pv,newaddr,len,char);      /* might not be null terminated */
778        newaddr[len] = '\0';            /* is now */
779    }
780    else {
781        Zero(newaddr,len+1,char);
782    }
783    return newaddr;
784}
785
786/*
787=for apidoc savesharedpv
788
789A version of C<savepv()> which allocates the duplicate string in memory
790which is shared between threads.
791
792=cut
793*/
794char *
795Perl_savesharedpv(pTHX_ const char *pv)
796{
797    register char *newaddr = Nullch;
798    if (pv) {
799        newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
800        (void)strcpy(newaddr,pv);
801    }
802    return newaddr;
803}
804
805
806
807/* the SV for Perl_form() and mess() is not kept in an arena */
808
809STATIC SV *
810S_mess_alloc(pTHX)
811{
812    SV *sv;
813    XPVMG *any;
814
815    if (!PL_dirty)
816        return sv_2mortal(newSVpvn("",0));
817
818    if (PL_mess_sv)
819        return PL_mess_sv;
820
821    /* Create as PVMG now, to avoid any upgrading later */
822    New(905, sv, 1, SV);
823    Newz(905, any, 1, XPVMG);
824    SvFLAGS(sv) = SVt_PVMG;
825    SvANY(sv) = (void*)any;
826    SvREFCNT(sv) = 1 << 30; /* practically infinite */
827    PL_mess_sv = sv;
828    return sv;
829}
830
831#if defined(PERL_IMPLICIT_CONTEXT)
832char *
833Perl_form_nocontext(const char* pat, ...)
834{
835    dTHX;
836    char *retval;
837    va_list args;
838    va_start(args, pat);
839    retval = vform(pat, &args);
840    va_end(args);
841    return retval;
842}
843#endif /* PERL_IMPLICIT_CONTEXT */
844
845/*
846=head1 Miscellaneous Functions
847=for apidoc form
848
849Takes a sprintf-style format pattern and conventional
850(non-SV) arguments and returns the formatted string.
851
852    (char *) Perl_form(pTHX_ const char* pat, ...)
853
854can be used any place a string (char *) is required:
855
856    char * s = Perl_form("%d.%d",major,minor);
857
858Uses a single private buffer so if you want to format several strings you
859must explicitly copy the earlier strings away (and free the copies when you
860are done).
861
862=cut
863*/
864
865char *
866Perl_form(pTHX_ const char* pat, ...)
867{
868    char *retval;
869    va_list args;
870    va_start(args, pat);
871    retval = vform(pat, &args);
872    va_end(args);
873    return retval;
874}
875
876char *
877Perl_vform(pTHX_ const char *pat, va_list *args)
878{
879    SV *sv = mess_alloc();
880    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
881    return SvPVX(sv);
882}
883
884#if defined(PERL_IMPLICIT_CONTEXT)
885SV *
886Perl_mess_nocontext(const char *pat, ...)
887{
888    dTHX;
889    SV *retval;
890    va_list args;
891    va_start(args, pat);
892    retval = vmess(pat, &args);
893    va_end(args);
894    return retval;
895}
896#endif /* PERL_IMPLICIT_CONTEXT */
897
898SV *
899Perl_mess(pTHX_ const char *pat, ...)
900{
901    SV *retval;
902    va_list args;
903    va_start(args, pat);
904    retval = vmess(pat, &args);
905    va_end(args);
906    return retval;
907}
908
909STATIC COP*
910S_closest_cop(pTHX_ COP *cop, OP *o)
911{
912    /* Look for PL_op starting from o.  cop is the last COP we've seen. */
913
914    if (!o || o == PL_op) return cop;
915
916    if (o->op_flags & OPf_KIDS) {
917        OP *kid;
918        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
919        {
920            COP *new_cop;
921
922            /* If the OP_NEXTSTATE has been optimised away we can still use it
923             * the get the file and line number. */
924
925            if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
926                cop = (COP *)kid;
927
928            /* Keep searching, and return when we've found something. */
929
930            new_cop = closest_cop(cop, kid);
931            if (new_cop) return new_cop;
932        }
933    }
934
935    /* Nothing found. */
936
937    return 0;
938}
939
940SV *
941Perl_vmess(pTHX_ const char *pat, va_list *args)
942{
943    SV *sv = mess_alloc();
944    static char dgd[] = " during global destruction.\n";
945    COP *cop;
946
947    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
948    if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
949
950        /*
951         * Try and find the file and line for PL_op.  This will usually be
952         * PL_curcop, but it might be a cop that has been optimised away.  We
953         * can try to find such a cop by searching through the optree starting
954         * from the sibling of PL_curcop.
955         */
956
957        cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
958        if (!cop) cop = PL_curcop;
959
960        if (CopLINE(cop))
961            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
962            OutCopFILE(cop), (IV)CopLINE(cop));
963        if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
964            bool line_mode = (RsSIMPLE(PL_rs) &&
965                              SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
966            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
967                           PL_last_in_gv == PL_argvgv ?
968                           "" : GvNAME(PL_last_in_gv),
969                           line_mode ? "line" : "chunk",
970                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
971        }
972#ifdef USE_5005THREADS
973        if (thr->tid)
974            Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
975#endif
976        sv_catpv(sv, PL_dirty ? dgd : ".\n");
977    }
978    return sv;
979}
980
981void
982Perl_write_to_stderr(pTHX_ const char* message, int msglen)
983{
984    IO *io;
985    MAGIC *mg;
986
987    if (PL_stderrgv && SvREFCNT(PL_stderrgv)
988        && (io = GvIO(PL_stderrgv))
989        && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
990    {
991        dSP;
992        ENTER;
993        SAVETMPS;
994
995        save_re_context();
996        SAVESPTR(PL_stderrgv);
997        PL_stderrgv = Nullgv;
998
999        PUSHSTACKi(PERLSI_MAGIC);
1000
1001        PUSHMARK(SP);
1002        EXTEND(SP,2);
1003        PUSHs(SvTIED_obj((SV*)io, mg));
1004        PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1005        PUTBACK;
1006        call_method("PRINT", G_SCALAR);
1007
1008        POPSTACK;
1009        FREETMPS;
1010        LEAVE;
1011    }
1012    else {
1013#ifdef USE_SFIO
1014        /* SFIO can really mess with your errno */
1015        int e = errno;
1016#endif
1017        PerlIO *serr = Perl_error_log;
1018
1019        PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1020        (void)PerlIO_flush(serr);
1021#ifdef USE_SFIO
1022        errno = e;
1023#endif
1024    }
1025}
1026
1027OP *
1028Perl_vdie(pTHX_ const char* pat, va_list *args)
1029{
1030    char *message;
1031    int was_in_eval = PL_in_eval;
1032    HV *stash;
1033    GV *gv;
1034    CV *cv;
1035    SV *msv;
1036    STRLEN msglen;
1037    I32 utf8 = 0;
1038
1039    DEBUG_S(PerlIO_printf(Perl_debug_log,
1040                          "%p: die: curstack = %p, mainstack = %p\n",
1041                          thr, PL_curstack, PL_mainstack));
1042
1043    if (pat) {
1044        msv = vmess(pat, args);
1045        if (PL_errors && SvCUR(PL_errors)) {
1046            sv_catsv(PL_errors, msv);
1047            message = SvPV(PL_errors, msglen);
1048            SvCUR_set(PL_errors, 0);
1049        }
1050        else
1051            message = SvPV(msv,msglen);
1052        utf8 = SvUTF8(msv);
1053    }
1054    else {
1055        message = Nullch;
1056        msglen = 0;
1057    }
1058
1059    DEBUG_S(PerlIO_printf(Perl_debug_log,
1060                          "%p: die: message = %s\ndiehook = %p\n",
1061                          thr, message, PL_diehook));
1062    if (PL_diehook) {
1063        /* sv_2cv might call Perl_croak() */
1064        SV *olddiehook = PL_diehook;
1065        ENTER;
1066        SAVESPTR(PL_diehook);
1067        PL_diehook = Nullsv;
1068        cv = sv_2cv(olddiehook, &stash, &gv, 0);
1069        LEAVE;
1070        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1071            dSP;
1072            SV *msg;
1073
1074            ENTER;
1075            save_re_context();
1076            if (message) {
1077                msg = newSVpvn(message, msglen);
1078                SvFLAGS(msg) |= utf8;
1079                SvREADONLY_on(msg);
1080                SAVEFREESV(msg);
1081            }
1082            else {
1083                msg = ERRSV;
1084            }
1085
1086            PUSHSTACKi(PERLSI_DIEHOOK);
1087            PUSHMARK(SP);
1088            XPUSHs(msg);
1089            PUTBACK;
1090            call_sv((SV*)cv, G_DISCARD);
1091            POPSTACK;
1092            LEAVE;
1093        }
1094    }
1095
1096    PL_restartop = die_where(message, msglen);
1097    SvFLAGS(ERRSV) |= utf8;
1098    DEBUG_S(PerlIO_printf(Perl_debug_log,
1099          "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1100          thr, PL_restartop, was_in_eval, PL_top_env));
1101    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1102        JMPENV_JUMP(3);
1103    return PL_restartop;
1104}
1105
1106#if defined(PERL_IMPLICIT_CONTEXT)
1107OP *
1108Perl_die_nocontext(const char* pat, ...)
1109{
1110    dTHX;
1111    OP *o;
1112    va_list args;
1113    va_start(args, pat);
1114    o = vdie(pat, &args);
1115    va_end(args);
1116    return o;
1117}
1118#endif /* PERL_IMPLICIT_CONTEXT */
1119
1120OP *
1121Perl_die(pTHX_ const char* pat, ...)
1122{
1123    OP *o;
1124    va_list args;
1125    va_start(args, pat);
1126    o = vdie(pat, &args);
1127    va_end(args);
1128    return o;
1129}
1130
1131void
1132Perl_vcroak(pTHX_ const char* pat, va_list *args)
1133{
1134    char *message;
1135    HV *stash;
1136    GV *gv;
1137    CV *cv;
1138    SV *msv;
1139    STRLEN msglen;
1140    I32 utf8 = 0;
1141
1142    if (pat) {
1143        msv = vmess(pat, args);
1144        if (PL_errors && SvCUR(PL_errors)) {
1145            sv_catsv(PL_errors, msv);
1146            message = SvPV(PL_errors, msglen);
1147            SvCUR_set(PL_errors, 0);
1148        }
1149        else
1150            message = SvPV(msv,msglen);
1151        utf8 = SvUTF8(msv);
1152    }
1153    else {
1154        message = Nullch;
1155        msglen = 0;
1156    }
1157
1158    DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1159                          PTR2UV(thr), message));
1160
1161    if (PL_diehook) {
1162        /* sv_2cv might call Perl_croak() */
1163        SV *olddiehook = PL_diehook;
1164        ENTER;
1165        SAVESPTR(PL_diehook);
1166        PL_diehook = Nullsv;
1167        cv = sv_2cv(olddiehook, &stash, &gv, 0);
1168        LEAVE;
1169        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1170            dSP;
1171            SV *msg;
1172
1173            ENTER;
1174            save_re_context();
1175            if (message) {
1176                msg = newSVpvn(message, msglen);
1177                SvFLAGS(msg) |= utf8;
1178                SvREADONLY_on(msg);
1179                SAVEFREESV(msg);
1180            }
1181            else {
1182                msg = ERRSV;
1183            }
1184
1185            PUSHSTACKi(PERLSI_DIEHOOK);
1186            PUSHMARK(SP);
1187            XPUSHs(msg);
1188            PUTBACK;
1189            call_sv((SV*)cv, G_DISCARD);
1190            POPSTACK;
1191            LEAVE;
1192        }
1193    }
1194    if (PL_in_eval) {
1195        PL_restartop = die_where(message, msglen);
1196        SvFLAGS(ERRSV) |= utf8;
1197        JMPENV_JUMP(3);
1198    }
1199    else if (!message)
1200        message = SvPVx(ERRSV, msglen);
1201
1202    write_to_stderr(message, msglen);
1203    my_failure_exit();
1204}
1205
1206#if defined(PERL_IMPLICIT_CONTEXT)
1207void
1208Perl_croak_nocontext(const char *pat, ...)
1209{
1210    dTHX;
1211    va_list args;
1212    va_start(args, pat);
1213    vcroak(pat, &args);
1214    /* NOTREACHED */
1215    va_end(args);
1216}
1217#endif /* PERL_IMPLICIT_CONTEXT */
1218
1219/*
1220=head1 Warning and Dieing
1221
1222=for apidoc croak
1223
1224This is the XSUB-writer's interface to Perl's C<die> function.
1225Normally use this function the same way you use the C C<printf>
1226function.  See C<warn>.
1227
1228If you want to throw an exception object, assign the object to
1229C<$@> and then pass C<Nullch> to croak():
1230
1231   errsv = get_sv("@", TRUE);
1232   sv_setsv(errsv, exception_object);
1233   croak(Nullch);
1234
1235=cut
1236*/
1237
1238void
1239Perl_croak(pTHX_ const char *pat, ...)
1240{
1241    va_list args;
1242    va_start(args, pat);
1243    vcroak(pat, &args);
1244    /* NOTREACHED */
1245    va_end(args);
1246}
1247
1248void
1249Perl_vwarn(pTHX_ const char* pat, va_list *args)
1250{
1251    char *message;
1252    HV *stash;
1253    GV *gv;
1254    CV *cv;
1255    SV *msv;
1256    STRLEN msglen;
1257    I32 utf8 = 0;
1258
1259    msv = vmess(pat, args);
1260    utf8 = SvUTF8(msv);
1261    message = SvPV(msv, msglen);
1262
1263    if (PL_warnhook) {
1264        /* sv_2cv might call Perl_warn() */
1265        SV *oldwarnhook = PL_warnhook;
1266        ENTER;
1267        SAVESPTR(PL_warnhook);
1268        PL_warnhook = Nullsv;
1269        cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1270        LEAVE;
1271        if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1272            dSP;
1273            SV *msg;
1274
1275            ENTER;
1276            save_re_context();
1277            msg = newSVpvn(message, msglen);
1278            SvFLAGS(msg) |= utf8;
1279            SvREADONLY_on(msg);
1280            SAVEFREESV(msg);
1281
1282            PUSHSTACKi(PERLSI_WARNHOOK);
1283            PUSHMARK(SP);
1284            XPUSHs(msg);
1285            PUTBACK;
1286            call_sv((SV*)cv, G_DISCARD);
1287            POPSTACK;
1288            LEAVE;
1289            return;
1290        }
1291    }
1292
1293    write_to_stderr(message, msglen);
1294}
1295
1296#if defined(PERL_IMPLICIT_CONTEXT)
1297void
1298Perl_warn_nocontext(const char *pat, ...)
1299{
1300    dTHX;
1301    va_list args;
1302    va_start(args, pat);
1303    vwarn(pat, &args);
1304    va_end(args);
1305}
1306#endif /* PERL_IMPLICIT_CONTEXT */
1307
1308/*
1309=for apidoc warn
1310
1311This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
1312function the same way you use the C C<printf> function.  See
1313C<croak>.
1314
1315=cut
1316*/
1317
1318void
1319Perl_warn(pTHX_ const char *pat, ...)
1320{
1321    va_list args;
1322    va_start(args, pat);
1323    vwarn(pat, &args);
1324    va_end(args);
1325}
1326
1327#if defined(PERL_IMPLICIT_CONTEXT)
1328void
1329Perl_warner_nocontext(U32 err, const char *pat, ...)
1330{
1331    dTHX;
1332    va_list args;
1333    va_start(args, pat);
1334    vwarner(err, pat, &args);
1335    va_end(args);
1336}
1337#endif /* PERL_IMPLICIT_CONTEXT */
1338
1339void
1340Perl_warner(pTHX_ U32  err, const char* pat,...)
1341{
1342    va_list args;
1343    va_start(args, pat);
1344    vwarner(err, pat, &args);
1345    va_end(args);
1346}
1347
1348void
1349Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1350{
1351    char *message;
1352    HV *stash;
1353    GV *gv;
1354    CV *cv;
1355    SV *msv;
1356    STRLEN msglen;
1357    I32 utf8 = 0;
1358
1359    msv = vmess(pat, args);
1360    message = SvPV(msv, msglen);
1361    utf8 = SvUTF8(msv);
1362
1363    if (ckDEAD(err)) {
1364#ifdef USE_5005THREADS
1365        DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1366#endif /* USE_5005THREADS */
1367        if (PL_diehook) {
1368            /* sv_2cv might call Perl_croak() */
1369            SV *olddiehook = PL_diehook;
1370            ENTER;
1371            SAVESPTR(PL_diehook);
1372            PL_diehook = Nullsv;
1373            cv = sv_2cv(olddiehook, &stash, &gv, 0);
1374            LEAVE;
1375            if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1376                dSP;
1377                SV *msg;
1378
1379                ENTER;
1380                save_re_context();
1381                msg = newSVpvn(message, msglen);
1382                SvFLAGS(msg) |= utf8;
1383                SvREADONLY_on(msg);
1384                SAVEFREESV(msg);
1385
1386                PUSHSTACKi(PERLSI_DIEHOOK);
1387                PUSHMARK(sp);
1388                XPUSHs(msg);
1389                PUTBACK;
1390                call_sv((SV*)cv, G_DISCARD);
1391                POPSTACK;
1392                LEAVE;
1393            }
1394        }
1395        if (PL_in_eval) {
1396            PL_restartop = die_where(message, msglen);
1397            SvFLAGS(ERRSV) |= utf8;
1398            JMPENV_JUMP(3);
1399        }
1400        write_to_stderr(message, msglen);
1401        my_failure_exit();
1402    }
1403    else {
1404        if (PL_warnhook) {
1405            /* sv_2cv might call Perl_warn() */
1406            SV *oldwarnhook = PL_warnhook;
1407            ENTER;
1408            SAVESPTR(PL_warnhook);
1409            PL_warnhook = Nullsv;
1410            cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1411            LEAVE;
1412            if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1413                dSP;
1414                SV *msg;
1415
1416                ENTER;
1417                save_re_context();
1418                msg = newSVpvn(message, msglen);
1419                SvFLAGS(msg) |= utf8;
1420                SvREADONLY_on(msg);
1421                SAVEFREESV(msg);
1422
1423                PUSHSTACKi(PERLSI_WARNHOOK);
1424                PUSHMARK(sp);
1425                XPUSHs(msg);
1426                PUTBACK;
1427                call_sv((SV*)cv, G_DISCARD);
1428                POPSTACK;
1429                LEAVE;
1430                return;
1431            }
1432        }
1433        write_to_stderr(message, msglen);
1434    }
1435}
1436
1437/* since we've already done strlen() for both nam and val
1438 * we can use that info to make things faster than
1439 * sprintf(s, "%s=%s", nam, val)
1440 */
1441#define my_setenv_format(s, nam, nlen, val, vlen) \
1442   Copy(nam, s, nlen, char); \
1443   *(s+nlen) = '='; \
1444   Copy(val, s+(nlen+1), vlen, char); \
1445   *(s+(nlen+1+vlen)) = '\0'
1446
1447#ifdef USE_ENVIRON_ARRAY
1448       /* VMS' my_setenv() is in vms.c */
1449#if !defined(WIN32) && !defined(NETWARE)
1450void
1451Perl_my_setenv(pTHX_ char *nam, char *val)
1452{
1453#ifdef USE_ITHREADS
1454  /* only parent thread can modify process environment */
1455  if (PL_curinterp == aTHX)
1456#endif
1457  {
1458#ifndef PERL_USE_SAFE_PUTENV
1459    /* most putenv()s leak, so we manipulate environ directly */
1460    register I32 i=setenv_getix(nam);           /* where does it go? */
1461    int nlen, vlen;
1462
1463    if (environ == PL_origenviron) {    /* need we copy environment? */
1464        I32 j;
1465        I32 max;
1466        char **tmpenv;
1467
1468        /*SUPPRESS 530*/
1469        for (max = i; environ[max]; max++) ;
1470        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1471        for (j=0; j<max; j++) {         /* copy environment */
1472            int len = strlen(environ[j]);
1473            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1474            Copy(environ[j], tmpenv[j], len+1, char);
1475        }
1476        tmpenv[max] = Nullch;
1477        environ = tmpenv;               /* tell exec where it is now */
1478    }
1479    if (!val) {
1480        safesysfree(environ[i]);
1481        while (environ[i]) {
1482            environ[i] = environ[i+1];
1483            i++;
1484        }
1485        return;
1486    }
1487    if (!environ[i]) {                  /* does not exist yet */
1488        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1489        environ[i+1] = Nullch;  /* make sure it's null terminated */
1490    }
1491    else
1492        safesysfree(environ[i]);
1493    nlen = strlen(nam);
1494    vlen = strlen(val);
1495
1496    environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1497    /* all that work just for this */
1498    my_setenv_format(environ[i], nam, nlen, val, vlen);
1499
1500#else   /* PERL_USE_SAFE_PUTENV */
1501#   if defined(__CYGWIN__) || defined( EPOC)
1502    setenv(nam, val, 1);
1503#   else
1504    char *new_env;
1505    int nlen = strlen(nam), vlen;
1506    if (!val) {
1507        val = "";
1508    }
1509    vlen = strlen(val);
1510    new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1511    /* all that work just for this */
1512    my_setenv_format(new_env, nam, nlen, val, vlen);
1513    (void)putenv(new_env);
1514#   endif /* __CYGWIN__ */
1515#endif  /* PERL_USE_SAFE_PUTENV */
1516  }
1517}
1518
1519#else /* WIN32 || NETWARE */
1520
1521void
1522Perl_my_setenv(pTHX_ char *nam,char *val)
1523{
1524    register char *envstr;
1525    int nlen = strlen(nam), vlen;
1526
1527    if (!val) {
1528        val = "";
1529    }
1530    vlen = strlen(val);
1531    New(904, envstr, nlen+vlen+2, char);
1532    my_setenv_format(envstr, nam, nlen, val, vlen);
1533    (void)PerlEnv_putenv(envstr);
1534    Safefree(envstr);
1535}
1536
1537#endif /* WIN32 || NETWARE */
1538
1539#ifndef PERL_MICRO
1540I32
1541Perl_setenv_getix(pTHX_ char *nam)
1542{
1543    register I32 i, len = strlen(nam);
1544
1545    for (i = 0; environ[i]; i++) {
1546        if (
1547#ifdef WIN32
1548            strnicmp(environ[i],nam,len) == 0
1549#else
1550            strnEQ(environ[i],nam,len)
1551#endif
1552            && environ[i][len] == '=')
1553            break;                      /* strnEQ must come first to avoid */
1554    }                                   /* potential SEGV's */
1555    return i;
1556}
1557#endif /* !PERL_MICRO */
1558
1559#endif /* !VMS && !EPOC*/
1560
1561#ifdef UNLINK_ALL_VERSIONS
1562I32
1563Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1564{
1565    I32 i;
1566
1567    for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1568    return i ? 0 : -1;
1569}
1570#endif
1571
1572/* this is a drop-in replacement for bcopy() */
1573#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1574char *
1575Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1576{
1577    char *retval = to;
1578
1579    if (from - to >= 0) {
1580        while (len--)
1581            *to++ = *from++;
1582    }
1583    else {
1584        to += len;
1585        from += len;
1586        while (len--)
1587            *(--to) = *(--from);
1588    }
1589    return retval;
1590}
1591#endif
1592
1593/* this is a drop-in replacement for memset() */
1594#ifndef HAS_MEMSET
1595void *
1596Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1597{
1598    char *retval = loc;
1599
1600    while (len--)
1601        *loc++ = ch;
1602    return retval;
1603}
1604#endif
1605
1606/* this is a drop-in replacement for bzero() */
1607#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1608char *
1609Perl_my_bzero(register char *loc, register I32 len)
1610{
1611    char *retval = loc;
1612
1613    while (len--)
1614        *loc++ = 0;
1615    return retval;
1616}
1617#endif
1618
1619/* this is a drop-in replacement for memcmp() */
1620#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1621I32
1622Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1623{
1624    register U8 *a = (U8 *)s1;
1625    register U8 *b = (U8 *)s2;
1626    register I32 tmp;
1627
1628    while (len--) {
1629        if (tmp = *a++ - *b++)
1630            return tmp;
1631    }
1632    return 0;
1633}
1634#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1635
1636#ifndef HAS_VPRINTF
1637
1638#ifdef USE_CHAR_VSPRINTF
1639char *
1640#else
1641int
1642#endif
1643vsprintf(char *dest, const char *pat, char *args)
1644{
1645    FILE fakebuf;
1646
1647    fakebuf._ptr = dest;
1648    fakebuf._cnt = 32767;
1649#ifndef _IOSTRG
1650#define _IOSTRG 0
1651#endif
1652    fakebuf._flag = _IOWRT|_IOSTRG;
1653    _doprnt(pat, args, &fakebuf);       /* what a kludge */
1654    (void)putc('\0', &fakebuf);
1655#ifdef USE_CHAR_VSPRINTF
1656    return(dest);
1657#else
1658    return 0;           /* perl doesn't use return value */
1659#endif
1660}
1661
1662#endif /* HAS_VPRINTF */
1663
1664#ifdef MYSWAP
1665#if BYTEORDER != 0x4321
1666short
1667Perl_my_swap(pTHX_ short s)
1668{
1669#if (BYTEORDER & 1) == 0
1670    short result;
1671
1672    result = ((s & 255) << 8) + ((s >> 8) & 255);
1673    return result;
1674#else
1675    return s;
1676#endif
1677}
1678
1679long
1680Perl_my_htonl(pTHX_ long l)
1681{
1682    union {
1683        long result;
1684        char c[sizeof(long)];
1685    } u;
1686
1687#if BYTEORDER == 0x1234
1688    u.c[0] = (l >> 24) & 255;
1689    u.c[1] = (l >> 16) & 255;
1690    u.c[2] = (l >> 8) & 255;
1691    u.c[3] = l & 255;
1692    return u.result;
1693#else
1694#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1695    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1696#else
1697    register I32 o;
1698    register I32 s;
1699
1700    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1701        u.c[o & 0xf] = (l >> s) & 255;
1702    }
1703    return u.result;
1704#endif
1705#endif
1706}
1707
1708long
1709Perl_my_ntohl(pTHX_ long l)
1710{
1711    union {
1712        long l;
1713        char c[sizeof(long)];
1714    } u;
1715
1716#if BYTEORDER == 0x1234
1717    u.c[0] = (l >> 24) & 255;
1718    u.c[1] = (l >> 16) & 255;
1719    u.c[2] = (l >> 8) & 255;
1720    u.c[3] = l & 255;
1721    return u.l;
1722#else
1723#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1724    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1725#else
1726    register I32 o;
1727    register I32 s;
1728
1729    u.l = l;
1730    l = 0;
1731    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1732        l |= (u.c[o & 0xf] & 255) << s;
1733    }
1734    return l;
1735#endif
1736#endif
1737}
1738
1739#endif /* BYTEORDER != 0x4321 */
1740#endif /* MYSWAP */
1741
1742/*
1743 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1744 * If these functions are defined,
1745 * the BYTEORDER is neither 0x1234 nor 0x4321.
1746 * However, this is not assumed.
1747 * -DWS
1748 */
1749
1750#define HTOV(name,type)                                         \
1751        type                                                    \
1752        name (register type n)                                  \
1753        {                                                       \
1754            union {                                             \
1755                type value;                                     \
1756                char c[sizeof(type)];                           \
1757            } u;                                                \
1758            register I32 i;                                     \
1759            register I32 s;                                     \
1760            for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1761                u.c[i] = (n >> s) & 0xFF;                       \
1762            }                                                   \
1763            return u.value;                                     \
1764        }
1765
1766#define VTOH(name,type)                                         \
1767        type                                                    \
1768        name (register type n)                                  \
1769        {                                                       \
1770            union {                                             \
1771                type value;                                     \
1772                char c[sizeof(type)];                           \
1773            } u;                                                \
1774            register I32 i;                                     \
1775            register I32 s;                                     \
1776            u.value = n;                                        \
1777            n = 0;                                              \
1778            for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1779                n += (u.c[i] & 0xFF) << s;                      \
1780            }                                                   \
1781            return n;                                           \
1782        }
1783
1784#if defined(HAS_HTOVS) && !defined(htovs)
1785HTOV(htovs,short)
1786#endif
1787#if defined(HAS_HTOVL) && !defined(htovl)
1788HTOV(htovl,long)
1789#endif
1790#if defined(HAS_VTOHS) && !defined(vtohs)
1791VTOH(vtohs,short)
1792#endif
1793#if defined(HAS_VTOHL) && !defined(vtohl)
1794VTOH(vtohl,long)
1795#endif
1796
1797PerlIO *
1798Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1799{
1800#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1801    int p[2];
1802    register I32 This, that;
1803    register Pid_t pid;
1804    SV *sv;
1805    I32 did_pipes = 0;
1806    int pp[2];
1807
1808    PERL_FLUSHALL_FOR_CHILD;
1809    This = (*mode == 'w');
1810    that = !This;
1811    if (PL_tainting) {
1812        taint_env();
1813        taint_proper("Insecure %s%s", "EXEC");
1814    }
1815    if (PerlProc_pipe(p) < 0)
1816        return Nullfp;
1817    /* Try for another pipe pair for error return */
1818    if (PerlProc_pipe(pp) >= 0)
1819        did_pipes = 1;
1820    while ((pid = PerlProc_fork()) < 0) {
1821        if (errno != EAGAIN) {
1822            PerlLIO_close(p[This]);
1823            PerlLIO_close(p[that]);
1824            if (did_pipes) {
1825                PerlLIO_close(pp[0]);
1826                PerlLIO_close(pp[1]);
1827            }
1828            return Nullfp;
1829        }
1830        sleep(5);
1831    }
1832    if (pid == 0) {
1833        /* Child */
1834#undef THIS
1835#undef THAT
1836#define THIS that
1837#define THAT This
1838        /* Close parent's end of error status pipe (if any) */
1839        if (did_pipes) {
1840            PerlLIO_close(pp[0]);
1841#if defined(HAS_FCNTL) && defined(F_SETFD)
1842            /* Close error pipe automatically if exec works */
1843            fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1844#endif
1845        }
1846        /* Now dup our end of _the_ pipe to right position */
1847        if (p[THIS] != (*mode == 'r')) {
1848            PerlLIO_dup2(p[THIS], *mode == 'r');
1849            PerlLIO_close(p[THIS]);
1850            if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1851                PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1852        }
1853        else
1854            PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
1855#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1856        /* No automatic close - do it by hand */
1857#  ifndef NOFILE
1858#  define NOFILE 20
1859#  endif
1860        {
1861            int fd;
1862
1863            for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
1864                if (fd != pp[1])
1865                    PerlLIO_close(fd);
1866            }
1867        }
1868#endif
1869        do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1870        PerlProc__exit(1);
1871#undef THIS
1872#undef THAT
1873    }
1874    /* Parent */
1875    do_execfree();      /* free any memory malloced by child on fork */
1876    if (did_pipes)
1877        PerlLIO_close(pp[1]);
1878    /* Keep the lower of the two fd numbers */
1879    if (p[that] < p[This]) {
1880        PerlLIO_dup2(p[This], p[that]);
1881        PerlLIO_close(p[This]);
1882        p[This] = p[that];
1883    }
1884    else
1885        PerlLIO_close(p[that]);         /* close child's end of pipe */
1886
1887    LOCK_FDPID_MUTEX;
1888    sv = *av_fetch(PL_fdpid,p[This],TRUE);
1889    UNLOCK_FDPID_MUTEX;
1890    (void)SvUPGRADE(sv,SVt_IV);
1891    SvIVX(sv) = pid;
1892    PL_forkprocess = pid;
1893    /* If we managed to get status pipe check for exec fail */
1894    if (did_pipes && pid > 0) {
1895        int errkid;
1896        int n = 0, n1;
1897
1898        while (n < sizeof(int)) {
1899            n1 = PerlLIO_read(pp[0],
1900                              (void*)(((char*)&errkid)+n),
1901                              (sizeof(int)) - n);
1902            if (n1 <= 0)
1903                break;
1904            n += n1;
1905        }
1906        PerlLIO_close(pp[0]);
1907        did_pipes = 0;
1908        if (n) {                        /* Error */
1909            int pid2, status;
1910            PerlLIO_close(p[This]);
1911            if (n != sizeof(int))
1912                Perl_croak(aTHX_ "panic: kid popen errno read");
1913            do {
1914                pid2 = wait4pid(pid, &status, 0);
1915            } while (pid2 == -1 && errno == EINTR);
1916            errno = errkid;             /* Propagate errno from kid */
1917            return Nullfp;
1918        }
1919    }
1920    if (did_pipes)
1921         PerlLIO_close(pp[0]);
1922    return PerlIO_fdopen(p[This], mode);
1923#else
1924    Perl_croak(aTHX_ "List form of piped open not implemented");
1925    return (PerlIO *) NULL;
1926#endif
1927}
1928
1929    /* VMS' my_popen() is in VMS.c, same with OS/2. */
1930#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1931PerlIO *
1932Perl_my_popen(pTHX_ char *cmd, char *mode)
1933{
1934    int p[2];
1935    register I32 This, that;
1936    register Pid_t pid;
1937    SV *sv;
1938    I32 doexec = strNE(cmd,"-");
1939    I32 did_pipes = 0;
1940    int pp[2];
1941
1942    PERL_FLUSHALL_FOR_CHILD;
1943#ifdef OS2
1944    if (doexec) {
1945        return my_syspopen(aTHX_ cmd,mode);
1946    }
1947#endif
1948    This = (*mode == 'w');
1949    that = !This;
1950    if (doexec && PL_tainting) {
1951        taint_env();
1952        taint_proper("Insecure %s%s", "EXEC");
1953    }
1954    if (PerlProc_pipe(p) < 0)
1955        return Nullfp;
1956    if (doexec && PerlProc_pipe(pp) >= 0)
1957        did_pipes = 1;
1958    while ((pid = PerlProc_fork()) < 0) {
1959        if (errno != EAGAIN) {
1960            PerlLIO_close(p[This]);
1961            PerlLIO_close(p[that]);
1962            if (did_pipes) {
1963                PerlLIO_close(pp[0]);
1964                PerlLIO_close(pp[1]);
1965            }
1966            if (!doexec)
1967                Perl_croak(aTHX_ "Can't fork");
1968            return Nullfp;
1969        }
1970        sleep(5);
1971    }
1972    if (pid == 0) {
1973        GV* tmpgv;
1974
1975#undef THIS
1976#undef THAT
1977#define THIS that
1978#define THAT This
1979        if (did_pipes) {
1980            PerlLIO_close(pp[0]);
1981#if defined(HAS_FCNTL) && defined(F_SETFD)
1982            fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1983#endif
1984        }
1985        if (p[THIS] != (*mode == 'r')) {
1986            PerlLIO_dup2(p[THIS], *mode == 'r');
1987            PerlLIO_close(p[THIS]);
1988            if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1989                PerlLIO_close(p[THAT]);
1990        }
1991        else
1992            PerlLIO_close(p[THAT]);
1993#ifndef OS2
1994        if (doexec) {
1995#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1996            int fd;
1997
1998#ifndef NOFILE
1999#define NOFILE 20
2000#endif
2001            {
2002                int fd;
2003
2004                for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2005                    if (fd != pp[1])
2006                        PerlLIO_close(fd);
2007            }
2008#endif
2009            /* may or may not use the shell */
2010            do_exec3(cmd, pp[1], did_pipes);
2011            PerlProc__exit(1);
2012        }
2013#endif  /* defined OS2 */
2014        /*SUPPRESS 560*/
2015        if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2016            SvREADONLY_off(GvSV(tmpgv));
2017            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2018            SvREADONLY_on(GvSV(tmpgv));
2019        }
2020#ifdef THREADS_HAVE_PIDS
2021        PL_ppid = (IV)getppid();
2022#endif
2023        PL_forkprocess = 0;
2024        hv_clear(PL_pidstatus); /* we have no children */
2025        return Nullfp;
2026#undef THIS
2027#undef THAT
2028    }
2029    do_execfree();      /* free any memory malloced by child on vfork */
2030    if (did_pipes)
2031        PerlLIO_close(pp[1]);
2032    if (p[that] < p[This]) {
2033        PerlLIO_dup2(p[This], p[that]);
2034        PerlLIO_close(p[This]);
2035        p[This] = p[that];
2036    }
2037    else
2038        PerlLIO_close(p[that]);
2039
2040    LOCK_FDPID_MUTEX;
2041    sv = *av_fetch(PL_fdpid,p[This],TRUE);
2042    UNLOCK_FDPID_MUTEX;
2043    (void)SvUPGRADE(sv,SVt_IV);
2044    SvIVX(sv) = pid;
2045    PL_forkprocess = pid;
2046    if (did_pipes && pid > 0) {
2047        int errkid;
2048        int n = 0, n1;
2049
2050        while (n < sizeof(int)) {
2051            n1 = PerlLIO_read(pp[0],
2052                              (void*)(((char*)&errkid)+n),
2053                              (sizeof(int)) - n);
2054            if (n1 <= 0)
2055                break;
2056            n += n1;
2057        }
2058        PerlLIO_close(pp[0]);
2059        did_pipes = 0;
2060        if (n) {                        /* Error */
2061            int pid2, status;
2062            PerlLIO_close(p[This]);
2063            if (n != sizeof(int))
2064                Perl_croak(aTHX_ "panic: kid popen errno read");
2065            do {
2066                pid2 = wait4pid(pid, &status, 0);
2067            } while (pid2 == -1 && errno == EINTR);
2068            errno = errkid;             /* Propagate errno from kid */
2069            return Nullfp;
2070        }
2071    }
2072    if (did_pipes)
2073         PerlLIO_close(pp[0]);
2074    return PerlIO_fdopen(p[This], mode);
2075}
2076#else
2077#if defined(atarist) || defined(EPOC)
2078FILE *popen();
2079PerlIO *
2080Perl_my_popen(pTHX_ char *cmd, char *mode)
2081{
2082    PERL_FLUSHALL_FOR_CHILD;
2083    /* Call system's popen() to get a FILE *, then import it.
2084       used 0 for 2nd parameter to PerlIO_importFILE;
2085       apparently not used
2086    */
2087    return PerlIO_importFILE(popen(cmd, mode), 0);
2088}
2089#else
2090#if defined(DJGPP)
2091FILE *djgpp_popen();
2092PerlIO *
2093Perl_my_popen(pTHX_ char *cmd, char *mode)
2094{
2095    PERL_FLUSHALL_FOR_CHILD;
2096    /* Call system's popen() to get a FILE *, then import it.
2097       used 0 for 2nd parameter to PerlIO_importFILE;
2098       apparently not used
2099    */
2100    return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2101}
2102#endif
2103#endif
2104
2105#endif /* !DOSISH */
2106
2107/* this is called in parent before the fork() */
2108void
2109Perl_atfork_lock(void)
2110{
2111#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2112    /* locks must be held in locking order (if any) */
2113#  ifdef MYMALLOC
2114    MUTEX_LOCK(&PL_malloc_mutex);
2115#  endif
2116    OP_REFCNT_LOCK;
2117#endif
2118}
2119
2120/* this is called in both parent and child after the fork() */
2121void
2122Perl_atfork_unlock(void)
2123{
2124#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2125    /* locks must be released in same order as in atfork_lock() */
2126#  ifdef MYMALLOC
2127    MUTEX_UNLOCK(&PL_malloc_mutex);
2128#  endif
2129    OP_REFCNT_UNLOCK;
2130#endif
2131}
2132
2133Pid_t
2134Perl_my_fork(void)
2135{
2136#if defined(HAS_FORK)
2137    Pid_t pid;
2138#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2139    atfork_lock();
2140    pid = fork();
2141    atfork_unlock();
2142#else
2143    /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2144     * handlers elsewhere in the code */
2145    pid = fork();
2146#endif
2147    return pid;
2148#else
2149    /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2150    Perl_croak_nocontext("fork() not available");
2151    return 0;
2152#endif /* HAS_FORK */
2153}
2154
2155#ifdef DUMP_FDS
2156void
2157Perl_dump_fds(pTHX_ char *s)
2158{
2159    int fd;
2160    Stat_t tmpstatbuf;
2161
2162    PerlIO_printf(Perl_debug_log,"%s", s);
2163    for (fd = 0; fd < 32; fd++) {
2164        if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2165            PerlIO_printf(Perl_debug_log," %d",fd);
2166    }
2167    PerlIO_printf(Perl_debug_log,"\n");
2168}
2169#endif  /* DUMP_FDS */
2170
2171#ifndef HAS_DUP2
2172int
2173dup2(int oldfd, int newfd)
2174{
2175#if defined(HAS_FCNTL) && defined(F_DUPFD)
2176    if (oldfd == newfd)
2177        return oldfd;
2178    PerlLIO_close(newfd);
2179    return fcntl(oldfd, F_DUPFD, newfd);
2180#else
2181#define DUP2_MAX_FDS 256
2182    int fdtmp[DUP2_MAX_FDS];
2183    I32 fdx = 0;
2184    int fd;
2185
2186    if (oldfd == newfd)
2187        return oldfd;
2188    PerlLIO_close(newfd);
2189    /* good enough for low fd's... */
2190    while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2191        if (fdx >= DUP2_MAX_FDS) {
2192            PerlLIO_close(fd);
2193            fd = -1;
2194            break;
2195        }
2196        fdtmp[fdx++] = fd;
2197    }
2198    while (fdx > 0)
2199        PerlLIO_close(fdtmp[--fdx]);
2200    return fd;
2201#endif
2202}
2203#endif
2204
2205#ifndef PERL_MICRO
2206#ifdef HAS_SIGACTION
2207
2208#ifdef MACOS_TRADITIONAL
2209/* We don't want restart behavior on MacOS */
2210#undef SA_RESTART
2211#endif
2212
2213Sighandler_t
2214Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2215{
2216    struct sigaction act, oact;
2217
2218#ifdef USE_ITHREADS
2219    /* only "parent" interpreter can diddle signals */
2220    if (PL_curinterp != aTHX)
2221        return SIG_ERR;
2222#endif
2223
2224    act.sa_handler = handler;
2225    sigemptyset(&act.sa_mask);
2226    act.sa_flags = 0;
2227#ifdef SA_RESTART
2228    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2229        act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2230#endif
2231#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2232    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2233        act.sa_flags |= SA_NOCLDWAIT;
2234#endif
2235    if (sigaction(signo, &act, &oact) == -1)
2236        return SIG_ERR;
2237    else
2238        return oact.sa_handler;
2239}
2240
2241Sighandler_t
2242Perl_rsignal_state(pTHX_ int signo)
2243{
2244    struct sigaction oact;
2245
2246    if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2247        return SIG_ERR;
2248    else
2249        return oact.sa_handler;
2250}
2251
2252int
2253Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2254{
2255    struct sigaction act;
2256
2257#ifdef USE_ITHREADS
2258    /* only "parent" interpreter can diddle signals */
2259    if (PL_curinterp != aTHX)
2260        return -1;
2261#endif
2262
2263    act.sa_handler = handler;
2264    sigemptyset(&act.sa_mask);
2265    act.sa_flags = 0;
2266#ifdef SA_RESTART
2267    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2268        act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2269#endif
2270#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2271    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2272        act.sa_flags |= SA_NOCLDWAIT;
2273#endif
2274    return sigaction(signo, &act, save);
2275}
2276
2277int
2278Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2279{
2280#ifdef USE_ITHREADS
2281    /* only "parent" interpreter can diddle signals */
2282    if (PL_curinterp != aTHX)
2283        return -1;
2284#endif
2285
2286    return sigaction(signo, save, (struct sigaction *)NULL);
2287}
2288
2289#else /* !HAS_SIGACTION */
2290
2291Sighandler_t
2292Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2293{
2294#if defined(USE_ITHREADS) && !defined(WIN32)
2295    /* only "parent" interpreter can diddle signals */
2296    if (PL_curinterp != aTHX)
2297        return SIG_ERR;
2298#endif
2299
2300    return PerlProc_signal(signo, handler);
2301}
2302
2303static int sig_trapped; /* XXX signals are process-wide anyway, so we
2304                           ignore the implications of this for threading */
2305
2306static
2307Signal_t
2308sig_trap(int signo)
2309{
2310    sig_trapped++;
2311}
2312
2313Sighandler_t
2314Perl_rsignal_state(pTHX_ int signo)
2315{
2316    Sighandler_t oldsig;
2317
2318#if defined(USE_ITHREADS) && !defined(WIN32)
2319    /* only "parent" interpreter can diddle signals */
2320    if (PL_curinterp != aTHX)
2321        return SIG_ERR;
2322#endif
2323
2324    sig_trapped = 0;
2325    oldsig = PerlProc_signal(signo, sig_trap);
2326    PerlProc_signal(signo, oldsig);
2327    if (sig_trapped)
2328        PerlProc_kill(PerlProc_getpid(), signo);
2329    return oldsig;
2330}
2331
2332int
2333Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2334{
2335#if defined(USE_ITHREADS) && !defined(WIN32)
2336    /* only "parent" interpreter can diddle signals */
2337    if (PL_curinterp != aTHX)
2338        return -1;
2339#endif
2340    *save = PerlProc_signal(signo, handler);
2341    return (*save == SIG_ERR) ? -1 : 0;
2342}
2343
2344int
2345Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2346{
2347#if defined(USE_ITHREADS) && !defined(WIN32)
2348    /* only "parent" interpreter can diddle signals */
2349    if (PL_curinterp != aTHX)
2350        return -1;
2351#endif
2352    return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2353}
2354
2355#endif /* !HAS_SIGACTION */
2356#endif /* !PERL_MICRO */
2357
2358    /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2359#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2360I32
2361Perl_my_pclose(pTHX_ PerlIO *ptr)
2362{
2363    Sigsave_t hstat, istat, qstat;
2364    int status;
2365    SV **svp;
2366    Pid_t pid;
2367    Pid_t pid2;
2368    bool close_failed;
2369    int saved_errno = 0;
2370#ifdef VMS
2371    int saved_vaxc_errno;
2372#endif
2373#ifdef WIN32
2374    int saved_win32_errno;
2375#endif
2376
2377    LOCK_FDPID_MUTEX;
2378    svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2379    UNLOCK_FDPID_MUTEX;
2380    pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2381    SvREFCNT_dec(*svp);
2382    *svp = &PL_sv_undef;
2383#ifdef OS2
2384    if (pid == -1) {                    /* Opened by popen. */
2385        return my_syspclose(ptr);
2386    }
2387#endif
2388    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2389        saved_errno = errno;
2390#ifdef VMS
2391        saved_vaxc_errno = vaxc$errno;
2392#endif
2393#ifdef WIN32
2394        saved_win32_errno = GetLastError();
2395#endif
2396    }
2397#ifdef UTS
2398    if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2399#endif
2400#ifndef PERL_MICRO
2401    rsignal_save(SIGHUP, SIG_IGN, &hstat);
2402    rsignal_save(SIGINT, SIG_IGN, &istat);
2403    rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2404#endif
2405    do {
2406        pid2 = wait4pid(pid, &status, 0);
2407    } while (pid2 == -1 && errno == EINTR);
2408#ifndef PERL_MICRO
2409    rsignal_restore(SIGHUP, &hstat);
2410    rsignal_restore(SIGINT, &istat);
2411    rsignal_restore(SIGQUIT, &qstat);
2412#endif
2413    if (close_failed) {
2414        SETERRNO(saved_errno, saved_vaxc_errno);
2415        return -1;
2416    }
2417    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2418}
2419#endif /* !DOSISH */
2420
2421#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2422I32
2423Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2424{
2425    I32 result;
2426    if (!pid)
2427        return -1;
2428#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2429    {
2430        SV *sv;
2431        SV** svp;
2432        char spid[TYPE_CHARS(int)];
2433
2434        if (pid > 0) {
2435            sprintf(spid, "%"IVdf, (IV)pid);
2436            svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2437            if (svp && *svp != &PL_sv_undef) {
2438                *statusp = SvIVX(*svp);
2439                (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2440                return pid;
2441            }
2442        }
2443        else {
2444            HE *entry;
2445
2446            hv_iterinit(PL_pidstatus);
2447            if ((entry = hv_iternext(PL_pidstatus))) {
2448                SV *sv;
2449                char spid[TYPE_CHARS(int)];
2450
2451                pid = atoi(hv_iterkey(entry,(I32*)statusp));
2452                sv = hv_iterval(PL_pidstatus,entry);
2453                *statusp = SvIVX(sv);
2454                sprintf(spid, "%"IVdf, (IV)pid);
2455                (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2456                return pid;
2457            }
2458        }
2459    }
2460#endif
2461#ifdef HAS_WAITPID
2462#  ifdef HAS_WAITPID_RUNTIME
2463    if (!HAS_WAITPID_RUNTIME)
2464        goto hard_way;
2465#  endif
2466    result = PerlProc_waitpid(pid,statusp,flags);
2467    goto finish;
2468#endif
2469#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2470    result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2471    goto finish;
2472#endif
2473#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2474  hard_way:
2475    {
2476        if (flags)
2477            Perl_croak(aTHX_ "Can't do waitpid with flags");
2478        else {
2479            while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2480                pidgone(result,*statusp);
2481            if (result < 0)
2482                *statusp = -1;
2483        }
2484    }
2485#endif
2486  finish:
2487    if (result < 0 && errno == EINTR) {
2488        PERL_ASYNC_CHECK();
2489    }
2490    return result;
2491}
2492#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2493
2494void
2495/*SUPPRESS 590*/
2496Perl_pidgone(pTHX_ Pid_t pid, int status)
2497{
2498    register SV *sv;
2499    char spid[TYPE_CHARS(int)];
2500
2501    sprintf(spid, "%"IVdf, (IV)pid);
2502    sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2503    (void)SvUPGRADE(sv,SVt_IV);
2504    SvIVX(sv) = status;
2505    return;
2506}
2507
2508#if defined(atarist) || defined(OS2) || defined(EPOC)
2509int pclose();
2510#ifdef HAS_FORK
2511int                                     /* Cannot prototype with I32
2512                                           in os2ish.h. */
2513my_syspclose(PerlIO *ptr)
2514#else
2515I32
2516Perl_my_pclose(pTHX_ PerlIO *ptr)
2517#endif
2518{
2519    /* Needs work for PerlIO ! */
2520    FILE *f = PerlIO_findFILE(ptr);
2521    I32 result = pclose(f);
2522    PerlIO_releaseFILE(ptr,f);
2523    return result;
2524}
2525#endif
2526
2527#if defined(DJGPP)
2528int djgpp_pclose();
2529I32
2530Perl_my_pclose(pTHX_ PerlIO *ptr)
2531{
2532    /* Needs work for PerlIO ! */
2533    FILE *f = PerlIO_findFILE(ptr);
2534    I32 result = djgpp_pclose(f);
2535    result = (result << 8) & 0xff00;
2536    PerlIO_releaseFILE(ptr,f);
2537    return result;
2538}
2539#endif
2540
2541void
2542Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2543{
2544    register I32 todo;
2545    register const char *frombase = from;
2546
2547    if (len == 1) {
2548        register const char c = *from;
2549        while (count-- > 0)
2550            *to++ = c;
2551        return;
2552    }
2553    while (count-- > 0) {
2554        for (todo = len; todo > 0; todo--) {
2555            *to++ = *from++;
2556        }
2557        from = frombase;
2558    }
2559}
2560
2561#ifndef HAS_RENAME
2562I32
2563Perl_same_dirent(pTHX_ char *a, char *b)
2564{
2565    char *fa = strrchr(a,'/');
2566    char *fb = strrchr(b,'/');
2567    Stat_t tmpstatbuf1;
2568    Stat_t tmpstatbuf2;
2569    SV *tmpsv = sv_newmortal();
2570
2571    if (fa)
2572        fa++;
2573    else
2574        fa = a;
2575    if (fb)
2576        fb++;
2577    else
2578        fb = b;
2579    if (strNE(a,b))
2580        return FALSE;
2581    if (fa == a)
2582        sv_setpv(tmpsv, ".");
2583    else
2584        sv_setpvn(tmpsv, a, fa - a);
2585    if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2586        return FALSE;
2587    if (fb == b)
2588        sv_setpv(tmpsv, ".");
2589    else
2590        sv_setpvn(tmpsv, b, fb - b);
2591    if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2592        return FALSE;
2593    return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2594           tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2595}
2596#endif /* !HAS_RENAME */
2597
2598char*
2599Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2600{
2601    char *xfound = Nullch;
2602    char *xfailed = Nullch;
2603    char tmpbuf[MAXPATHLEN];
2604    register char *s;
2605    I32 len = 0;
2606    int retval;
2607#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2608#  define SEARCH_EXTS ".bat", ".cmd", NULL
2609#  define MAX_EXT_LEN 4
2610#endif
2611#ifdef OS2
2612#  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2613#  define MAX_EXT_LEN 4
2614#endif
2615#ifdef VMS
2616#  define SEARCH_EXTS ".pl", ".com", NULL
2617#  define MAX_EXT_LEN 4
2618#endif
2619    /* additional extensions to try in each dir if scriptname not found */
2620#ifdef SEARCH_EXTS
2621    char *exts[] = { SEARCH_EXTS };
2622    char **ext = search_ext ? search_ext : exts;
2623    int extidx = 0, i = 0;
2624    char *curext = Nullch;
2625#else
2626#  define MAX_EXT_LEN 0
2627#endif
2628
2629    /*
2630     * If dosearch is true and if scriptname does not contain path
2631     * delimiters, search the PATH for scriptname.
2632     *
2633     * If SEARCH_EXTS is also defined, will look for each
2634     * scriptname{SEARCH_EXTS} whenever scriptname is not found
2635     * while searching the PATH.
2636     *
2637     * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2638     * proceeds as follows:
2639     *   If DOSISH or VMSISH:
2640     *     + look for ./scriptname{,.foo,.bar}
2641     *     + search the PATH for scriptname{,.foo,.bar}
2642     *
2643     *   If !DOSISH:
2644     *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2645     *       this will not look in '.' if it's not in the PATH)
2646     */
2647    tmpbuf[0] = '\0';
2648
2649#ifdef VMS
2650#  ifdef ALWAYS_DEFTYPES
2651    len = strlen(scriptname);
2652    if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2653        int hasdir, idx = 0, deftypes = 1;
2654        bool seen_dot = 1;
2655
2656        hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2657#  else
2658    if (dosearch) {
2659        int hasdir, idx = 0, deftypes = 1;
2660        bool seen_dot = 1;
2661
2662        hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2663#  endif
2664        /* The first time through, just add SEARCH_EXTS to whatever we
2665         * already have, so we can check for default file types. */
2666        while (deftypes ||
2667               (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2668        {
2669            if (deftypes) {
2670                deftypes = 0;
2671                *tmpbuf = '\0';
2672            }
2673            if ((strlen(tmpbuf) + strlen(scriptname)
2674                 + MAX_EXT_LEN) >= sizeof tmpbuf)
2675                continue;       /* don't search dir with too-long name */
2676            strcat(tmpbuf, scriptname);
2677#else  /* !VMS */
2678
2679#ifdef DOSISH
2680    if (strEQ(scriptname, "-"))
2681        dosearch = 0;
2682    if (dosearch) {             /* Look in '.' first. */
2683        char *cur = scriptname;
2684#ifdef SEARCH_EXTS
2685        if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2686            while (ext[i])
2687                if (strEQ(ext[i++],curext)) {
2688                    extidx = -1;                /* already has an ext */
2689                    break;
2690                }
2691        do {
2692#endif
2693            DEBUG_p(PerlIO_printf(Perl_debug_log,
2694                                  "Looking for %s\n",cur));
2695            if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2696                && !S_ISDIR(PL_statbuf.st_mode)) {
2697                dosearch = 0;
2698                scriptname = cur;
2699#ifdef SEARCH_EXTS
2700                break;
2701#endif
2702            }
2703#ifdef SEARCH_EXTS
2704            if (cur == scriptname) {
2705                len = strlen(scriptname);
2706                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2707                    break;
2708                cur = strcpy(tmpbuf, scriptname);
2709            }
2710        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2711                 && strcpy(tmpbuf+len, ext[extidx++]));
2712#endif
2713    }
2714#endif
2715
2716#ifdef MACOS_TRADITIONAL
2717    if (dosearch && !strchr(scriptname, ':') &&
2718        (s = PerlEnv_getenv("Commands")))
2719#else
2720    if (dosearch && !strchr(scriptname, '/')
2721#ifdef DOSISH
2722                 && !strchr(scriptname, '\\')
2723#endif
2724                 && (s = PerlEnv_getenv("PATH")))
2725#endif
2726    {
2727        bool seen_dot = 0;
2728       
2729        PL_bufend = s + strlen(s);
2730        while (s < PL_bufend) {
2731#ifdef MACOS_TRADITIONAL
2732            s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2733                        ',',
2734                        &len);
2735#else
2736#if defined(atarist) || defined(DOSISH)
2737            for (len = 0; *s
2738#  ifdef atarist
2739                    && *s != ','
2740#  endif
2741                    && *s != ';'; len++, s++) {
2742                if (len < sizeof tmpbuf)
2743                    tmpbuf[len] = *s;
2744            }
2745            if (len < sizeof tmpbuf)
2746                tmpbuf[len] = '\0';
2747#else  /* ! (atarist || DOSISH) */
2748            s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2749                        ':',
2750                        &len);
2751#endif /* ! (atarist || DOSISH) */
2752#endif /* MACOS_TRADITIONAL */
2753            if (s < PL_bufend)
2754                s++;
2755            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2756                continue;       /* don't search dir with too-long name */
2757#ifdef MACOS_TRADITIONAL
2758            if (len && tmpbuf[len - 1] != ':')
2759                tmpbuf[len++] = ':';
2760#else
2761            if (len
2762#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2763                && tmpbuf[len - 1] != '/'
2764                && tmpbuf[len - 1] != '\\'
2765#endif
2766               )
2767                tmpbuf[len++] = '/';
2768            if (len == 2 && tmpbuf[0] == '.')
2769                seen_dot = 1;
2770#endif
2771            (void)strcpy(tmpbuf + len, scriptname);
2772#endif  /* !VMS */
2773
2774#ifdef SEARCH_EXTS
2775            len = strlen(tmpbuf);
2776            if (extidx > 0)     /* reset after previous loop */
2777                extidx = 0;
2778            do {
2779#endif
2780                DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2781                retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2782                if (S_ISDIR(PL_statbuf.st_mode)) {
2783                    retval = -1;
2784                }
2785#ifdef SEARCH_EXTS
2786            } while (  retval < 0               /* not there */
2787                    && extidx>=0 && ext[extidx] /* try an extension? */
2788                    && strcpy(tmpbuf+len, ext[extidx++])
2789                );
2790#endif
2791            if (retval < 0)
2792                continue;
2793            if (S_ISREG(PL_statbuf.st_mode)
2794                && cando(S_IRUSR,TRUE,&PL_statbuf)
2795#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2796                && cando(S_IXUSR,TRUE,&PL_statbuf)
2797#endif
2798                )
2799            {
2800                xfound = tmpbuf;                /* bingo! */
2801                break;
2802            }
2803            if (!xfailed)
2804                xfailed = savepv(tmpbuf);
2805        }
2806#ifndef DOSISH
2807        if (!xfound && !seen_dot && !xfailed &&
2808            (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2809             || S_ISDIR(PL_statbuf.st_mode)))
2810#endif
2811            seen_dot = 1;                       /* Disable message. */
2812        if (!xfound) {
2813            if (flags & 1) {                    /* do or die? */
2814                Perl_croak(aTHX_ "Can't %s %s%s%s",
2815                      (xfailed ? "execute" : "find"),
2816                      (xfailed ? xfailed : scriptname),
2817                      (xfailed ? "" : " on PATH"),
2818                      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2819            }
2820            scriptname = Nullch;
2821        }
2822        if (xfailed)
2823            Safefree(xfailed);
2824        scriptname = xfound;
2825    }
2826    return (scriptname ? savepv(scriptname) : Nullch);
2827}
2828
2829#ifndef PERL_GET_CONTEXT_DEFINED
2830
2831void *
2832Perl_get_context(void)
2833{
2834#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2835#  ifdef OLD_PTHREADS_API
2836    pthread_addr_t t;
2837    if (pthread_getspecific(PL_thr_key, &t))
2838        Perl_croak_nocontext("panic: pthread_getspecific");
2839    return (void*)t;
2840#  else
2841#    ifdef I_MACH_CTHREADS
2842    return (void*)cthread_data(cthread_self());
2843#    else
2844    return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2845#    endif
2846#  endif
2847#else
2848    return (void*)NULL;
2849#endif
2850}
2851
2852void
2853Perl_set_context(void *t)
2854{
2855#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2856#  ifdef I_MACH_CTHREADS
2857    cthread_set_data(cthread_self(), t);
2858#  else
2859    if (pthread_setspecific(PL_thr_key, t))
2860        Perl_croak_nocontext("panic: pthread_setspecific");
2861#  endif
2862#endif
2863}
2864
2865#endif /* !PERL_GET_CONTEXT_DEFINED */
2866
2867#ifdef USE_5005THREADS
2868
2869#ifdef FAKE_THREADS
2870/* Very simplistic scheduler for now */
2871void
2872schedule(void)
2873{
2874    thr = thr->i.next_run;
2875}
2876
2877void
2878Perl_cond_init(pTHX_ perl_cond *cp)
2879{
2880    *cp = 0;
2881}
2882
2883void
2884Perl_cond_signal(pTHX_ perl_cond *cp)
2885{
2886    perl_os_thread t;
2887    perl_cond cond = *cp;
2888
2889    if (!cond)
2890        return;
2891    t = cond->thread;
2892    /* Insert t in the runnable queue just ahead of us */
2893    t->i.next_run = thr->i.next_run;
2894    thr->i.next_run->i.prev_run = t;
2895    t->i.prev_run = thr;
2896    thr->i.next_run = t;
2897    thr->i.wait_queue = 0;
2898    /* Remove from the wait queue */
2899    *cp = cond->next;
2900    Safefree(cond);
2901}
2902
2903void
2904Perl_cond_broadcast(pTHX_ perl_cond *cp)
2905{
2906    perl_os_thread t;
2907    perl_cond cond, cond_next;
2908
2909    for (cond = *cp; cond; cond = cond_next) {
2910        t = cond->thread;
2911        /* Insert t in the runnable queue just ahead of us */
2912        t->i.next_run = thr->i.next_run;
2913        thr->i.next_run->i.prev_run = t;
2914        t->i.prev_run = thr;
2915        thr->i.next_run = t;
2916        thr->i.wait_queue = 0;
2917        /* Remove from the wait queue */
2918        cond_next = cond->next;
2919        Safefree(cond);
2920    }
2921    *cp = 0;
2922}
2923
2924void
2925Perl_cond_wait(pTHX_ perl_cond *cp)
2926{
2927    perl_cond cond;
2928
2929    if (thr->i.next_run == thr)
2930        Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
2931
2932    New(666, cond, 1, struct perl_wait_queue);
2933    cond->thread = thr;
2934    cond->next = *cp;
2935    *cp = cond;
2936    thr->i.wait_queue = cond;
2937    /* Remove ourselves from runnable queue */
2938    thr->i.next_run->i.prev_run = thr->i.prev_run;
2939    thr->i.prev_run->i.next_run = thr->i.next_run;
2940}
2941#endif /* FAKE_THREADS */
2942
2943MAGIC *
2944Perl_condpair_magic(pTHX_ SV *sv)
2945{
2946    MAGIC *mg;
2947
2948    (void)SvUPGRADE(sv, SVt_PVMG);
2949    mg = mg_find(sv, PERL_MAGIC_mutex);
2950    if (!mg) {
2951        condpair_t *cp;
2952
2953        New(53, cp, 1, condpair_t);
2954        MUTEX_INIT(&cp->mutex);
2955        COND_INIT(&cp->owner_cond);
2956        COND_INIT(&cp->cond);
2957        cp->owner = 0;
2958        LOCK_CRED_MUTEX;                /* XXX need separate mutex? */
2959        mg = mg_find(sv, PERL_MAGIC_mutex);
2960        if (mg) {
2961            /* someone else beat us to initialising it */
2962            UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
2963            MUTEX_DESTROY(&cp->mutex);
2964            COND_DESTROY(&cp->owner_cond);
2965            COND_DESTROY(&cp->cond);
2966            Safefree(cp);
2967        }
2968        else {
2969            sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
2970            mg = SvMAGIC(sv);
2971            mg->mg_ptr = (char *)cp;
2972            mg->mg_len = sizeof(cp);
2973            UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
2974            DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
2975                                           "%p: condpair_magic %p\n", thr, sv)));
2976        }
2977    }
2978    return mg;
2979}
2980
2981SV *
2982Perl_sv_lock(pTHX_ SV *osv)
2983{
2984    MAGIC *mg;
2985    SV *sv = osv;
2986
2987    LOCK_SV_LOCK_MUTEX;
2988    if (SvROK(sv)) {
2989        sv = SvRV(sv);
2990    }
2991
2992    mg = condpair_magic(sv);
2993    MUTEX_LOCK(MgMUTEXP(mg));
2994    if (MgOWNER(mg) == thr)
2995        MUTEX_UNLOCK(MgMUTEXP(mg));
2996    else {
2997        while (MgOWNER(mg))
2998            COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2999        MgOWNER(mg) = thr;
3000        DEBUG_S(PerlIO_printf(Perl_debug_log,
3001                              "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3002                              PTR2UV(thr), PTR2UV(sv)));
3003        MUTEX_UNLOCK(MgMUTEXP(mg));
3004        SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3005    }
3006    UNLOCK_SV_LOCK_MUTEX;
3007    return sv;
3008}
3009
3010/*
3011 * Make a new perl thread structure using t as a prototype. Some of the
3012 * fields for the new thread are copied from the prototype thread, t,
3013 * so t should not be running in perl at the time this function is
3014 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3015 * thread calling new_struct_thread) clearly satisfies this constraint.
3016 */
3017struct perl_thread *
3018Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3019{
3020#if !defined(PERL_IMPLICIT_CONTEXT)
3021    struct perl_thread *thr;
3022#endif
3023    SV *sv;
3024    SV **svp;
3025    I32 i;
3026
3027    sv = newSVpvn("", 0);
3028    SvGROW(sv, sizeof(struct perl_thread) + 1);
3029    SvCUR_set(sv, sizeof(struct perl_thread));
3030    thr = (Thread) SvPVX(sv);
3031#ifdef DEBUGGING
3032    Poison(thr, 1, struct perl_thread);
3033    PL_markstack = 0;
3034    PL_scopestack = 0;
3035    PL_savestack = 0;
3036    PL_retstack = 0;
3037    PL_dirty = 0;
3038    PL_localizing = 0;
3039    Zero(&PL_hv_fetch_ent_mh, 1, HE);
3040    PL_efloatbuf = (char*)NULL;
3041    PL_efloatsize = 0;
3042#else
3043    Zero(thr, 1, struct perl_thread);
3044#endif
3045
3046    thr->oursv = sv;
3047    init_stacks();
3048
3049    PL_curcop = &PL_compiling;
3050    thr->interp = t->interp;
3051    thr->cvcache = newHV();
3052    thr->threadsv = newAV();
3053    thr->specific = newAV();
3054    thr->errsv = newSVpvn("", 0);
3055    thr->flags = THRf_R_JOINABLE;
3056    thr->thr_done = 0;
3057    MUTEX_INIT(&thr->mutex);
3058
3059    JMPENV_BOOTSTRAP;
3060
3061    PL_in_eval = EVAL_NULL;     /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3062    PL_restartop = 0;
3063
3064    PL_statname = NEWSV(66,0);
3065    PL_errors = newSVpvn("", 0);
3066    PL_maxscream = -1;
3067    PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3068    PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3069    PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3070    PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3071    PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3072    PL_regindent = 0;
3073    PL_reginterp_cnt = 0;
3074    PL_lastscream = Nullsv;
3075    PL_screamfirst = 0;
3076    PL_screamnext = 0;
3077    PL_reg_start_tmp = 0;
3078    PL_reg_start_tmpl = 0;
3079    PL_reg_poscache = Nullch;
3080
3081    PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3082
3083    /* parent thread's data needs to be locked while we make copy */
3084    MUTEX_LOCK(&t->mutex);
3085
3086#ifdef PERL_FLEXIBLE_EXCEPTIONS
3087    PL_protect = t->Tprotect;
3088#endif
3089
3090    PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
3091    PL_defstash = t->Tdefstash;   /* XXX maybe these should */
3092    PL_curstash = t->Tcurstash;   /* always be set to main? */
3093
3094    PL_tainted = t->Ttainted;
3095    PL_curpm = t->Tcurpm;       /* XXX No PMOP ref count */
3096    PL_rs = newSVsv(t->Trs);
3097    PL_last_in_gv = Nullgv;
3098    PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3099    PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3100    PL_chopset = t->Tchopset;
3101    PL_bodytarget = newSVsv(t->Tbodytarget);
3102    PL_toptarget = newSVsv(t->Ttoptarget);
3103    if (t->Tformtarget == t->Ttoptarget)
3104        PL_formtarget = PL_toptarget;
3105    else
3106        PL_formtarget = PL_bodytarget;
3107    PL_watchaddr = 0; /* XXX */
3108    PL_watchok = 0; /* XXX */
3109    PL_comppad = 0;
3110    PL_curpad = 0;
3111
3112    /* Initialise all per-thread SVs that the template thread used */
3113    svp = AvARRAY(t->threadsv);
3114    for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3115        if (*svp && *svp != &PL_sv_undef) {
3116            SV *sv = newSVsv(*svp);
3117            av_store(thr->threadsv, i, sv);
3118            sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3119            DEBUG_S(PerlIO_printf(Perl_debug_log,
3120                "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3121                                  (IV)i, t, thr));
3122        }
3123    }
3124    thr->threadsvp = AvARRAY(thr->threadsv);
3125
3126    MUTEX_LOCK(&PL_threads_mutex);
3127    PL_nthreads++;
3128    thr->tid = ++PL_threadnum;
3129    thr->next = t->next;
3130    thr->prev = t;
3131    t->next = thr;
3132    thr->next->prev = thr;
3133    MUTEX_UNLOCK(&PL_threads_mutex);
3134
3135    /* done copying parent's state */
3136    MUTEX_UNLOCK(&t->mutex);
3137
3138#ifdef HAVE_THREAD_INTERN
3139    Perl_init_thread_intern(thr);
3140#endif /* HAVE_THREAD_INTERN */
3141    return thr;
3142}
3143#endif /* USE_5005THREADS */
3144
3145#ifdef PERL_GLOBAL_STRUCT
3146struct perl_vars *
3147Perl_GetVars(pTHX)
3148{
3149 return &PL_Vars;
3150}
3151#endif
3152
3153char **
3154Perl_get_op_names(pTHX)
3155{
3156 return PL_op_name;
3157}
3158
3159char **
3160Perl_get_op_descs(pTHX)
3161{
3162 return PL_op_desc;
3163}
3164
3165char *
3166Perl_get_no_modify(pTHX)
3167{
3168 return (char*)PL_no_modify;
3169}
3170
3171U32 *
3172Perl_get_opargs(pTHX)
3173{
3174 return PL_opargs;
3175}
3176
3177PPADDR_t*
3178Perl_get_ppaddr(pTHX)
3179{
3180 return (PPADDR_t*)PL_ppaddr;
3181}
3182
3183#ifndef HAS_GETENV_LEN
3184char *
3185Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3186{
3187    char *env_trans = PerlEnv_getenv(env_elem);
3188    if (env_trans)
3189        *len = strlen(env_trans);
3190    return env_trans;
3191}
3192#endif
3193
3194
3195MGVTBL*
3196Perl_get_vtbl(pTHX_ int vtbl_id)
3197{
3198    MGVTBL* result = Null(MGVTBL*);
3199
3200    switch(vtbl_id) {
3201    case want_vtbl_sv:
3202        result = &PL_vtbl_sv;
3203        break;
3204    case want_vtbl_env:
3205        result = &PL_vtbl_env;
3206        break;
3207    case want_vtbl_envelem:
3208        result = &PL_vtbl_envelem;
3209        break;
3210    case want_vtbl_sig:
3211        result = &PL_vtbl_sig;
3212        break;
3213    case want_vtbl_sigelem:
3214        result = &PL_vtbl_sigelem;
3215        break;
3216    case want_vtbl_pack:
3217        result = &PL_vtbl_pack;
3218        break;
3219    case want_vtbl_packelem:
3220        result = &PL_vtbl_packelem;
3221        break;
3222    case want_vtbl_dbline:
3223        result = &PL_vtbl_dbline;
3224        break;
3225    case want_vtbl_isa:
3226        result = &PL_vtbl_isa;
3227        break;
3228    case want_vtbl_isaelem:
3229        result = &PL_vtbl_isaelem;
3230        break;
3231    case want_vtbl_arylen:
3232        result = &PL_vtbl_arylen;
3233        break;
3234    case want_vtbl_glob:
3235        result = &PL_vtbl_glob;
3236        break;
3237    case want_vtbl_mglob:
3238        result = &PL_vtbl_mglob;
3239        break;
3240    case want_vtbl_nkeys:
3241        result = &PL_vtbl_nkeys;
3242        break;
3243    case want_vtbl_taint:
3244        result = &PL_vtbl_taint;
3245        break;
3246    case want_vtbl_substr:
3247        result = &PL_vtbl_substr;
3248        break;
3249    case want_vtbl_vec:
3250        result = &PL_vtbl_vec;
3251        break;
3252    case want_vtbl_pos:
3253        result = &PL_vtbl_pos;
3254        break;
3255    case want_vtbl_bm:
3256        result = &PL_vtbl_bm;
3257        break;
3258    case want_vtbl_fm:
3259        result = &PL_vtbl_fm;
3260        break;
3261    case want_vtbl_uvar:
3262        result = &PL_vtbl_uvar;
3263        break;
3264#ifdef USE_5005THREADS
3265    case want_vtbl_mutex:
3266        result = &PL_vtbl_mutex;
3267        break;
3268#endif
3269    case want_vtbl_defelem:
3270        result = &PL_vtbl_defelem;
3271        break;
3272    case want_vtbl_regexp:
3273        result = &PL_vtbl_regexp;
3274        break;
3275    case want_vtbl_regdata:
3276        result = &PL_vtbl_regdata;
3277        break;
3278    case want_vtbl_regdatum:
3279        result = &PL_vtbl_regdatum;
3280        break;
3281#ifdef USE_LOCALE_COLLATE
3282    case want_vtbl_collxfrm:
3283        result = &PL_vtbl_collxfrm;
3284        break;
3285#endif
3286    case want_vtbl_amagic:
3287        result = &PL_vtbl_amagic;
3288        break;
3289    case want_vtbl_amagicelem:
3290        result = &PL_vtbl_amagicelem;
3291        break;
3292    case want_vtbl_backref:
3293        result = &PL_vtbl_backref;
3294        break;
3295    case want_vtbl_utf8:
3296        result = &PL_vtbl_utf8;
3297        break;
3298    }
3299    return result;
3300}
3301
3302I32
3303Perl_my_fflush_all(pTHX)
3304{
3305#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3306    return PerlIO_flush(NULL);
3307#else
3308# if defined(HAS__FWALK)
3309    extern int fflush(FILE *);
3310    /* undocumented, unprototyped, but very useful BSDism */
3311    extern void _fwalk(int (*)(FILE *));
3312    _fwalk(&fflush);
3313    return 0;
3314# else
3315#  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3316    long open_max = -1;
3317#   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3318    open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3319#   else
3320#    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3321    open_max = sysconf(_SC_OPEN_MAX);
3322#     else
3323#      ifdef FOPEN_MAX
3324    open_max = FOPEN_MAX;
3325#      else
3326#       ifdef OPEN_MAX
3327    open_max = OPEN_MAX;
3328#       else
3329#        ifdef _NFILE
3330    open_max = _NFILE;
3331#        endif
3332#       endif
3333#      endif
3334#     endif
3335#    endif
3336    if (open_max > 0) {
3337      long i;
3338      for (i = 0; i < open_max; i++)
3339            if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3340                STDIO_STREAM_ARRAY[i]._file < open_max &&
3341                STDIO_STREAM_ARRAY[i]._flag)
3342                PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3343      return 0;
3344    }
3345#  endif
3346    SETERRNO(EBADF,RMS_IFI);
3347    return EOF;
3348# endif
3349#endif
3350}
3351
3352void
3353Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3354{
3355    char *func =
3356        op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3357        op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3358        PL_op_desc[op];
3359    char *pars = OP_IS_FILETEST(op) ? "" : "()";
3360    char *type = OP_IS_SOCKET(op)
3361            || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3362                ?  "socket" : "filehandle";
3363    char *name = NULL;
3364
3365    if (gv && isGV(gv)) {
3366        name = GvENAME(gv);
3367    }
3368
3369    if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3370        if (ckWARN(WARN_IO)) {
3371            const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3372            if (name && *name)
3373                Perl_warner(aTHX_ packWARN(WARN_IO),
3374                            "Filehandle %s opened only for %sput",
3375                            name, direction);
3376            else
3377                Perl_warner(aTHX_ packWARN(WARN_IO),
3378                            "Filehandle opened only for %sput", direction);
3379        }
3380    }
3381    else {
3382        char *vile;
3383        I32   warn_type;
3384
3385        if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3386            vile = "closed";
3387            warn_type = WARN_CLOSED;
3388        }
3389        else {
3390            vile = "unopened";
3391            warn_type = WARN_UNOPENED;
3392        }
3393
3394        if (ckWARN(warn_type)) {
3395            if (name && *name) {
3396                Perl_warner(aTHX_ packWARN(warn_type),
3397                            "%s%s on %s %s %s", func, pars, vile, type, name);
3398                if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3399                    Perl_warner(
3400                        aTHX_ packWARN(warn_type),
3401                        "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3402                        func, pars, name
3403                    );
3404            }
3405            else {
3406                Perl_warner(aTHX_ packWARN(warn_type),
3407                            "%s%s on %s %s", func, pars, vile, type);
3408                if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3409                    Perl_warner(
3410                        aTHX_ packWARN(warn_type),
3411                        "\t(Are you trying to call %s%s on dirhandle?)\n",
3412                        func, pars
3413                    );
3414            }
3415        }
3416    }
3417}
3418
3419#ifdef EBCDIC
3420/* in ASCII order, not that it matters */
3421static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3422
3423int
3424Perl_ebcdic_control(pTHX_ int ch)
3425{
3426    if (ch > 'a') {
3427        char *ctlp;
3428
3429        if (islower(ch))
3430            ch = toupper(ch);
3431
3432        if ((ctlp = strchr(controllablechars, ch)) == 0) {
3433            Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3434        }
3435
3436        if (ctlp == controllablechars)
3437            return('\177'); /* DEL */
3438        else
3439            return((unsigned char)(ctlp - controllablechars - 1));
3440    } else { /* Want uncontrol */
3441        if (ch == '\177' || ch == -1)
3442            return('?');
3443        else if (ch == '\157')
3444            return('\177');
3445        else if (ch == '\174')
3446            return('\000');
3447        else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3448            return('\036');
3449        else if (ch == '\155')
3450            return('\037');
3451        else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3452            return(controllablechars[ch+1]);
3453        else
3454            Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3455    }
3456}
3457#endif
3458
3459/* To workaround core dumps from the uninitialised tm_zone we get the
3460 * system to give us a reasonable struct to copy.  This fix means that
3461 * strftime uses the tm_zone and tm_gmtoff values returned by
3462 * localtime(time()). That should give the desired result most of the
3463 * time. But probably not always!
3464 *
3465 * This does not address tzname aspects of NETaa14816.
3466 *
3467 */
3468
3469#ifdef HAS_GNULIBC
3470# ifndef STRUCT_TM_HASZONE
3471#    define STRUCT_TM_HASZONE
3472# endif
3473#endif
3474
3475#ifdef STRUCT_TM_HASZONE /* Backward compat */
3476# ifndef HAS_TM_TM_ZONE
3477#    define HAS_TM_TM_ZONE
3478# endif
3479#endif
3480
3481void
3482Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3483{
3484#ifdef HAS_TM_TM_ZONE
3485    Time_t now;
3486    (void)time(&now);
3487    Copy(localtime(&now), ptm, 1, struct tm);
3488#endif
3489}
3490
3491/*
3492 * mini_mktime - normalise struct tm values without the localtime()
3493 * semantics (and overhead) of mktime().
3494 */
3495void
3496Perl_mini_mktime(pTHX_ struct tm *ptm)
3497{
3498    int yearday;
3499    int secs;
3500    int month, mday, year, jday;
3501    int odd_cent, odd_year;
3502
3503#define DAYS_PER_YEAR   365
3504#define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3505#define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3506#define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3507#define SECS_PER_HOUR   (60*60)
3508#define SECS_PER_DAY    (24*SECS_PER_HOUR)
3509/* parentheses deliberately absent on these two, otherwise they don't work */
3510#define MONTH_TO_DAYS   153/5
3511#define DAYS_TO_MONTH   5/153
3512/* offset to bias by March (month 4) 1st between month/mday & year finding */
3513#define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3514/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3515#define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3516
3517/*
3518 * Year/day algorithm notes:
3519 *
3520 * With a suitable offset for numeric value of the month, one can find
3521 * an offset into the year by considering months to have 30.6 (153/5) days,
3522 * using integer arithmetic (i.e., with truncation).  To avoid too much
3523 * messing about with leap days, we consider January and February to be
3524 * the 13th and 14th month of the previous year.  After that transformation,
3525 * we need the month index we use to be high by 1 from 'normal human' usage,
3526 * so the month index values we use run from 4 through 15.
3527 *
3528 * Given that, and the rules for the Gregorian calendar (leap years are those
3529 * divisible by 4 unless also divisible by 100, when they must be divisible
3530 * by 400 instead), we can simply calculate the number of days since some
3531 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3532 * the days we derive from our month index, and adding in the day of the
3533 * month.  The value used here is not adjusted for the actual origin which
3534 * it normally would use (1 January A.D. 1), since we're not exposing it.
3535 * We're only building the value so we can turn around and get the
3536 * normalised values for the year, month, day-of-month, and day-of-year.
3537 *
3538 * For going backward, we need to bias the value we're using so that we find
3539 * the right year value.  (Basically, we don't want the contribution of
3540 * March 1st to the number to apply while deriving the year).  Having done
3541 * that, we 'count up' the contribution to the year number by accounting for
3542 * full quadracenturies (400-year periods) with their extra leap days, plus
3543 * the contribution from full centuries (to avoid counting in the lost leap
3544 * days), plus the contribution from full quad-years (to count in the normal
3545 * leap days), plus the leftover contribution from any non-leap years.
3546 * At this point, if we were working with an actual leap day, we'll have 0
3547 * days left over.  This is also true for March 1st, however.  So, we have
3548 * to special-case that result, and (earlier) keep track of the 'odd'
3549 * century and year contributions.  If we got 4 extra centuries in a qcent,
3550 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3551 * Otherwise, we add back in the earlier bias we removed (the 123 from
3552 * figuring in March 1st), find the month index (integer division by 30.6),
3553 * and the remainder is the day-of-month.  We then have to convert back to
3554 * 'real' months (including fixing January and February from being 14/15 in
3555 * the previous year to being in the proper year).  After that, to get
3556 * tm_yday, we work with the normalised year and get a new yearday value for
3557 * January 1st, which we subtract from the yearday value we had earlier,
3558 * representing the date we've re-built.  This is done from January 1
3559 * because tm_yday is 0-origin.
3560 *
3561 * Since POSIX time routines are only guaranteed to work for times since the
3562 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3563 * applies Gregorian calendar rules even to dates before the 16th century
3564 * doesn't bother me.  Besides, you'd need cultural context for a given
3565 * date to know whether it was Julian or Gregorian calendar, and that's
3566 * outside the scope for this routine.  Since we convert back based on the
3567 * same rules we used to build the yearday, you'll only get strange results
3568 * for input which needed normalising, or for the 'odd' century years which
3569 * were leap years in the Julian calander but not in the Gregorian one.
3570 * I can live with that.
3571 *
3572 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3573 * that's still outside the scope for POSIX time manipulation, so I don't
3574 * care.
3575 */
3576
3577    year = 1900 + ptm->tm_year;
3578    month = ptm->tm_mon;
3579    mday = ptm->tm_mday;
3580    /* allow given yday with no month & mday to dominate the result */
3581    if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3582        month = 0;
3583        mday = 0;
3584        jday = 1 + ptm->tm_yday;
3585    }
3586    else {
3587        jday = 0;
3588    }
3589    if (month >= 2)
3590        month+=2;
3591    else
3592        month+=14, year--;
3593    yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3594    yearday += month*MONTH_TO_DAYS + mday + jday;
3595    /*
3596     * Note that we don't know when leap-seconds were or will be,
3597     * so we have to trust the user if we get something which looks
3598     * like a sensible leap-second.  Wild values for seconds will
3599     * be rationalised, however.
3600     */
3601    if ((unsigned) ptm->tm_sec <= 60) {
3602        secs = 0;
3603    }
3604    else {
3605        secs = ptm->tm_sec;
3606        ptm->tm_sec = 0;
3607    }
3608    secs += 60 * ptm->tm_min;
3609    secs += SECS_PER_HOUR * ptm->tm_hour;
3610    if (secs < 0) {
3611        if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3612            /* got negative remainder, but need positive time */
3613            /* back off an extra day to compensate */
3614            yearday += (secs/SECS_PER_DAY)-1;
3615            secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3616        }
3617        else {
3618            yearday += (secs/SECS_PER_DAY);
3619            secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3620        }
3621    }
3622    else if (secs >= SECS_PER_DAY) {
3623        yearday += (secs/SECS_PER_DAY);
3624        secs %= SECS_PER_DAY;
3625    }
3626    ptm->tm_hour = secs/SECS_PER_HOUR;
3627    secs %= SECS_PER_HOUR;
3628    ptm->tm_min = secs/60;
3629    secs %= 60;
3630    ptm->tm_sec += secs;
3631    /* done with time of day effects */
3632    /*
3633     * The algorithm for yearday has (so far) left it high by 428.
3634     * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3635     * bias it by 123 while trying to figure out what year it
3636     * really represents.  Even with this tweak, the reverse
3637     * translation fails for years before A.D. 0001.
3638     * It would still fail for Feb 29, but we catch that one below.
3639     */
3640    jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3641    yearday -= YEAR_ADJUST;
3642    year = (yearday / DAYS_PER_QCENT) * 400;
3643    yearday %= DAYS_PER_QCENT;
3644    odd_cent = yearday / DAYS_PER_CENT;
3645    year += odd_cent * 100;
3646    yearday %= DAYS_PER_CENT;
3647    year += (yearday / DAYS_PER_QYEAR) * 4;
3648    yearday %= DAYS_PER_QYEAR;
3649    odd_year = yearday / DAYS_PER_YEAR;
3650    year += odd_year;
3651    yearday %= DAYS_PER_YEAR;
3652    if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3653        month = 1;
3654        yearday = 29;
3655    }
3656    else {
3657        yearday += YEAR_ADJUST; /* recover March 1st crock */
3658        month = yearday*DAYS_TO_MONTH;
3659        yearday -= month*MONTH_TO_DAYS;
3660        /* recover other leap-year adjustment */
3661        if (month > 13) {
3662            month-=14;
3663            year++;
3664        }
3665        else {
3666            month-=2;
3667        }
3668    }
3669    ptm->tm_year = year - 1900;
3670    if (yearday) {
3671      ptm->tm_mday = yearday;
3672      ptm->tm_mon = month;
3673    }
3674    else {
3675      ptm->tm_mday = 31;
3676      ptm->tm_mon = month - 1;
3677    }
3678    /* re-build yearday based on Jan 1 to get tm_yday */
3679    year--;
3680    yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3681    yearday += 14*MONTH_TO_DAYS + 1;
3682    ptm->tm_yday = jday - yearday;
3683    /* fix tm_wday if not overridden by caller */
3684    if ((unsigned)ptm->tm_wday > 6)
3685        ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3686}
3687
3688char *
3689Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3690{
3691#ifdef HAS_STRFTIME
3692  char *buf;
3693  int buflen;
3694  struct tm mytm;
3695  int len;
3696
3697  init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3698  mytm.tm_sec = sec;
3699  mytm.tm_min = min;
3700  mytm.tm_hour = hour;
3701  mytm.tm_mday = mday;
3702  mytm.tm_mon = mon;
3703  mytm.tm_year = year;
3704  mytm.tm_wday = wday;
3705  mytm.tm_yday = yday;
3706  mytm.tm_isdst = isdst;
3707  mini_mktime(&mytm);
3708  /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3709#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3710  STMT_START {
3711    struct tm mytm2;
3712    mytm2 = mytm;
3713    mktime(&mytm2);
3714#ifdef HAS_TM_TM_GMTOFF
3715    mytm.tm_gmtoff = mytm2.tm_gmtoff;
3716#endif
3717#ifdef HAS_TM_TM_ZONE
3718    mytm.tm_zone = mytm2.tm_zone;
3719#endif
3720  } STMT_END;
3721#endif
3722  buflen = 64;
3723  New(0, buf, buflen, char);
3724  len = strftime(buf, buflen, fmt, &mytm);
3725  /*
3726  ** The following is needed to handle to the situation where
3727  ** tmpbuf overflows.  Basically we want to allocate a buffer
3728  ** and try repeatedly.  The reason why it is so complicated
3729  ** is that getting a return value of 0 from strftime can indicate
3730  ** one of the following:
3731  ** 1. buffer overflowed,
3732  ** 2. illegal conversion specifier, or
3733  ** 3. the format string specifies nothing to be returned(not
3734  **      an error).  This could be because format is an empty string
3735  **    or it specifies %p that yields an empty string in some locale.
3736  ** If there is a better way to make it portable, go ahead by
3737  ** all means.
3738  */
3739  if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3740    return buf;
3741  else {
3742    /* Possibly buf overflowed - try again with a bigger buf */
3743    int     fmtlen = strlen(fmt);
3744    int     bufsize = fmtlen + buflen;
3745
3746    New(0, buf, bufsize, char);
3747    while (buf) {
3748      buflen = strftime(buf, bufsize, fmt, &mytm);
3749      if (buflen > 0 && buflen < bufsize)
3750        break;
3751      /* heuristic to prevent out-of-memory errors */
3752      if (bufsize > 100*fmtlen) {
3753        Safefree(buf);
3754        buf = NULL;
3755        break;
3756      }
3757      bufsize *= 2;
3758      Renew(buf, bufsize, char);
3759    }
3760    return buf;
3761  }
3762#else
3763  Perl_croak(aTHX_ "panic: no strftime");
3764#endif
3765}
3766
3767
3768#define SV_CWD_RETURN_UNDEF \
3769sv_setsv(sv, &PL_sv_undef); \
3770return FALSE
3771
3772#define SV_CWD_ISDOT(dp) \
3773    (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3774        (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3775
3776/*
3777=head1 Miscellaneous Functions
3778
3779=for apidoc getcwd_sv
3780
3781Fill the sv with current working directory
3782
3783=cut
3784*/
3785
3786/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3787 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3788 * getcwd(3) if available
3789 * Comments from the orignal:
3790 *     This is a faster version of getcwd.  It's also more dangerous
3791 *     because you might chdir out of a directory that you can't chdir
3792 *     back into. */
3793
3794int
3795Perl_getcwd_sv(pTHX_ register SV *sv)
3796{
3797#ifndef PERL_MICRO
3798
3799#ifndef INCOMPLETE_TAINTS
3800    SvTAINTED_on(sv);
3801#endif
3802
3803#ifdef HAS_GETCWD
3804    {
3805        char buf[MAXPATHLEN];
3806
3807        /* Some getcwd()s automatically allocate a buffer of the given
3808         * size from the heap if they are given a NULL buffer pointer.
3809         * The problem is that this behaviour is not portable. */
3810        if (getcwd(buf, sizeof(buf) - 1)) {
3811            STRLEN len = strlen(buf);
3812            sv_setpvn(sv, buf, len);
3813            return TRUE;
3814        }
3815        else {
3816            sv_setsv(sv, &PL_sv_undef);
3817            return FALSE;
3818        }
3819    }
3820
3821#else
3822
3823    Stat_t statbuf;
3824    int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3825    int namelen, pathlen=0;
3826    DIR *dir;
3827    Direntry_t *dp;
3828
3829    (void)SvUPGRADE(sv, SVt_PV);
3830
3831    if (PerlLIO_lstat(".", &statbuf) < 0) {
3832        SV_CWD_RETURN_UNDEF;
3833    }
3834
3835    orig_cdev = statbuf.st_dev;
3836    orig_cino = statbuf.st_ino;
3837    cdev = orig_cdev;
3838    cino = orig_cino;
3839
3840    for (;;) {
3841        odev = cdev;
3842        oino = cino;
3843
3844        if (PerlDir_chdir("..") < 0) {
3845            SV_CWD_RETURN_UNDEF;
3846        }
3847        if (PerlLIO_stat(".", &statbuf) < 0) {
3848            SV_CWD_RETURN_UNDEF;
3849        }
3850
3851        cdev = statbuf.st_dev;
3852        cino = statbuf.st_ino;
3853
3854        if (odev == cdev && oino == cino) {
3855            break;
3856        }
3857        if (!(dir = PerlDir_open("."))) {
3858            SV_CWD_RETURN_UNDEF;
3859        }
3860
3861        while ((dp = PerlDir_read(dir)) != NULL) {
3862#ifdef DIRNAMLEN
3863            namelen = dp->d_namlen;
3864#else
3865            namelen = strlen(dp->d_name);
3866#endif
3867            /* skip . and .. */
3868            if (SV_CWD_ISDOT(dp)) {
3869                continue;
3870            }
3871
3872            if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3873                SV_CWD_RETURN_UNDEF;
3874            }
3875
3876            tdev = statbuf.st_dev;
3877            tino = statbuf.st_ino;
3878            if (tino == oino && tdev == odev) {
3879                break;
3880            }
3881        }
3882
3883        if (!dp) {
3884            SV_CWD_RETURN_UNDEF;
3885        }
3886
3887        if (pathlen + namelen + 1 >= MAXPATHLEN) {
3888            SV_CWD_RETURN_UNDEF;
3889        }
3890
3891        SvGROW(sv, pathlen + namelen + 1);
3892
3893        if (pathlen) {
3894            /* shift down */
3895            Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3896        }
3897
3898        /* prepend current directory to the front */
3899        *SvPVX(sv) = '/';
3900        Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3901        pathlen += (namelen + 1);
3902
3903#ifdef VOID_CLOSEDIR
3904        PerlDir_close(dir);
3905#else
3906        if (PerlDir_close(dir) < 0) {
3907            SV_CWD_RETURN_UNDEF;
3908        }
3909#endif
3910    }
3911
3912    if (pathlen) {
3913        SvCUR_set(sv, pathlen);
3914        *SvEND(sv) = '\0';
3915        SvPOK_only(sv);
3916
3917        if (PerlDir_chdir(SvPVX(sv)) < 0) {
3918            SV_CWD_RETURN_UNDEF;
3919        }
3920    }
3921    if (PerlLIO_stat(".", &statbuf) < 0) {
3922        SV_CWD_RETURN_UNDEF;
3923    }
3924
3925    cdev = statbuf.st_dev;
3926    cino = statbuf.st_ino;
3927
3928    if (cdev != orig_cdev || cino != orig_cino) {
3929        Perl_croak(aTHX_ "Unstable directory path, "
3930                   "current directory changed unexpectedly");
3931    }
3932
3933    return TRUE;
3934#endif
3935
3936#else
3937    return FALSE;
3938#endif
3939}
3940
3941#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
3942#   define EMULATE_SOCKETPAIR_UDP
3943#endif
3944
3945#ifdef EMULATE_SOCKETPAIR_UDP
3946static int
3947S_socketpair_udp (int fd[2]) {
3948    dTHX;
3949    /* Fake a datagram socketpair using UDP to localhost.  */
3950    int sockets[2] = {-1, -1};
3951    struct sockaddr_in addresses[2];
3952    int i;
3953    Sock_size_t size = sizeof(struct sockaddr_in);
3954    unsigned short port;
3955    int got;
3956
3957    memset(&addresses, 0, sizeof(addresses));
3958    i = 1;
3959    do {
3960        sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
3961        if (sockets[i] == -1)
3962            goto tidy_up_and_fail;
3963
3964        addresses[i].sin_family = AF_INET;
3965        addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
3966        addresses[i].sin_port = 0;      /* kernel choses port.  */
3967        if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
3968                sizeof(struct sockaddr_in)) == -1)
3969            goto tidy_up_and_fail;
3970    } while (i--);
3971
3972    /* Now have 2 UDP sockets. Find out which port each is connected to, and
3973       for each connect the other socket to it.  */
3974    i = 1;
3975    do {
3976        if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
3977                &size) == -1)
3978            goto tidy_up_and_fail;
3979        if (size != sizeof(struct sockaddr_in))
3980            goto abort_tidy_up_and_fail;
3981        /* !1 is 0, !0 is 1 */
3982        if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
3983                sizeof(struct sockaddr_in)) == -1)
3984            goto tidy_up_and_fail;
3985    } while (i--);
3986
3987    /* Now we have 2 sockets connected to each other. I don't trust some other
3988       process not to have already sent a packet to us (by random) so send
3989       a packet from each to the other.  */
3990    i = 1;
3991    do {
3992        /* I'm going to send my own port number.  As a short.
3993           (Who knows if someone somewhere has sin_port as a bitfield and needs
3994           this routine. (I'm assuming crays have socketpair)) */
3995        port = addresses[i].sin_port;
3996        got = PerlLIO_write(sockets[i], &port, sizeof(port));
3997        if (got != sizeof(port)) {
3998            if (got == -1)
3999                goto tidy_up_and_fail;
4000            goto abort_tidy_up_and_fail;
4001        }
4002    } while (i--);
4003
4004    /* Packets sent. I don't trust them to have arrived though.
4005       (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4006       connect to localhost will use a second kernel thread. In 2.6 the
4007       first thread running the connect() returns before the second completes,
4008       so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4009       returns 0. Poor programs have tripped up. One poor program's authors'
4010       had a 50-1 reverse stock split. Not sure how connected these were.)
4011       So I don't trust someone not to have an unpredictable UDP stack.
4012    */
4013
4014    {
4015        struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4016        int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4017        fd_set rset;
4018
4019        FD_ZERO(&rset);
4020        FD_SET(sockets[0], &rset);
4021        FD_SET(sockets[1], &rset);
4022
4023        got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4024        if (got != 2 || !FD_ISSET(sockets[0], &rset)
4025                || !FD_ISSET(sockets[1], &rset)) {
4026            /* I hope this is portable and appropriate.  */
4027            if (got == -1)
4028                goto tidy_up_and_fail;
4029            goto abort_tidy_up_and_fail;
4030        }
4031    }
4032
4033    /* And the paranoia department even now doesn't trust it to have arrive
4034       (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4035    {
4036        struct sockaddr_in readfrom;
4037        unsigned short buffer[2];
4038
4039        i = 1;
4040        do {
4041#ifdef MSG_DONTWAIT
4042            got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4043                    sizeof(buffer), MSG_DONTWAIT,
4044                    (struct sockaddr *) &readfrom, &size);
4045#else
4046            got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4047                    sizeof(buffer), 0,
4048                    (struct sockaddr *) &readfrom, &size);
4049#endif
4050
4051            if (got == -1)
4052                goto tidy_up_and_fail;
4053            if (got != sizeof(port)
4054                    || size != sizeof(struct sockaddr_in)
4055                    /* Check other socket sent us its port.  */
4056                    || buffer[0] != (unsigned short) addresses[!i].sin_port
4057                    /* Check kernel says we got the datagram from that socket */
4058                    || readfrom.sin_family != addresses[!i].sin_family
4059                    || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4060                    || readfrom.sin_port != addresses[!i].sin_port)
4061                goto abort_tidy_up_and_fail;
4062        } while (i--);
4063    }
4064    /* My caller (my_socketpair) has validated that this is non-NULL  */
4065    fd[0] = sockets[0];
4066    fd[1] = sockets[1];
4067    /* I hereby declare this connection open.  May God bless all who cross
4068       her.  */
4069    return 0;
4070
4071  abort_tidy_up_and_fail:
4072    errno = ECONNABORTED;
4073  tidy_up_and_fail:
4074    {
4075        int save_errno = errno;
4076        if (sockets[0] != -1)
4077            PerlLIO_close(sockets[0]);
4078        if (sockets[1] != -1)
4079            PerlLIO_close(sockets[1]);
4080        errno = save_errno;
4081        return -1;
4082    }
4083}
4084#endif /*  EMULATE_SOCKETPAIR_UDP */
4085
4086#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4087int
4088Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4089    /* Stevens says that family must be AF_LOCAL, protocol 0.
4090       I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4091    dTHX;
4092    int listener = -1;
4093    int connector = -1;
4094    int acceptor = -1;
4095    struct sockaddr_in listen_addr;
4096    struct sockaddr_in connect_addr;
4097    Sock_size_t size;
4098
4099    if (protocol
4100#ifdef AF_UNIX
4101        || family != AF_UNIX
4102#endif
4103    ) {
4104        errno = EAFNOSUPPORT;
4105        return -1;
4106    }
4107    if (!fd) {
4108        errno = EINVAL;
4109        return -1;
4110    }
4111
4112#ifdef EMULATE_SOCKETPAIR_UDP
4113    if (type == SOCK_DGRAM)
4114        return S_socketpair_udp(fd);
4115#endif
4116
4117    listener = PerlSock_socket(AF_INET, type, 0);
4118    if (listener == -1)
4119        return -1;
4120    memset(&listen_addr, 0, sizeof(listen_addr));
4121    listen_addr.sin_family = AF_INET;
4122    listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4123    listen_addr.sin_port = 0;   /* kernel choses port.  */
4124    if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4125            sizeof(listen_addr)) == -1)
4126        goto tidy_up_and_fail;
4127    if (PerlSock_listen(listener, 1) == -1)
4128        goto tidy_up_and_fail;
4129
4130    connector = PerlSock_socket(AF_INET, type, 0);
4131    if (connector == -1)
4132        goto tidy_up_and_fail;
4133    /* We want to find out the port number to connect to.  */
4134    size = sizeof(connect_addr);
4135    if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4136            &size) == -1)
4137        goto tidy_up_and_fail;
4138    if (size != sizeof(connect_addr))
4139        goto abort_tidy_up_and_fail;
4140    if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4141            sizeof(connect_addr)) == -1)
4142        goto tidy_up_and_fail;
4143
4144    size = sizeof(listen_addr);
4145    acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4146            &size);
4147    if (acceptor == -1)
4148        goto tidy_up_and_fail;
4149    if (size != sizeof(listen_addr))
4150        goto abort_tidy_up_and_fail;
4151    PerlLIO_close(listener);
4152    /* Now check we are talking to ourself by matching port and host on the
4153       two sockets.  */
4154    if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4155            &size) == -1)
4156        goto tidy_up_and_fail;
4157    if (size != sizeof(connect_addr)
4158            || listen_addr.sin_family != connect_addr.sin_family
4159            || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4160            || listen_addr.sin_port != connect_addr.sin_port) {
4161        goto abort_tidy_up_and_fail;
4162    }
4163    fd[0] = connector;
4164    fd[1] = acceptor;
4165    return 0;
4166
4167  abort_tidy_up_and_fail:
4168  errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
4169  tidy_up_and_fail:
4170    {
4171        int save_errno = errno;
4172        if (listener != -1)
4173            PerlLIO_close(listener);
4174        if (connector != -1)
4175            PerlLIO_close(connector);
4176        if (acceptor != -1)
4177            PerlLIO_close(acceptor);
4178        errno = save_errno;
4179        return -1;
4180    }
4181}
4182#else
4183/* In any case have a stub so that there's code corresponding
4184 * to the my_socketpair in global.sym. */
4185int
4186Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4187#ifdef HAS_SOCKETPAIR
4188    return socketpair(family, type, protocol, fd);
4189#else
4190    return -1;
4191#endif
4192}
4193#endif
4194
4195/*
4196
4197=for apidoc sv_nosharing
4198
4199Dummy routine which "shares" an SV when there is no sharing module present.
4200Exists to avoid test for a NULL function pointer and because it could potentially warn under
4201some level of strict-ness.
4202
4203=cut
4204*/
4205
4206void
4207Perl_sv_nosharing(pTHX_ SV *sv)
4208{
4209}
4210
4211/*
4212=for apidoc sv_nolocking
4213
4214Dummy routine which "locks" an SV when there is no locking module present.
4215Exists to avoid test for a NULL function pointer and because it could potentially warn under
4216some level of strict-ness.
4217
4218=cut
4219*/
4220
4221void
4222Perl_sv_nolocking(pTHX_ SV *sv)
4223{
4224}
4225
4226
4227/*
4228=for apidoc sv_nounlocking
4229
4230Dummy routine which "unlocks" an SV when there is no locking module present.
4231Exists to avoid test for a NULL function pointer and because it could potentially warn under
4232some level of strict-ness.
4233
4234=cut
4235*/
4236
4237void
4238Perl_sv_nounlocking(pTHX_ SV *sv)
4239{
4240}
4241
4242U32
4243Perl_parse_unicode_opts(pTHX_ char **popt)
4244{
4245  char *p = *popt;
4246  U32 opt = 0;
4247
4248  if (*p) {
4249       if (isDIGIT(*p)) {
4250            opt = (U32) atoi(p);
4251            while (isDIGIT(*p)) p++;
4252            if (*p && *p != '\n' && *p != '\r')
4253                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4254       }
4255       else {
4256            for (; *p; p++) {
4257                 switch (*p) {
4258                 case PERL_UNICODE_STDIN:
4259                      opt |= PERL_UNICODE_STDIN_FLAG;   break;
4260                 case PERL_UNICODE_STDOUT:
4261                      opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4262                 case PERL_UNICODE_STDERR:
4263                      opt |= PERL_UNICODE_STDERR_FLAG;  break;
4264                 case PERL_UNICODE_STD:
4265                      opt |= PERL_UNICODE_STD_FLAG;     break;
4266                 case PERL_UNICODE_IN:
4267                      opt |= PERL_UNICODE_IN_FLAG;      break;
4268                 case PERL_UNICODE_OUT:
4269                      opt |= PERL_UNICODE_OUT_FLAG;     break;
4270                 case PERL_UNICODE_INOUT:
4271                      opt |= PERL_UNICODE_INOUT_FLAG;   break;
4272                 case PERL_UNICODE_LOCALE:
4273                      opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4274                 case PERL_UNICODE_ARGV:
4275                      opt |= PERL_UNICODE_ARGV_FLAG;    break;
4276                 default:
4277                      if (*p != '\n' && *p != '\r')
4278                          Perl_croak(aTHX_
4279                                     "Unknown Unicode option letter '%c'", *p);
4280                 }
4281            }
4282       }
4283  }
4284  else
4285       opt = PERL_UNICODE_DEFAULT_FLAGS;
4286
4287  if (opt & ~PERL_UNICODE_ALL_FLAGS)
4288       Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4289                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4290
4291  *popt = p;
4292
4293  return opt;
4294}
4295
4296U32
4297Perl_seed(pTHX)
4298{
4299    /*
4300     * This is really just a quick hack which grabs various garbage
4301     * values.  It really should be a real hash algorithm which
4302     * spreads the effect of every input bit onto every output bit,
4303     * if someone who knows about such things would bother to write it.
4304     * Might be a good idea to add that function to CORE as well.
4305     * No numbers below come from careful analysis or anything here,
4306     * except they are primes and SEED_C1 > 1E6 to get a full-width
4307     * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4308     * probably be bigger too.
4309     */
4310#if RANDBITS > 16
4311#  define SEED_C1       1000003
4312#define   SEED_C4       73819
4313#else
4314#  define SEED_C1       25747
4315#define   SEED_C4       20639
4316#endif
4317#define   SEED_C2       3
4318#define   SEED_C3       269
4319#define   SEED_C5       26107
4320
4321#ifndef PERL_NO_DEV_RANDOM
4322    int fd;
4323#endif
4324    U32 u;
4325#ifdef VMS
4326#  include <starlet.h>
4327    /* when[] = (low 32 bits, high 32 bits) of time since epoch
4328     * in 100-ns units, typically incremented ever 10 ms.        */
4329    unsigned int when[2];
4330#else
4331#  ifdef HAS_GETTIMEOFDAY
4332    struct timeval when;
4333#  else
4334    Time_t when;
4335#  endif
4336#endif
4337
4338/* This test is an escape hatch, this symbol isn't set by Configure. */
4339#ifndef PERL_NO_DEV_RANDOM
4340#ifndef PERL_RANDOM_DEVICE
4341   /* /dev/random isn't used by default because reads from it will block
4342    * if there isn't enough entropy available.  You can compile with
4343    * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4344    * is enough real entropy to fill the seed. */
4345#  define PERL_RANDOM_DEVICE "/dev/urandom"
4346#endif
4347    fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4348    if (fd != -1) {
4349        if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4350            u = 0;
4351        PerlLIO_close(fd);
4352        if (u)
4353            return u;
4354    }
4355#endif
4356
4357#ifdef VMS
4358    _ckvmssts(sys$gettim(when));
4359    u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4360#else
4361#  ifdef HAS_GETTIMEOFDAY
4362    PerlProc_gettimeofday(&when,NULL);
4363    u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4364#  else
4365    (void)time(&when);
4366    u = (U32)SEED_C1 * when;
4367#  endif
4368#endif
4369    u += SEED_C3 * (U32)PerlProc_getpid();
4370    u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4371#ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4372    u += SEED_C5 * (U32)PTR2UV(&when);
4373#endif
4374    return u;
4375}
4376
4377UV
4378Perl_get_hash_seed(pTHX)
4379{
4380     char *s = PerlEnv_getenv("PERL_HASH_SEED");
4381     UV myseed = 0;
4382
4383     if (s)
4384          while (isSPACE(*s)) s++;
4385     if (s && isDIGIT(*s))
4386          myseed = (UV)Atoul(s);
4387     else
4388#ifdef USE_HASH_SEED_EXPLICIT
4389     if (s)
4390#endif
4391     {
4392          /* Compute a random seed */
4393          (void)seedDrand01((Rand_seed_t)seed());
4394          myseed = (UV)(Drand01() * (NV)UV_MAX);
4395#if RANDBITS < (UVSIZE * 8)
4396          /* Since there are not enough randbits to to reach all
4397           * the bits of a UV, the low bits might need extra
4398           * help.  Sum in another random number that will
4399           * fill in the low bits. */
4400          myseed +=
4401               (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4402#endif /* RANDBITS < (UVSIZE * 8) */
4403          if (myseed == 0) { /* Superparanoia. */
4404              myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4405              if (myseed == 0)
4406                  Perl_croak(aTHX_ "Your random numbers are not that random");
4407          }
4408     }
4409     PL_rehash_seed_set = TRUE;
4410
4411     return myseed;
4412}
Note: See TracBrowser for help on using the repository browser.