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