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