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