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