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