[MERGE] t/TEST -deparse fixups
[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 %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)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 Analyses 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)
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 #ifdef USE_ENVIRON_ARRAY
2064        /* VMS' my_setenv() is in vms.c */
2065 #if !defined(WIN32) && !defined(NETWARE)
2066 void
2067 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2068 {
2069   dVAR;
2070 #ifdef __amigaos4__
2071   amigaos4_obtain_environ(__FUNCTION__);
2072 #endif
2073 #ifdef USE_ITHREADS
2074   /* only parent thread can modify process environment */
2075   if (PL_curinterp == aTHX)
2076 #endif
2077   {
2078 #ifndef PERL_USE_SAFE_PUTENV
2079     if (!PL_use_safe_putenv) {
2080         /* most putenv()s leak, so we manipulate environ directly */
2081         I32 i;
2082         const I32 len = strlen(nam);
2083         int nlen, vlen;
2084
2085         /* where does it go? */
2086         for (i = 0; environ[i]; i++) {
2087             if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2088                 break;
2089         }
2090
2091         if (environ == PL_origenviron) {   /* need we copy environment? */
2092             I32 j;
2093             I32 max;
2094             char **tmpenv;
2095
2096             max = i;
2097             while (environ[max])
2098                 max++;
2099             tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2100             for (j=0; j<max; j++) {         /* copy environment */
2101                 const int len = strlen(environ[j]);
2102                 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2103                 Copy(environ[j], tmpenv[j], len+1, char);
2104             }
2105             tmpenv[max] = NULL;
2106             environ = tmpenv;               /* tell exec where it is now */
2107         }
2108         if (!val) {
2109             safesysfree(environ[i]);
2110             while (environ[i]) {
2111                 environ[i] = environ[i+1];
2112                 i++;
2113             }
2114 #ifdef __amigaos4__
2115             goto my_setenv_out;
2116 #else
2117             return;
2118 #endif
2119         }
2120         if (!environ[i]) {                 /* does not exist yet */
2121             environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2122             environ[i+1] = NULL;    /* make sure it's null terminated */
2123         }
2124         else
2125             safesysfree(environ[i]);
2126         nlen = strlen(nam);
2127         vlen = strlen(val);
2128
2129         environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2130         /* all that work just for this */
2131         my_setenv_format(environ[i], nam, nlen, val, vlen);
2132     } else {
2133 # endif
2134     /* This next branch should only be called #if defined(HAS_SETENV), but
2135        Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
2136        were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2137     */
2138 #   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2139 #       if defined(HAS_UNSETENV)
2140         if (val == NULL) {
2141             (void)unsetenv(nam);
2142         } else {
2143             (void)setenv(nam, val, 1);
2144         }
2145 #       else /* ! HAS_UNSETENV */
2146         (void)setenv(nam, val, 1);
2147 #       endif /* HAS_UNSETENV */
2148 #   elif defined(HAS_UNSETENV)
2149         if (val == NULL) {
2150             if (environ) /* old glibc can crash with null environ */
2151                 (void)unsetenv(nam);
2152         } else {
2153             const int nlen = strlen(nam);
2154             const int vlen = strlen(val);
2155             char * const new_env =
2156                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2157             my_setenv_format(new_env, nam, nlen, val, vlen);
2158             (void)putenv(new_env);
2159         }
2160 #   else /* ! HAS_UNSETENV */
2161         char *new_env;
2162         const int nlen = strlen(nam);
2163         int vlen;
2164         if (!val) {
2165            val = "";
2166         }
2167         vlen = strlen(val);
2168         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2169         /* all that work just for this */
2170         my_setenv_format(new_env, nam, nlen, val, vlen);
2171         (void)putenv(new_env);
2172 #   endif /* __CYGWIN__ */
2173 #ifndef PERL_USE_SAFE_PUTENV
2174     }
2175 #endif
2176   }
2177 #ifdef __amigaos4__
2178 my_setenv_out:
2179   amigaos4_release_environ(__FUNCTION__);
2180 #endif
2181 }
2182
2183 #else /* WIN32 || NETWARE */
2184
2185 void
2186 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2187 {
2188     dVAR;
2189     char *envstr;
2190     const int nlen = strlen(nam);
2191     int vlen;
2192
2193     if (!val) {
2194        val = "";
2195     }
2196     vlen = strlen(val);
2197     Newx(envstr, nlen+vlen+2, char);
2198     my_setenv_format(envstr, nam, nlen, val, vlen);
2199     (void)PerlEnv_putenv(envstr);
2200     Safefree(envstr);
2201 }
2202
2203 #endif /* WIN32 || NETWARE */
2204
2205 #endif /* !VMS */
2206
2207 #ifdef UNLINK_ALL_VERSIONS
2208 I32
2209 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2210 {
2211     I32 retries = 0;
2212
2213     PERL_ARGS_ASSERT_UNLNK;
2214
2215     while (PerlLIO_unlink(f) >= 0)
2216         retries++;
2217     return retries ? 0 : -1;
2218 }
2219 #endif
2220
2221 PerlIO *
2222 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2223 {
2224 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2225     int p[2];
2226     I32 This, that;
2227     Pid_t pid;
2228     SV *sv;
2229     I32 did_pipes = 0;
2230     int pp[2];
2231
2232     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2233
2234     PERL_FLUSHALL_FOR_CHILD;
2235     This = (*mode == 'w');
2236     that = !This;
2237     if (TAINTING_get) {
2238         taint_env();
2239         taint_proper("Insecure %s%s", "EXEC");
2240     }
2241     if (PerlProc_pipe(p) < 0)
2242         return NULL;
2243     /* Try for another pipe pair for error return */
2244     if (PerlProc_pipe(pp) >= 0)
2245         did_pipes = 1;
2246     while ((pid = PerlProc_fork()) < 0) {
2247         if (errno != EAGAIN) {
2248             PerlLIO_close(p[This]);
2249             PerlLIO_close(p[that]);
2250             if (did_pipes) {
2251                 PerlLIO_close(pp[0]);
2252                 PerlLIO_close(pp[1]);
2253             }
2254             return NULL;
2255         }
2256         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2257         sleep(5);
2258     }
2259     if (pid == 0) {
2260         /* Child */
2261 #undef THIS
2262 #undef THAT
2263 #define THIS that
2264 #define THAT This
2265         /* Close parent's end of error status pipe (if any) */
2266         if (did_pipes) {
2267             PerlLIO_close(pp[0]);
2268 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2269             /* Close error pipe automatically if exec works */
2270             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2271                 return NULL;
2272 #endif
2273         }
2274         /* Now dup our end of _the_ pipe to right position */
2275         if (p[THIS] != (*mode == 'r')) {
2276             PerlLIO_dup2(p[THIS], *mode == 'r');
2277             PerlLIO_close(p[THIS]);
2278             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2279                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2280         }
2281         else
2282             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2283 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2284         /* No automatic close - do it by hand */
2285 #  ifndef NOFILE
2286 #  define NOFILE 20
2287 #  endif
2288         {
2289             int fd;
2290
2291             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2292                 if (fd != pp[1])
2293                     PerlLIO_close(fd);
2294             }
2295         }
2296 #endif
2297         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2298         PerlProc__exit(1);
2299 #undef THIS
2300 #undef THAT
2301     }
2302     /* Parent */
2303     do_execfree();      /* free any memory malloced by child on fork */
2304     if (did_pipes)
2305         PerlLIO_close(pp[1]);
2306     /* Keep the lower of the two fd numbers */
2307     if (p[that] < p[This]) {
2308         PerlLIO_dup2(p[This], p[that]);
2309         PerlLIO_close(p[This]);
2310         p[This] = p[that];
2311     }
2312     else
2313         PerlLIO_close(p[that]);         /* close child's end of pipe */
2314
2315     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2316     SvUPGRADE(sv,SVt_IV);
2317     SvIV_set(sv, pid);
2318     PL_forkprocess = pid;
2319     /* If we managed to get status pipe check for exec fail */
2320     if (did_pipes && pid > 0) {
2321         int errkid;
2322         unsigned n = 0;
2323
2324         while (n < sizeof(int)) {
2325             const SSize_t n1 = PerlLIO_read(pp[0],
2326                               (void*)(((char*)&errkid)+n),
2327                               (sizeof(int)) - n);
2328             if (n1 <= 0)
2329                 break;
2330             n += n1;
2331         }
2332         PerlLIO_close(pp[0]);
2333         did_pipes = 0;
2334         if (n) {                        /* Error */
2335             int pid2, status;
2336             PerlLIO_close(p[This]);
2337             if (n != sizeof(int))
2338                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2339             do {
2340                 pid2 = wait4pid(pid, &status, 0);
2341             } while (pid2 == -1 && errno == EINTR);
2342             errno = errkid;             /* Propagate errno from kid */
2343             return NULL;
2344         }
2345     }
2346     if (did_pipes)
2347          PerlLIO_close(pp[0]);
2348     return PerlIO_fdopen(p[This], mode);
2349 #else
2350 #  if defined(OS2)      /* Same, without fork()ing and all extra overhead... */
2351     return my_syspopen4(aTHX_ NULL, mode, n, args);
2352 #  elif defined(WIN32)
2353     return win32_popenlist(mode, n, args);
2354 #  else
2355     Perl_croak(aTHX_ "List form of piped open not implemented");
2356     return (PerlIO *) NULL;
2357 #  endif
2358 #endif
2359 }
2360
2361     /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2362 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2363 PerlIO *
2364 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2365 {
2366     int p[2];
2367     I32 This, that;
2368     Pid_t pid;
2369     SV *sv;
2370     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2371     I32 did_pipes = 0;
2372     int pp[2];
2373
2374     PERL_ARGS_ASSERT_MY_POPEN;
2375
2376     PERL_FLUSHALL_FOR_CHILD;
2377 #ifdef OS2
2378     if (doexec) {
2379         return my_syspopen(aTHX_ cmd,mode);
2380     }
2381 #endif
2382     This = (*mode == 'w');
2383     that = !This;
2384     if (doexec && TAINTING_get) {
2385         taint_env();
2386         taint_proper("Insecure %s%s", "EXEC");
2387     }
2388     if (PerlProc_pipe(p) < 0)
2389         return NULL;
2390     if (doexec && PerlProc_pipe(pp) >= 0)
2391         did_pipes = 1;
2392     while ((pid = PerlProc_fork()) < 0) {
2393         if (errno != EAGAIN) {
2394             PerlLIO_close(p[This]);
2395             PerlLIO_close(p[that]);
2396             if (did_pipes) {
2397                 PerlLIO_close(pp[0]);
2398                 PerlLIO_close(pp[1]);
2399             }
2400             if (!doexec)
2401                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2402             return NULL;
2403         }
2404         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2405         sleep(5);
2406     }
2407     if (pid == 0) {
2408
2409 #undef THIS
2410 #undef THAT
2411 #define THIS that
2412 #define THAT This
2413         if (did_pipes) {
2414             PerlLIO_close(pp[0]);
2415 #if defined(HAS_FCNTL) && defined(F_SETFD)
2416             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2417                 return NULL;
2418 #endif
2419         }
2420         if (p[THIS] != (*mode == 'r')) {
2421             PerlLIO_dup2(p[THIS], *mode == 'r');
2422             PerlLIO_close(p[THIS]);
2423             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2424                 PerlLIO_close(p[THAT]);
2425         }
2426         else
2427             PerlLIO_close(p[THAT]);
2428 #ifndef OS2
2429         if (doexec) {
2430 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2431 #ifndef NOFILE
2432 #define NOFILE 20
2433 #endif
2434             {
2435                 int fd;
2436
2437                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2438                     if (fd != pp[1])
2439                         PerlLIO_close(fd);
2440             }
2441 #endif
2442             /* may or may not use the shell */
2443             do_exec3(cmd, pp[1], did_pipes);
2444             PerlProc__exit(1);
2445         }
2446 #endif  /* defined OS2 */
2447
2448 #ifdef PERLIO_USING_CRLF
2449    /* Since we circumvent IO layers when we manipulate low-level
2450       filedescriptors directly, need to manually switch to the
2451       default, binary, low-level mode; see PerlIOBuf_open(). */
2452    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2453 #endif 
2454         PL_forkprocess = 0;
2455 #ifdef PERL_USES_PL_PIDSTATUS
2456         hv_clear(PL_pidstatus); /* we have no children */
2457 #endif
2458         return NULL;
2459 #undef THIS
2460 #undef THAT
2461     }
2462     do_execfree();      /* free any memory malloced by child on vfork */
2463     if (did_pipes)
2464         PerlLIO_close(pp[1]);
2465     if (p[that] < p[This]) {
2466         PerlLIO_dup2(p[This], p[that]);
2467         PerlLIO_close(p[This]);
2468         p[This] = p[that];
2469     }
2470     else
2471         PerlLIO_close(p[that]);
2472
2473     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2474     SvUPGRADE(sv,SVt_IV);
2475     SvIV_set(sv, pid);
2476     PL_forkprocess = pid;
2477     if (did_pipes && pid > 0) {
2478         int errkid;
2479         unsigned n = 0;
2480
2481         while (n < sizeof(int)) {
2482             const SSize_t n1 = PerlLIO_read(pp[0],
2483                               (void*)(((char*)&errkid)+n),
2484                               (sizeof(int)) - n);
2485             if (n1 <= 0)
2486                 break;
2487             n += n1;
2488         }
2489         PerlLIO_close(pp[0]);
2490         did_pipes = 0;
2491         if (n) {                        /* Error */
2492             int pid2, status;
2493             PerlLIO_close(p[This]);
2494             if (n != sizeof(int))
2495                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2496             do {
2497                 pid2 = wait4pid(pid, &status, 0);
2498             } while (pid2 == -1 && errno == EINTR);
2499             errno = errkid;             /* Propagate errno from kid */
2500             return NULL;
2501         }
2502     }
2503     if (did_pipes)
2504          PerlLIO_close(pp[0]);
2505     return PerlIO_fdopen(p[This], mode);
2506 }
2507 #elif defined(DJGPP)
2508 FILE *djgpp_popen();
2509 PerlIO *
2510 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2511 {
2512     PERL_FLUSHALL_FOR_CHILD;
2513     /* Call system's popen() to get a FILE *, then import it.
2514        used 0 for 2nd parameter to PerlIO_importFILE;
2515        apparently not used
2516     */
2517     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2518 }
2519 #elif defined(__LIBCATAMOUNT__)
2520 PerlIO *
2521 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2522 {
2523     return NULL;
2524 }
2525
2526 #endif /* !DOSISH */
2527
2528 /* this is called in parent before the fork() */
2529 void
2530 Perl_atfork_lock(void)
2531 #if defined(USE_ITHREADS)
2532 #  ifdef USE_PERLIO
2533   PERL_TSA_ACQUIRE(PL_perlio_mutex)
2534 #  endif
2535 #  ifdef MYMALLOC
2536   PERL_TSA_ACQUIRE(PL_malloc_mutex)
2537 #  endif
2538   PERL_TSA_ACQUIRE(PL_op_mutex)
2539 #endif
2540 {
2541 #if defined(USE_ITHREADS)
2542     dVAR;
2543     /* locks must be held in locking order (if any) */
2544 #  ifdef USE_PERLIO
2545     MUTEX_LOCK(&PL_perlio_mutex);
2546 #  endif
2547 #  ifdef MYMALLOC
2548     MUTEX_LOCK(&PL_malloc_mutex);
2549 #  endif
2550     OP_REFCNT_LOCK;
2551 #endif
2552 }
2553
2554 /* this is called in both parent and child after the fork() */
2555 void
2556 Perl_atfork_unlock(void)
2557 #if defined(USE_ITHREADS)
2558 #  ifdef USE_PERLIO
2559   PERL_TSA_RELEASE(PL_perlio_mutex)
2560 #  endif
2561 #  ifdef MYMALLOC
2562   PERL_TSA_RELEASE(PL_malloc_mutex)
2563 #  endif
2564   PERL_TSA_RELEASE(PL_op_mutex)
2565 #endif
2566 {
2567 #if defined(USE_ITHREADS)
2568     dVAR;
2569     /* locks must be released in same order as in atfork_lock() */
2570 #  ifdef USE_PERLIO
2571     MUTEX_UNLOCK(&PL_perlio_mutex);
2572 #  endif
2573 #  ifdef MYMALLOC
2574     MUTEX_UNLOCK(&PL_malloc_mutex);
2575 #  endif
2576     OP_REFCNT_UNLOCK;
2577 #endif
2578 }
2579
2580 Pid_t
2581 Perl_my_fork(void)
2582 {
2583 #if defined(HAS_FORK)
2584     Pid_t pid;
2585 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2586     atfork_lock();
2587     pid = fork();
2588     atfork_unlock();
2589 #else
2590     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2591      * handlers elsewhere in the code */
2592     pid = fork();
2593 #endif
2594     return pid;
2595 #elif defined(__amigaos4__)
2596     return amigaos_fork();
2597 #else
2598     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2599     Perl_croak_nocontext("fork() not available");
2600     return 0;
2601 #endif /* HAS_FORK */
2602 }
2603
2604 #ifndef HAS_DUP2
2605 int
2606 dup2(int oldfd, int newfd)
2607 {
2608 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2609     if (oldfd == newfd)
2610         return oldfd;
2611     PerlLIO_close(newfd);
2612     return fcntl(oldfd, F_DUPFD, newfd);
2613 #else
2614 #define DUP2_MAX_FDS 256
2615     int fdtmp[DUP2_MAX_FDS];
2616     I32 fdx = 0;
2617     int fd;
2618
2619     if (oldfd == newfd)
2620         return oldfd;
2621     PerlLIO_close(newfd);
2622     /* good enough for low fd's... */
2623     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2624         if (fdx >= DUP2_MAX_FDS) {
2625             PerlLIO_close(fd);
2626             fd = -1;
2627             break;
2628         }
2629         fdtmp[fdx++] = fd;
2630     }
2631     while (fdx > 0)
2632         PerlLIO_close(fdtmp[--fdx]);
2633     return fd;
2634 #endif
2635 }
2636 #endif
2637
2638 #ifndef PERL_MICRO
2639 #ifdef HAS_SIGACTION
2640
2641 Sighandler_t
2642 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2643 {
2644     struct sigaction act, oact;
2645
2646 #ifdef USE_ITHREADS
2647     dVAR;
2648     /* only "parent" interpreter can diddle signals */
2649     if (PL_curinterp != aTHX)
2650         return (Sighandler_t) SIG_ERR;
2651 #endif
2652
2653     act.sa_handler = (void(*)(int))handler;
2654     sigemptyset(&act.sa_mask);
2655     act.sa_flags = 0;
2656 #ifdef SA_RESTART
2657     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2658         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2659 #endif
2660 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2661     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2662         act.sa_flags |= SA_NOCLDWAIT;
2663 #endif
2664     if (sigaction(signo, &act, &oact) == -1)
2665         return (Sighandler_t) SIG_ERR;
2666     else
2667         return (Sighandler_t) oact.sa_handler;
2668 }
2669
2670 Sighandler_t
2671 Perl_rsignal_state(pTHX_ int signo)
2672 {
2673     struct sigaction oact;
2674     PERL_UNUSED_CONTEXT;
2675
2676     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2677         return (Sighandler_t) SIG_ERR;
2678     else
2679         return (Sighandler_t) oact.sa_handler;
2680 }
2681
2682 int
2683 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2684 {
2685 #ifdef USE_ITHREADS
2686     dVAR;
2687 #endif
2688     struct sigaction act;
2689
2690     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2691
2692 #ifdef USE_ITHREADS
2693     /* only "parent" interpreter can diddle signals */
2694     if (PL_curinterp != aTHX)
2695         return -1;
2696 #endif
2697
2698     act.sa_handler = (void(*)(int))handler;
2699     sigemptyset(&act.sa_mask);
2700     act.sa_flags = 0;
2701 #ifdef SA_RESTART
2702     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2703         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2704 #endif
2705 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2706     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2707         act.sa_flags |= SA_NOCLDWAIT;
2708 #endif
2709     return sigaction(signo, &act, save);
2710 }
2711
2712 int
2713 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2714 {
2715 #ifdef USE_ITHREADS
2716     dVAR;
2717 #endif
2718     PERL_UNUSED_CONTEXT;
2719 #ifdef USE_ITHREADS
2720     /* only "parent" interpreter can diddle signals */
2721     if (PL_curinterp != aTHX)
2722         return -1;
2723 #endif
2724
2725     return sigaction(signo, save, (struct sigaction *)NULL);
2726 }
2727
2728 #else /* !HAS_SIGACTION */
2729
2730 Sighandler_t
2731 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2732 {
2733 #if defined(USE_ITHREADS) && !defined(WIN32)
2734     /* only "parent" interpreter can diddle signals */
2735     if (PL_curinterp != aTHX)
2736         return (Sighandler_t) SIG_ERR;
2737 #endif
2738
2739     return PerlProc_signal(signo, handler);
2740 }
2741
2742 static Signal_t
2743 sig_trap(int signo)
2744 {
2745     dVAR;
2746     PL_sig_trapped++;
2747 }
2748
2749 Sighandler_t
2750 Perl_rsignal_state(pTHX_ int signo)
2751 {
2752     dVAR;
2753     Sighandler_t oldsig;
2754
2755 #if defined(USE_ITHREADS) && !defined(WIN32)
2756     /* only "parent" interpreter can diddle signals */
2757     if (PL_curinterp != aTHX)
2758         return (Sighandler_t) SIG_ERR;
2759 #endif
2760
2761     PL_sig_trapped = 0;
2762     oldsig = PerlProc_signal(signo, sig_trap);
2763     PerlProc_signal(signo, oldsig);
2764     if (PL_sig_trapped)
2765         PerlProc_kill(PerlProc_getpid(), signo);
2766     return oldsig;
2767 }
2768
2769 int
2770 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2771 {
2772 #if defined(USE_ITHREADS) && !defined(WIN32)
2773     /* only "parent" interpreter can diddle signals */
2774     if (PL_curinterp != aTHX)
2775         return -1;
2776 #endif
2777     *save = PerlProc_signal(signo, handler);
2778     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2779 }
2780
2781 int
2782 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2783 {
2784 #if defined(USE_ITHREADS) && !defined(WIN32)
2785     /* only "parent" interpreter can diddle signals */
2786     if (PL_curinterp != aTHX)
2787         return -1;
2788 #endif
2789     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2790 }
2791
2792 #endif /* !HAS_SIGACTION */
2793 #endif /* !PERL_MICRO */
2794
2795     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2796 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2797 I32
2798 Perl_my_pclose(pTHX_ PerlIO *ptr)
2799 {
2800     int status;
2801     SV **svp;
2802     Pid_t pid;
2803     Pid_t pid2 = 0;
2804     bool close_failed;
2805     dSAVEDERRNO;
2806     const int fd = PerlIO_fileno(ptr);
2807     bool should_wait;
2808
2809     svp = av_fetch(PL_fdpid,fd,TRUE);
2810     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2811     SvREFCNT_dec(*svp);
2812     *svp = NULL;
2813
2814 #if defined(USE_PERLIO)
2815     /* Find out whether the refcount is low enough for us to wait for the
2816        child proc without blocking. */
2817     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2818 #else
2819     should_wait = pid > 0;
2820 #endif
2821
2822 #ifdef OS2
2823     if (pid == -1) {                    /* Opened by popen. */
2824         return my_syspclose(ptr);
2825     }
2826 #endif
2827     close_failed = (PerlIO_close(ptr) == EOF);
2828     SAVE_ERRNO;
2829     if (should_wait) do {
2830         pid2 = wait4pid(pid, &status, 0);
2831     } while (pid2 == -1 && errno == EINTR);
2832     if (close_failed) {
2833         RESTORE_ERRNO;
2834         return -1;
2835     }
2836     return(
2837       should_wait
2838        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2839        : 0
2840     );
2841 }
2842 #elif defined(__LIBCATAMOUNT__)
2843 I32
2844 Perl_my_pclose(pTHX_ PerlIO *ptr)
2845 {
2846     return -1;
2847 }
2848 #endif /* !DOSISH */
2849
2850 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2851 I32
2852 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2853 {
2854     I32 result = 0;
2855     PERL_ARGS_ASSERT_WAIT4PID;
2856 #ifdef PERL_USES_PL_PIDSTATUS
2857     if (!pid) {
2858         /* PERL_USES_PL_PIDSTATUS is only defined when neither
2859            waitpid() nor wait4() is available, or on OS/2, which
2860            doesn't appear to support waiting for a progress group
2861            member, so we can only treat a 0 pid as an unknown child.
2862         */
2863         errno = ECHILD;
2864         return -1;
2865     }
2866     {
2867         if (pid > 0) {
2868             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2869                pid, rather than a string form.  */
2870             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2871             if (svp && *svp != &PL_sv_undef) {
2872                 *statusp = SvIVX(*svp);
2873                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2874                                 G_DISCARD);
2875                 return pid;
2876             }
2877         }
2878         else {
2879             HE *entry;
2880
2881             hv_iterinit(PL_pidstatus);
2882             if ((entry = hv_iternext(PL_pidstatus))) {
2883                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2884                 I32 len;
2885                 const char * const spid = hv_iterkey(entry,&len);
2886
2887                 assert (len == sizeof(Pid_t));
2888                 memcpy((char *)&pid, spid, len);
2889                 *statusp = SvIVX(sv);
2890                 /* The hash iterator is currently on this entry, so simply
2891                    calling hv_delete would trigger the lazy delete, which on
2892                    aggregate does more work, because next call to hv_iterinit()
2893                    would spot the flag, and have to call the delete routine,
2894                    while in the meantime any new entries can't re-use that
2895                    memory.  */
2896                 hv_iterinit(PL_pidstatus);
2897                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2898                 return pid;
2899             }
2900         }
2901     }
2902 #endif
2903 #ifdef HAS_WAITPID
2904 #  ifdef HAS_WAITPID_RUNTIME
2905     if (!HAS_WAITPID_RUNTIME)
2906         goto hard_way;
2907 #  endif
2908     result = PerlProc_waitpid(pid,statusp,flags);
2909     goto finish;
2910 #endif
2911 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2912     result = wait4(pid,statusp,flags,NULL);
2913     goto finish;
2914 #endif
2915 #ifdef PERL_USES_PL_PIDSTATUS
2916 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2917   hard_way:
2918 #endif
2919     {
2920         if (flags)
2921             Perl_croak(aTHX_ "Can't do waitpid with flags");
2922         else {
2923             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2924                 pidgone(result,*statusp);
2925             if (result < 0)
2926                 *statusp = -1;
2927         }
2928     }
2929 #endif
2930 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2931   finish:
2932 #endif
2933     if (result < 0 && errno == EINTR) {
2934         PERL_ASYNC_CHECK();
2935         errno = EINTR; /* reset in case a signal handler changed $! */
2936     }
2937     return result;
2938 }
2939 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2940
2941 #ifdef PERL_USES_PL_PIDSTATUS
2942 void
2943 S_pidgone(pTHX_ Pid_t pid, int status)
2944 {
2945     SV *sv;
2946
2947     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2948     SvUPGRADE(sv,SVt_IV);
2949     SvIV_set(sv, status);
2950     return;
2951 }
2952 #endif
2953
2954 #if defined(OS2)
2955 int pclose();
2956 #ifdef HAS_FORK
2957 int                                     /* Cannot prototype with I32
2958                                            in os2ish.h. */
2959 my_syspclose(PerlIO *ptr)
2960 #else
2961 I32
2962 Perl_my_pclose(pTHX_ PerlIO *ptr)
2963 #endif
2964 {
2965     /* Needs work for PerlIO ! */
2966     FILE * const f = PerlIO_findFILE(ptr);
2967     const I32 result = pclose(f);
2968     PerlIO_releaseFILE(ptr,f);
2969     return result;
2970 }
2971 #endif
2972
2973 #if defined(DJGPP)
2974 int djgpp_pclose();
2975 I32
2976 Perl_my_pclose(pTHX_ PerlIO *ptr)
2977 {
2978     /* Needs work for PerlIO ! */
2979     FILE * const f = PerlIO_findFILE(ptr);
2980     I32 result = djgpp_pclose(f);
2981     result = (result << 8) & 0xff00;
2982     PerlIO_releaseFILE(ptr,f);
2983     return result;
2984 }
2985 #endif
2986
2987 #define PERL_REPEATCPY_LINEAR 4
2988 void
2989 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2990 {
2991     PERL_ARGS_ASSERT_REPEATCPY;
2992
2993     assert(len >= 0);
2994
2995     if (count < 0)
2996         croak_memory_wrap();
2997
2998     if (len == 1)
2999         memset(to, *from, count);
3000     else if (count) {
3001         char *p = to;
3002         IV items, linear, half;
3003
3004         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3005         for (items = 0; items < linear; ++items) {
3006             const char *q = from;
3007             IV todo;
3008             for (todo = len; todo > 0; todo--)
3009                 *p++ = *q++;
3010         }
3011
3012         half = count / 2;
3013         while (items <= half) {
3014             IV size = items * len;
3015             memcpy(p, to, size);
3016             p     += size;
3017             items *= 2;
3018         }
3019
3020         if (count > items)
3021             memcpy(p, to, (count - items) * len);
3022     }
3023 }
3024
3025 #ifndef HAS_RENAME
3026 I32
3027 Perl_same_dirent(pTHX_ const char *a, const char *b)
3028 {
3029     char *fa = strrchr(a,'/');
3030     char *fb = strrchr(b,'/');
3031     Stat_t tmpstatbuf1;
3032     Stat_t tmpstatbuf2;
3033     SV * const tmpsv = sv_newmortal();
3034
3035     PERL_ARGS_ASSERT_SAME_DIRENT;
3036
3037     if (fa)
3038         fa++;
3039     else
3040         fa = a;
3041     if (fb)
3042         fb++;
3043     else
3044         fb = b;
3045     if (strNE(a,b))
3046         return FALSE;
3047     if (fa == a)
3048         sv_setpvs(tmpsv, ".");
3049     else
3050         sv_setpvn(tmpsv, a, fa - a);
3051     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3052         return FALSE;
3053     if (fb == b)
3054         sv_setpvs(tmpsv, ".");
3055     else
3056         sv_setpvn(tmpsv, b, fb - b);
3057     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3058         return FALSE;
3059     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3060            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3061 }
3062 #endif /* !HAS_RENAME */
3063
3064 char*
3065 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3066                  const char *const *const search_ext, I32 flags)
3067 {
3068     const char *xfound = NULL;
3069     char *xfailed = NULL;
3070     char tmpbuf[MAXPATHLEN];
3071     char *s;
3072     I32 len = 0;
3073     int retval;
3074     char *bufend;
3075 #if defined(DOSISH) && !defined(OS2)
3076 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3077 #  define MAX_EXT_LEN 4
3078 #endif
3079 #ifdef OS2
3080 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3081 #  define MAX_EXT_LEN 4
3082 #endif
3083 #ifdef VMS
3084 #  define SEARCH_EXTS ".pl", ".com", NULL
3085 #  define MAX_EXT_LEN 4
3086 #endif
3087     /* additional extensions to try in each dir if scriptname not found */
3088 #ifdef SEARCH_EXTS
3089     static const char *const exts[] = { SEARCH_EXTS };
3090     const char *const *const ext = search_ext ? search_ext : exts;
3091     int extidx = 0, i = 0;
3092     const char *curext = NULL;
3093 #else
3094     PERL_UNUSED_ARG(search_ext);
3095 #  define MAX_EXT_LEN 0
3096 #endif
3097
3098     PERL_ARGS_ASSERT_FIND_SCRIPT;
3099
3100     /*
3101      * If dosearch is true and if scriptname does not contain path
3102      * delimiters, search the PATH for scriptname.
3103      *
3104      * If SEARCH_EXTS is also defined, will look for each
3105      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3106      * while searching the PATH.
3107      *
3108      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3109      * proceeds as follows:
3110      *   If DOSISH or VMSISH:
3111      *     + look for ./scriptname{,.foo,.bar}
3112      *     + search the PATH for scriptname{,.foo,.bar}
3113      *
3114      *   If !DOSISH:
3115      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3116      *       this will not look in '.' if it's not in the PATH)
3117      */
3118     tmpbuf[0] = '\0';
3119
3120 #ifdef VMS
3121 #  ifdef ALWAYS_DEFTYPES
3122     len = strlen(scriptname);
3123     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3124         int idx = 0, deftypes = 1;
3125         bool seen_dot = 1;
3126
3127         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3128 #  else
3129     if (dosearch) {
3130         int idx = 0, deftypes = 1;
3131         bool seen_dot = 1;
3132
3133         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3134 #  endif
3135         /* The first time through, just add SEARCH_EXTS to whatever we
3136          * already have, so we can check for default file types. */
3137         while (deftypes ||
3138                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3139         {
3140             Stat_t statbuf;
3141             if (deftypes) {
3142                 deftypes = 0;
3143                 *tmpbuf = '\0';
3144             }
3145             if ((strlen(tmpbuf) + strlen(scriptname)
3146                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3147                 continue;       /* don't search dir with too-long name */
3148             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3149 #else  /* !VMS */
3150
3151 #ifdef DOSISH
3152     if (strEQ(scriptname, "-"))
3153         dosearch = 0;
3154     if (dosearch) {             /* Look in '.' first. */
3155         const char *cur = scriptname;
3156 #ifdef SEARCH_EXTS
3157         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3158             while (ext[i])
3159                 if (strEQ(ext[i++],curext)) {
3160                     extidx = -1;                /* already has an ext */
3161                     break;
3162                 }
3163         do {
3164 #endif
3165             DEBUG_p(PerlIO_printf(Perl_debug_log,
3166                                   "Looking for %s\n",cur));
3167             {
3168                 Stat_t statbuf;
3169                 if (PerlLIO_stat(cur,&statbuf) >= 0
3170                     && !S_ISDIR(statbuf.st_mode)) {
3171                     dosearch = 0;
3172                     scriptname = cur;
3173 #ifdef SEARCH_EXTS
3174                     break;
3175 #endif
3176                 }
3177             }
3178 #ifdef SEARCH_EXTS
3179             if (cur == scriptname) {
3180                 len = strlen(scriptname);
3181                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3182                     break;
3183                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3184                 cur = tmpbuf;
3185             }
3186         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3187                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3188 #endif
3189     }
3190 #endif
3191
3192     if (dosearch && !strchr(scriptname, '/')
3193 #ifdef DOSISH
3194                  && !strchr(scriptname, '\\')
3195 #endif
3196                  && (s = PerlEnv_getenv("PATH")))
3197     {
3198         bool seen_dot = 0;
3199
3200         bufend = s + strlen(s);
3201         while (s < bufend) {
3202             Stat_t statbuf;
3203 #  ifdef DOSISH
3204             for (len = 0; *s
3205                     && *s != ';'; len++, s++) {
3206                 if (len < sizeof tmpbuf)
3207                     tmpbuf[len] = *s;
3208             }
3209             if (len < sizeof tmpbuf)
3210                 tmpbuf[len] = '\0';
3211 #  else
3212             s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3213                                    ':', &len);
3214 #  endif
3215             if (s < bufend)
3216                 s++;
3217             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3218                 continue;       /* don't search dir with too-long name */
3219             if (len
3220 #  ifdef DOSISH
3221                 && tmpbuf[len - 1] != '/'
3222                 && tmpbuf[len - 1] != '\\'
3223 #  endif
3224                )
3225                 tmpbuf[len++] = '/';
3226             if (len == 2 && tmpbuf[0] == '.')
3227                 seen_dot = 1;
3228             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3229 #endif  /* !VMS */
3230
3231 #ifdef SEARCH_EXTS
3232             len = strlen(tmpbuf);
3233             if (extidx > 0)     /* reset after previous loop */
3234                 extidx = 0;
3235             do {
3236 #endif
3237                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3238                 retval = PerlLIO_stat(tmpbuf,&statbuf);
3239                 if (S_ISDIR(statbuf.st_mode)) {
3240                     retval = -1;
3241                 }
3242 #ifdef SEARCH_EXTS
3243             } while (  retval < 0               /* not there */
3244                     && extidx>=0 && ext[extidx] /* try an extension? */
3245                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3246                 );
3247 #endif
3248             if (retval < 0)
3249                 continue;
3250             if (S_ISREG(statbuf.st_mode)
3251                 && cando(S_IRUSR,TRUE,&statbuf)
3252 #if !defined(DOSISH)
3253                 && cando(S_IXUSR,TRUE,&statbuf)
3254 #endif
3255                 )
3256             {
3257                 xfound = tmpbuf;                /* bingo! */
3258                 break;
3259             }
3260             if (!xfailed)
3261                 xfailed = savepv(tmpbuf);
3262         }
3263 #ifndef DOSISH
3264         {
3265             Stat_t statbuf;
3266             if (!xfound && !seen_dot && !xfailed &&
3267                 (PerlLIO_stat(scriptname,&statbuf) < 0
3268                  || S_ISDIR(statbuf.st_mode)))
3269 #endif
3270                 seen_dot = 1;                   /* Disable message. */
3271 #ifndef DOSISH
3272         }
3273 #endif
3274         if (!xfound) {
3275             if (flags & 1) {                    /* do or die? */
3276                 /* diag_listed_as: Can't execute %s */
3277                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3278                       (xfailed ? "execute" : "find"),
3279                       (xfailed ? xfailed : scriptname),
3280                       (xfailed ? "" : " on PATH"),
3281                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3282             }
3283             scriptname = NULL;
3284         }
3285         Safefree(xfailed);
3286         scriptname = xfound;
3287     }
3288     return (scriptname ? savepv(scriptname) : NULL);
3289 }
3290
3291 #ifndef PERL_GET_CONTEXT_DEFINED
3292
3293 void *
3294 Perl_get_context(void)
3295 {
3296 #if defined(USE_ITHREADS)
3297     dVAR;
3298 #  ifdef OLD_PTHREADS_API
3299     pthread_addr_t t;
3300     int error = pthread_getspecific(PL_thr_key, &t)
3301     if (error)
3302         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3303     return (void*)t;
3304 #  elif defined(I_MACH_CTHREADS)
3305     return (void*)cthread_data(cthread_self());
3306 #  else
3307     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3308 #  endif
3309 #else
3310     return (void*)NULL;
3311 #endif
3312 }
3313
3314 void
3315 Perl_set_context(void *t)
3316 {
3317 #if defined(USE_ITHREADS)
3318     dVAR;
3319 #endif
3320     PERL_ARGS_ASSERT_SET_CONTEXT;
3321 #if defined(USE_ITHREADS)
3322 #  ifdef I_MACH_CTHREADS
3323     cthread_set_data(cthread_self(), t);
3324 #  else
3325     {
3326         const int error = pthread_setspecific(PL_thr_key, t);
3327         if (error)
3328             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3329     }
3330 #  endif
3331 #else
3332     PERL_UNUSED_ARG(t);
3333 #endif
3334 }
3335
3336 #endif /* !PERL_GET_CONTEXT_DEFINED */
3337
3338 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3339 struct perl_vars *
3340 Perl_GetVars(pTHX)
3341 {
3342     PERL_UNUSED_CONTEXT;
3343     return &PL_Vars;
3344 }
3345 #endif
3346
3347 char **
3348 Perl_get_op_names(pTHX)
3349 {
3350     PERL_UNUSED_CONTEXT;
3351     return (char **)PL_op_name;
3352 }
3353
3354 char **
3355 Perl_get_op_descs(pTHX)
3356 {
3357     PERL_UNUSED_CONTEXT;
3358     return (char **)PL_op_desc;
3359 }
3360
3361 const char *
3362 Perl_get_no_modify(pTHX)
3363 {
3364     PERL_UNUSED_CONTEXT;
3365     return PL_no_modify;
3366 }
3367
3368 U32 *
3369 Perl_get_opargs(pTHX)
3370 {
3371     PERL_UNUSED_CONTEXT;
3372     return (U32 *)PL_opargs;
3373 }
3374
3375 PPADDR_t*
3376 Perl_get_ppaddr(pTHX)
3377 {
3378     dVAR;
3379     PERL_UNUSED_CONTEXT;
3380     return (PPADDR_t*)PL_ppaddr;
3381 }
3382
3383 #ifndef HAS_GETENV_LEN
3384 char *
3385 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3386 {
3387     char * const env_trans = PerlEnv_getenv(env_elem);
3388     PERL_UNUSED_CONTEXT;
3389     PERL_ARGS_ASSERT_GETENV_LEN;
3390     if (env_trans)
3391         *len = strlen(env_trans);
3392     return env_trans;
3393 }
3394 #endif
3395
3396
3397 MGVTBL*
3398 Perl_get_vtbl(pTHX_ int vtbl_id)
3399 {
3400     PERL_UNUSED_CONTEXT;
3401
3402     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3403         ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3404 }
3405
3406 I32
3407 Perl_my_fflush_all(pTHX)
3408 {
3409 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3410     return PerlIO_flush(NULL);
3411 #else
3412 # if defined(HAS__FWALK)
3413     extern int fflush(FILE *);
3414     /* undocumented, unprototyped, but very useful BSDism */
3415     extern void _fwalk(int (*)(FILE *));
3416     _fwalk(&fflush);
3417     return 0;
3418 # else
3419 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3420     long open_max = -1;
3421 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3422     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3423 #   elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3424     open_max = sysconf(_SC_OPEN_MAX);
3425 #   elif defined(FOPEN_MAX)
3426     open_max = FOPEN_MAX;
3427 #   elif defined(OPEN_MAX)
3428     open_max = OPEN_MAX;
3429 #   elif defined(_NFILE)
3430     open_max = _NFILE;
3431 #   endif
3432     if (open_max > 0) {
3433       long i;
3434       for (i = 0; i < open_max; i++)
3435             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3436                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3437                 STDIO_STREAM_ARRAY[i]._flag)
3438                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3439       return 0;
3440     }
3441 #  endif
3442     SETERRNO(EBADF,RMS_IFI);
3443     return EOF;
3444 # endif
3445 #endif
3446 }
3447
3448 void
3449 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3450 {
3451     if (ckWARN(WARN_IO)) {
3452         HEK * const name
3453            = gv && (isGV_with_GP(gv))
3454                 ? GvENAME_HEK((gv))
3455                 : NULL;
3456         const char * const direction = have == '>' ? "out" : "in";
3457
3458         if (name && HEK_LEN(name))
3459             Perl_warner(aTHX_ packWARN(WARN_IO),
3460                         "Filehandle %" HEKf " opened only for %sput",
3461                         HEKfARG(name), direction);
3462         else
3463             Perl_warner(aTHX_ packWARN(WARN_IO),
3464                         "Filehandle opened only for %sput", direction);
3465     }
3466 }
3467
3468 void
3469 Perl_report_evil_fh(pTHX_ const GV *gv)
3470 {
3471     const IO *io = gv ? GvIO(gv) : NULL;
3472     const PERL_BITFIELD16 op = PL_op->op_type;
3473     const char *vile;
3474     I32 warn_type;
3475
3476     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3477         vile = "closed";
3478         warn_type = WARN_CLOSED;
3479     }
3480     else {
3481         vile = "unopened";
3482         warn_type = WARN_UNOPENED;
3483     }
3484
3485     if (ckWARN(warn_type)) {
3486         SV * const name
3487             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3488                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3489         const char * const pars =
3490             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3491         const char * const func =
3492             (const char *)
3493             (op == OP_READLINE || op == OP_RCATLINE
3494                                  ? "readline"  :        /* "<HANDLE>" not nice */
3495              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3496              PL_op_desc[op]);
3497         const char * const type =
3498             (const char *)
3499             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3500              ? "socket" : "filehandle");
3501         const bool have_name = name && SvCUR(name);
3502         Perl_warner(aTHX_ packWARN(warn_type),
3503                    "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3504                     have_name ? " " : "",
3505                     SVfARG(have_name ? name : &PL_sv_no));
3506         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3507                 Perl_warner(
3508                             aTHX_ packWARN(warn_type),
3509                         "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3510                         func, pars, have_name ? " " : "",
3511                         SVfARG(have_name ? name : &PL_sv_no)
3512                             );
3513     }
3514 }
3515
3516 /* To workaround core dumps from the uninitialised tm_zone we get the
3517  * system to give us a reasonable struct to copy.  This fix means that
3518  * strftime uses the tm_zone and tm_gmtoff values returned by
3519  * localtime(time()). That should give the desired result most of the
3520  * time. But probably not always!
3521  *
3522  * This does not address tzname aspects of NETaa14816.
3523  *
3524  */
3525
3526 #ifdef __GLIBC__
3527 # ifndef STRUCT_TM_HASZONE
3528 #    define STRUCT_TM_HASZONE
3529 # endif
3530 #endif
3531
3532 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3533 # ifndef HAS_TM_TM_ZONE
3534 #    define HAS_TM_TM_ZONE
3535 # endif
3536 #endif
3537
3538 void
3539 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3540 {
3541 #ifdef HAS_TM_TM_ZONE
3542     Time_t now;
3543     const struct tm* my_tm;
3544     PERL_UNUSED_CONTEXT;
3545     PERL_ARGS_ASSERT_INIT_TM;
3546     (void)time(&now);
3547     my_tm = localtime(&now);
3548     if (my_tm)
3549         Copy(my_tm, ptm, 1, struct tm);
3550 #else
3551     PERL_UNUSED_CONTEXT;
3552     PERL_ARGS_ASSERT_INIT_TM;
3553     PERL_UNUSED_ARG(ptm);
3554 #endif
3555 }
3556
3557 /*
3558  * mini_mktime - normalise struct tm values without the localtime()
3559  * semantics (and overhead) of mktime().
3560  */
3561 void
3562 Perl_mini_mktime(struct tm *ptm)
3563 {
3564     int yearday;
3565     int secs;
3566     int month, mday, year, jday;
3567     int odd_cent, odd_year;
3568
3569     PERL_ARGS_ASSERT_MINI_MKTIME;
3570
3571 #define DAYS_PER_YEAR   365
3572 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3573 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3574 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3575 #define SECS_PER_HOUR   (60*60)
3576 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3577 /* parentheses deliberately absent on these two, otherwise they don't work */
3578 #define MONTH_TO_DAYS   153/5
3579 #define DAYS_TO_MONTH   5/153
3580 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3581 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3582 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3583 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3584
3585 /*
3586  * Year/day algorithm notes:
3587  *
3588  * With a suitable offset for numeric value of the month, one can find
3589  * an offset into the year by considering months to have 30.6 (153/5) days,
3590  * using integer arithmetic (i.e., with truncation).  To avoid too much
3591  * messing about with leap days, we consider January and February to be
3592  * the 13th and 14th month of the previous year.  After that transformation,
3593  * we need the month index we use to be high by 1 from 'normal human' usage,
3594  * so the month index values we use run from 4 through 15.
3595  *
3596  * Given that, and the rules for the Gregorian calendar (leap years are those
3597  * divisible by 4 unless also divisible by 100, when they must be divisible
3598  * by 400 instead), we can simply calculate the number of days since some
3599  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3600  * the days we derive from our month index, and adding in the day of the
3601  * month.  The value used here is not adjusted for the actual origin which
3602  * it normally would use (1 January A.D. 1), since we're not exposing it.
3603  * We're only building the value so we can turn around and get the
3604  * normalised values for the year, month, day-of-month, and day-of-year.
3605  *
3606  * For going backward, we need to bias the value we're using so that we find
3607  * the right year value.  (Basically, we don't want the contribution of
3608  * March 1st to the number to apply while deriving the year).  Having done
3609  * that, we 'count up' the contribution to the year number by accounting for
3610  * full quadracenturies (400-year periods) with their extra leap days, plus
3611  * the contribution from full centuries (to avoid counting in the lost leap
3612  * days), plus the contribution from full quad-years (to count in the normal
3613  * leap days), plus the leftover contribution from any non-leap years.
3614  * At this point, if we were working with an actual leap day, we'll have 0
3615  * days left over.  This is also true for March 1st, however.  So, we have
3616  * to special-case that result, and (earlier) keep track of the 'odd'
3617  * century and year contributions.  If we got 4 extra centuries in a qcent,
3618  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3619  * Otherwise, we add back in the earlier bias we removed (the 123 from
3620  * figuring in March 1st), find the month index (integer division by 30.6),
3621  * and the remainder is the day-of-month.  We then have to convert back to
3622  * 'real' months (including fixing January and February from being 14/15 in
3623  * the previous year to being in the proper year).  After that, to get
3624  * tm_yday, we work with the normalised year and get a new yearday value for
3625  * January 1st, which we subtract from the yearday value we had earlier,
3626  * representing the date we've re-built.  This is done from January 1
3627  * because tm_yday is 0-origin.
3628  *
3629  * Since POSIX time routines are only guaranteed to work for times since the
3630  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3631  * applies Gregorian calendar rules even to dates before the 16th century
3632  * doesn't bother me.  Besides, you'd need cultural context for a given
3633  * date to know whether it was Julian or Gregorian calendar, and that's
3634  * outside the scope for this routine.  Since we convert back based on the
3635  * same rules we used to build the yearday, you'll only get strange results
3636  * for input which needed normalising, or for the 'odd' century years which
3637  * were leap years in the Julian calendar but not in the Gregorian one.
3638  * I can live with that.
3639  *
3640  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3641  * that's still outside the scope for POSIX time manipulation, so I don't
3642  * care.
3643  *
3644  * - lwall
3645  */
3646
3647     year = 1900 + ptm->tm_year;
3648     month = ptm->tm_mon;
3649     mday = ptm->tm_mday;
3650     jday = 0;
3651     if (month >= 2)
3652         month+=2;
3653     else
3654         month+=14, year--;
3655     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3656     yearday += month*MONTH_TO_DAYS + mday + jday;
3657     /*
3658      * Note that we don't know when leap-seconds were or will be,
3659      * so we have to trust the user if we get something which looks
3660      * like a sensible leap-second.  Wild values for seconds will
3661      * be rationalised, however.
3662      */
3663     if ((unsigned) ptm->tm_sec <= 60) {
3664         secs = 0;
3665     }
3666     else {
3667         secs = ptm->tm_sec;
3668         ptm->tm_sec = 0;
3669     }
3670     secs += 60 * ptm->tm_min;
3671     secs += SECS_PER_HOUR * ptm->tm_hour;
3672     if (secs < 0) {
3673         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3674             /* got negative remainder, but need positive time */
3675             /* back off an extra day to compensate */
3676             yearday += (secs/SECS_PER_DAY)-1;
3677             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3678         }
3679         else {
3680             yearday += (secs/SECS_PER_DAY);
3681             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3682         }
3683     }
3684     else if (secs >= SECS_PER_DAY) {
3685         yearday += (secs/SECS_PER_DAY);
3686         secs %= SECS_PER_DAY;
3687     }
3688     ptm->tm_hour = secs/SECS_PER_HOUR;
3689     secs %= SECS_PER_HOUR;
3690     ptm->tm_min = secs/60;
3691     secs %= 60;
3692     ptm->tm_sec += secs;
3693     /* done with time of day effects */
3694     /*
3695      * The algorithm for yearday has (so far) left it high by 428.
3696      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3697      * bias it by 123 while trying to figure out what year it
3698      * really represents.  Even with this tweak, the reverse
3699      * translation fails for years before A.D. 0001.
3700      * It would still fail for Feb 29, but we catch that one below.
3701      */
3702     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3703     yearday -= YEAR_ADJUST;
3704     year = (yearday / DAYS_PER_QCENT) * 400;
3705     yearday %= DAYS_PER_QCENT;
3706     odd_cent = yearday / DAYS_PER_CENT;
3707     year += odd_cent * 100;
3708     yearday %= DAYS_PER_CENT;
3709     year += (yearday / DAYS_PER_QYEAR) * 4;
3710     yearday %= DAYS_PER_QYEAR;
3711     odd_year = yearday / DAYS_PER_YEAR;
3712     year += odd_year;
3713     yearday %= DAYS_PER_YEAR;
3714     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3715         month = 1;
3716         yearday = 29;
3717     }
3718     else {
3719         yearday += YEAR_ADJUST; /* recover March 1st crock */
3720         month = yearday*DAYS_TO_MONTH;
3721         yearday -= month*MONTH_TO_DAYS;
3722         /* recover other leap-year adjustment */
3723         if (month > 13) {
3724             month-=14;
3725             year++;
3726         }
3727         else {
3728             month-=2;
3729         }
3730     }
3731     ptm->tm_year = year - 1900;
3732     if (yearday) {
3733       ptm->tm_mday = yearday;
3734       ptm->tm_mon = month;
3735     }
3736     else {
3737       ptm->tm_mday = 31;
3738       ptm->tm_mon = month - 1;
3739     }
3740     /* re-build yearday based on Jan 1 to get tm_yday */
3741     year--;
3742     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3743     yearday += 14*MONTH_TO_DAYS + 1;
3744     ptm->tm_yday = jday - yearday;
3745     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3746 }
3747
3748 char *
3749 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)
3750 {
3751 #ifdef HAS_STRFTIME
3752
3753   /* strftime(), but with a different API so that the return value is a pointer
3754    * to the formatted result (which MUST be arranged to be FREED BY THE
3755    * CALLER).  This allows this function to increase the buffer size as needed,
3756    * so that the caller doesn't have to worry about that.
3757    *
3758    * Note that yday and wday effectively are ignored by this function, as
3759    * mini_mktime() overwrites them */
3760
3761   char *buf;
3762   int buflen;
3763   struct tm mytm;
3764   int len;
3765
3766   PERL_ARGS_ASSERT_MY_STRFTIME;
3767
3768   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3769   mytm.tm_sec = sec;
3770   mytm.tm_min = min;
3771   mytm.tm_hour = hour;
3772   mytm.tm_mday = mday;
3773   mytm.tm_mon = mon;
3774   mytm.tm_year = year;
3775   mytm.tm_wday = wday;
3776   mytm.tm_yday = yday;
3777   mytm.tm_isdst = isdst;
3778   mini_mktime(&mytm);
3779   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3780 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3781   STMT_START {
3782     struct tm mytm2;
3783     mytm2 = mytm;
3784     mktime(&mytm2);
3785 #ifdef HAS_TM_TM_GMTOFF
3786     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3787 #endif
3788 #ifdef HAS_TM_TM_ZONE
3789     mytm.tm_zone = mytm2.tm_zone;
3790 #endif
3791   } STMT_END;
3792 #endif
3793   buflen = 64;
3794   Newx(buf, buflen, char);
3795
3796   GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3797   len = strftime(buf, buflen, fmt, &mytm);
3798   GCC_DIAG_RESTORE;
3799
3800   /*
3801   ** The following is needed to handle to the situation where
3802   ** tmpbuf overflows.  Basically we want to allocate a buffer
3803   ** and try repeatedly.  The reason why it is so complicated
3804   ** is that getting a return value of 0 from strftime can indicate
3805   ** one of the following:
3806   ** 1. buffer overflowed,
3807   ** 2. illegal conversion specifier, or
3808   ** 3. the format string specifies nothing to be returned(not
3809   **      an error).  This could be because format is an empty string
3810   **    or it specifies %p that yields an empty string in some locale.
3811   ** If there is a better way to make it portable, go ahead by
3812   ** all means.
3813   */
3814   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3815     return buf;
3816   else {
3817     /* Possibly buf overflowed - try again with a bigger buf */
3818     const int fmtlen = strlen(fmt);
3819     int bufsize = fmtlen + buflen;
3820
3821     Renew(buf, bufsize, char);
3822     while (buf) {
3823
3824       GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3825       buflen = strftime(buf, bufsize, fmt, &mytm);
3826       GCC_DIAG_RESTORE;
3827
3828       if (buflen > 0 && buflen < bufsize)
3829         break;
3830       /* heuristic to prevent out-of-memory errors */
3831       if (bufsize > 100*fmtlen) {
3832         Safefree(buf);
3833         buf = NULL;
3834         break;
3835       }
3836       bufsize *= 2;
3837       Renew(buf, bufsize, char);
3838     }
3839     return buf;
3840   }
3841 #else
3842   Perl_croak(aTHX_ "panic: no strftime");
3843   return NULL;
3844 #endif
3845 }
3846
3847
3848 #define SV_CWD_RETURN_UNDEF \
3849     sv_set_undef(sv); \
3850     return FALSE
3851
3852 #define SV_CWD_ISDOT(dp) \
3853     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3854         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3855
3856 /*
3857 =head1 Miscellaneous Functions
3858
3859 =for apidoc getcwd_sv
3860
3861 Fill C<sv> with current working directory
3862
3863 =cut
3864 */
3865
3866 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3867  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3868  * getcwd(3) if available
3869  * Comments from the original:
3870  *     This is a faster version of getcwd.  It's also more dangerous
3871  *     because you might chdir out of a directory that you can't chdir
3872  *     back into. */
3873
3874 int
3875 Perl_getcwd_sv(pTHX_ SV *sv)
3876 {
3877 #ifndef PERL_MICRO
3878     SvTAINTED_on(sv);
3879
3880     PERL_ARGS_ASSERT_GETCWD_SV;
3881
3882 #ifdef HAS_GETCWD
3883     {
3884         char buf[MAXPATHLEN];
3885
3886         /* Some getcwd()s automatically allocate a buffer of the given
3887          * size from the heap if they are given a NULL buffer pointer.
3888          * The problem is that this behaviour is not portable. */
3889         if (getcwd(buf, sizeof(buf) - 1)) {
3890             sv_setpv(sv, buf);
3891             return TRUE;
3892         }
3893         else {
3894             SV_CWD_RETURN_UNDEF;
3895         }
3896     }
3897
3898 #else
3899
3900     Stat_t statbuf;
3901     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3902     int pathlen=0;
3903     Direntry_t *dp;
3904
3905     SvUPGRADE(sv, SVt_PV);
3906
3907     if (PerlLIO_lstat(".", &statbuf) < 0) {
3908         SV_CWD_RETURN_UNDEF;
3909     }
3910
3911     orig_cdev = statbuf.st_dev;
3912     orig_cino = statbuf.st_ino;
3913     cdev = orig_cdev;
3914     cino = orig_cino;
3915
3916     for (;;) {
3917         DIR *dir;
3918         int namelen;
3919         odev = cdev;
3920         oino = cino;
3921
3922         if (PerlDir_chdir("..") < 0) {
3923             SV_CWD_RETURN_UNDEF;
3924         }
3925         if (PerlLIO_stat(".", &statbuf) < 0) {
3926             SV_CWD_RETURN_UNDEF;
3927         }
3928
3929         cdev = statbuf.st_dev;
3930         cino = statbuf.st_ino;
3931
3932         if (odev == cdev && oino == cino) {
3933             break;
3934         }
3935         if (!(dir = PerlDir_open("."))) {
3936             SV_CWD_RETURN_UNDEF;
3937         }
3938
3939         while ((dp = PerlDir_read(dir)) != NULL) {
3940 #ifdef DIRNAMLEN
3941             namelen = dp->d_namlen;
3942 #else
3943             namelen = strlen(dp->d_name);
3944 #endif
3945             /* skip . and .. */
3946             if (SV_CWD_ISDOT(dp)) {
3947                 continue;
3948             }
3949
3950             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3951                 SV_CWD_RETURN_UNDEF;
3952             }
3953
3954             tdev = statbuf.st_dev;
3955             tino = statbuf.st_ino;
3956             if (tino == oino && tdev == odev) {
3957                 break;
3958             }
3959         }
3960
3961         if (!dp) {
3962             SV_CWD_RETURN_UNDEF;
3963         }
3964
3965         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3966             SV_CWD_RETURN_UNDEF;
3967         }
3968
3969         SvGROW(sv, pathlen + namelen + 1);
3970
3971         if (pathlen) {
3972             /* shift down */
3973             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3974         }
3975
3976         /* prepend current directory to the front */
3977         *SvPVX(sv) = '/';
3978         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3979         pathlen += (namelen + 1);
3980
3981 #ifdef VOID_CLOSEDIR
3982         PerlDir_close(dir);
3983 #else
3984         if (PerlDir_close(dir) < 0) {
3985             SV_CWD_RETURN_UNDEF;
3986         }
3987 #endif
3988     }
3989
3990     if (pathlen) {
3991         SvCUR_set(sv, pathlen);
3992         *SvEND(sv) = '\0';
3993         SvPOK_only(sv);
3994
3995         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3996             SV_CWD_RETURN_UNDEF;
3997         }
3998     }
3999     if (PerlLIO_stat(".", &statbuf) < 0) {
4000         SV_CWD_RETURN_UNDEF;
4001     }
4002
4003     cdev = statbuf.st_dev;
4004     cino = statbuf.st_ino;
4005
4006     if (cdev != orig_cdev || cino != orig_cino) {
4007         Perl_croak(aTHX_ "Unstable directory path, "
4008                    "current directory changed unexpectedly");
4009     }
4010
4011     return TRUE;
4012 #endif
4013
4014 #else
4015     return FALSE;
4016 #endif
4017 }
4018
4019 #include "vutil.c"
4020
4021 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4022 #   define EMULATE_SOCKETPAIR_UDP
4023 #endif
4024
4025 #ifdef EMULATE_SOCKETPAIR_UDP
4026 static int
4027 S_socketpair_udp (int fd[2]) {
4028     dTHX;
4029     /* Fake a datagram socketpair using UDP to localhost.  */
4030     int sockets[2] = {-1, -1};
4031     struct sockaddr_in addresses[2];
4032     int i;
4033     Sock_size_t size = sizeof(struct sockaddr_in);
4034     unsigned short port;
4035     int got;
4036
4037     memset(&addresses, 0, sizeof(addresses));
4038     i = 1;
4039     do {
4040         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4041         if (sockets[i] == -1)
4042             goto tidy_up_and_fail;
4043
4044         addresses[i].sin_family = AF_INET;
4045         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4046         addresses[i].sin_port = 0;      /* kernel choses port.  */
4047         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4048                 sizeof(struct sockaddr_in)) == -1)
4049             goto tidy_up_and_fail;
4050     } while (i--);
4051
4052     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4053        for each connect the other socket to it.  */
4054     i = 1;
4055     do {
4056         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4057                 &size) == -1)
4058             goto tidy_up_and_fail;
4059         if (size != sizeof(struct sockaddr_in))
4060             goto abort_tidy_up_and_fail;
4061         /* !1 is 0, !0 is 1 */
4062         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4063                 sizeof(struct sockaddr_in)) == -1)
4064             goto tidy_up_and_fail;
4065     } while (i--);
4066
4067     /* Now we have 2 sockets connected to each other. I don't trust some other
4068        process not to have already sent a packet to us (by random) so send
4069        a packet from each to the other.  */
4070     i = 1;
4071     do {
4072         /* I'm going to send my own port number.  As a short.
4073            (Who knows if someone somewhere has sin_port as a bitfield and needs
4074            this routine. (I'm assuming crays have socketpair)) */
4075         port = addresses[i].sin_port;
4076         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4077         if (got != sizeof(port)) {
4078             if (got == -1)
4079                 goto tidy_up_and_fail;
4080             goto abort_tidy_up_and_fail;
4081         }
4082     } while (i--);
4083
4084     /* Packets sent. I don't trust them to have arrived though.
4085        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4086        connect to localhost will use a second kernel thread. In 2.6 the
4087        first thread running the connect() returns before the second completes,
4088        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4089        returns 0. Poor programs have tripped up. One poor program's authors'
4090        had a 50-1 reverse stock split. Not sure how connected these were.)
4091        So I don't trust someone not to have an unpredictable UDP stack.
4092     */
4093
4094     {
4095         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4096         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4097         fd_set rset;
4098
4099         FD_ZERO(&rset);
4100         FD_SET((unsigned int)sockets[0], &rset);
4101         FD_SET((unsigned int)sockets[1], &rset);
4102
4103         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4104         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4105                 || !FD_ISSET(sockets[1], &rset)) {
4106             /* I hope this is portable and appropriate.  */
4107             if (got == -1)
4108                 goto tidy_up_and_fail;
4109             goto abort_tidy_up_and_fail;
4110         }
4111     }
4112
4113     /* And the paranoia department even now doesn't trust it to have arrive
4114        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4115     {
4116         struct sockaddr_in readfrom;
4117         unsigned short buffer[2];
4118
4119         i = 1;
4120         do {
4121 #ifdef MSG_DONTWAIT
4122             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4123                     sizeof(buffer), MSG_DONTWAIT,
4124                     (struct sockaddr *) &readfrom, &size);
4125 #else
4126             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4127                     sizeof(buffer), 0,
4128                     (struct sockaddr *) &readfrom, &size);
4129 #endif
4130
4131             if (got == -1)
4132                 goto tidy_up_and_fail;
4133             if (got != sizeof(port)
4134                     || size != sizeof(struct sockaddr_in)
4135                     /* Check other socket sent us its port.  */
4136                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4137                     /* Check kernel says we got the datagram from that socket */
4138                     || readfrom.sin_family != addresses[!i].sin_family
4139                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4140                     || readfrom.sin_port != addresses[!i].sin_port)
4141                 goto abort_tidy_up_and_fail;
4142         } while (i--);
4143     }
4144     /* My caller (my_socketpair) has validated that this is non-NULL  */
4145     fd[0] = sockets[0];
4146     fd[1] = sockets[1];
4147     /* I hereby declare this connection open.  May God bless all who cross
4148        her.  */
4149     return 0;
4150
4151   abort_tidy_up_and_fail:
4152     errno = ECONNABORTED;
4153   tidy_up_and_fail:
4154     {
4155         dSAVE_ERRNO;
4156         if (sockets[0] != -1)
4157             PerlLIO_close(sockets[0]);
4158         if (sockets[1] != -1)
4159             PerlLIO_close(sockets[1]);
4160         RESTORE_ERRNO;
4161         return -1;
4162     }
4163 }
4164 #endif /*  EMULATE_SOCKETPAIR_UDP */
4165
4166 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4167 int
4168 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4169     /* Stevens says that family must be AF_LOCAL, protocol 0.
4170        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4171     dTHXa(NULL);
4172     int listener = -1;
4173     int connector = -1;
4174     int acceptor = -1;
4175     struct sockaddr_in listen_addr;
4176     struct sockaddr_in connect_addr;
4177     Sock_size_t size;
4178
4179     if (protocol
4180 #ifdef AF_UNIX
4181         || family != AF_UNIX
4182 #endif
4183     ) {
4184         errno = EAFNOSUPPORT;
4185         return -1;
4186     }
4187     if (!fd) {
4188         errno = EINVAL;
4189         return -1;
4190     }
4191
4192 #ifdef EMULATE_SOCKETPAIR_UDP
4193     if (type == SOCK_DGRAM)
4194         return S_socketpair_udp(fd);
4195 #endif
4196
4197     aTHXa(PERL_GET_THX);
4198     listener = PerlSock_socket(AF_INET, type, 0);
4199     if (listener == -1)
4200         return -1;
4201     memset(&listen_addr, 0, sizeof(listen_addr));
4202     listen_addr.sin_family = AF_INET;
4203     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4204     listen_addr.sin_port = 0;   /* kernel choses port.  */
4205     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4206             sizeof(listen_addr)) == -1)
4207         goto tidy_up_and_fail;
4208     if (PerlSock_listen(listener, 1) == -1)
4209         goto tidy_up_and_fail;
4210
4211     connector = PerlSock_socket(AF_INET, type, 0);
4212     if (connector == -1)
4213         goto tidy_up_and_fail;
4214     /* We want to find out the port number to connect to.  */
4215     size = sizeof(connect_addr);
4216     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4217             &size) == -1)
4218         goto tidy_up_and_fail;
4219     if (size != sizeof(connect_addr))
4220         goto abort_tidy_up_and_fail;
4221     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4222             sizeof(connect_addr)) == -1)
4223         goto tidy_up_and_fail;
4224
4225     size = sizeof(listen_addr);
4226     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4227             &size);
4228     if (acceptor == -1)
4229         goto tidy_up_and_fail;
4230     if (size != sizeof(listen_addr))
4231         goto abort_tidy_up_and_fail;
4232     PerlLIO_close(listener);
4233     /* Now check we are talking to ourself by matching port and host on the
4234        two sockets.  */
4235     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4236             &size) == -1)
4237         goto tidy_up_and_fail;
4238     if (size != sizeof(connect_addr)
4239             || listen_addr.sin_family != connect_addr.sin_family
4240             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4241             || listen_addr.sin_port != connect_addr.sin_port) {
4242         goto abort_tidy_up_and_fail;
4243     }
4244     fd[0] = connector;
4245     fd[1] = acceptor;
4246     return 0;
4247
4248   abort_tidy_up_and_fail:
4249 #ifdef ECONNABORTED
4250   errno = ECONNABORTED; /* This would be the standard thing to do. */
4251 #elif defined(ECONNREFUSED)
4252   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4253 #else
4254   errno = ETIMEDOUT;    /* Desperation time. */
4255 #endif
4256   tidy_up_and_fail:
4257     {
4258         dSAVE_ERRNO;
4259         if (listener != -1)
4260             PerlLIO_close(listener);
4261         if (connector != -1)
4262             PerlLIO_close(connector);
4263         if (acceptor != -1)
4264             PerlLIO_close(acceptor);
4265         RESTORE_ERRNO;
4266         return -1;
4267     }
4268 }
4269 #else
4270 /* In any case have a stub so that there's code corresponding
4271  * to the my_socketpair in embed.fnc. */
4272 int
4273 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4274 #ifdef HAS_SOCKETPAIR
4275     return socketpair(family, type, protocol, fd);
4276 #else
4277     return -1;
4278 #endif
4279 }
4280 #endif
4281
4282 /*
4283
4284 =for apidoc sv_nosharing
4285
4286 Dummy routine which "shares" an SV when there is no sharing module present.
4287 Or "locks" it.  Or "unlocks" it.  In other
4288 words, ignores its single SV argument.
4289 Exists to avoid test for a C<NULL> function pointer and because it could
4290 potentially warn under some level of strict-ness.
4291
4292 =cut
4293 */
4294
4295 void
4296 Perl_sv_nosharing(pTHX_ SV *sv)
4297 {
4298     PERL_UNUSED_CONTEXT;
4299     PERL_UNUSED_ARG(sv);
4300 }
4301
4302 /*
4303
4304 =for apidoc sv_destroyable
4305
4306 Dummy routine which reports that object can be destroyed when there is no
4307 sharing module present.  It ignores its single SV argument, and returns
4308 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4309 could potentially warn under some level of strict-ness.
4310
4311 =cut
4312 */
4313
4314 bool
4315 Perl_sv_destroyable(pTHX_ SV *sv)
4316 {
4317     PERL_UNUSED_CONTEXT;
4318     PERL_UNUSED_ARG(sv);
4319     return TRUE;
4320 }
4321
4322 U32
4323 Perl_parse_unicode_opts(pTHX_ const char **popt)
4324 {
4325   const char *p = *popt;
4326   U32 opt = 0;
4327
4328   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4329
4330   if (*p) {
4331        if (isDIGIT(*p)) {
4332             const char* endptr;
4333             UV uv;
4334             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4335                 opt = (U32)uv;
4336                 p = endptr;
4337                 if (p && *p && *p != '\n' && *p != '\r') {
4338                     if (isSPACE(*p))
4339                         goto the_end_of_the_opts_parser;
4340                     else
4341                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4342                 }
4343             }
4344             else {
4345                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4346             }
4347         }
4348         else {
4349             for (; *p; p++) {
4350                  switch (*p) {
4351                  case PERL_UNICODE_STDIN:
4352                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4353                  case PERL_UNICODE_STDOUT:
4354                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4355                  case PERL_UNICODE_STDERR:
4356                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4357                  case PERL_UNICODE_STD:
4358                       opt |= PERL_UNICODE_STD_FLAG;     break;
4359                  case PERL_UNICODE_IN:
4360                       opt |= PERL_UNICODE_IN_FLAG;      break;
4361                  case PERL_UNICODE_OUT:
4362                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4363                  case PERL_UNICODE_INOUT:
4364                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4365                  case PERL_UNICODE_LOCALE:
4366                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4367                  case PERL_UNICODE_ARGV:
4368                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4369                  case PERL_UNICODE_UTF8CACHEASSERT:
4370                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4371                  default:
4372                       if (*p != '\n' && *p != '\r') {
4373                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4374                         else
4375                           Perl_croak(aTHX_
4376                                      "Unknown Unicode option letter '%c'", *p);
4377                       }
4378                  }
4379             }
4380        }
4381   }
4382   else
4383        opt = PERL_UNICODE_DEFAULT_FLAGS;
4384
4385   the_end_of_the_opts_parser:
4386
4387   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4388        Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4389                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4390
4391   *popt = p;
4392
4393   return opt;
4394 }
4395
4396 #ifdef VMS
4397 #  include <starlet.h>
4398 #endif
4399
4400 U32
4401 Perl_seed(pTHX)
4402 {
4403     /*
4404      * This is really just a quick hack which grabs various garbage
4405      * values.  It really should be a real hash algorithm which
4406      * spreads the effect of every input bit onto every output bit,
4407      * if someone who knows about such things would bother to write it.
4408      * Might be a good idea to add that function to CORE as well.
4409      * No numbers below come from careful analysis or anything here,
4410      * except they are primes and SEED_C1 > 1E6 to get a full-width
4411      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4412      * probably be bigger too.
4413      */
4414 #if RANDBITS > 16
4415 #  define SEED_C1       1000003
4416 #define   SEED_C4       73819
4417 #else
4418 #  define SEED_C1       25747
4419 #define   SEED_C4       20639
4420 #endif
4421 #define   SEED_C2       3
4422 #define   SEED_C3       269
4423 #define   SEED_C5       26107
4424
4425 #ifndef PERL_NO_DEV_RANDOM
4426     int fd;
4427 #endif
4428     U32 u;
4429 #ifdef HAS_GETTIMEOFDAY
4430     struct timeval when;
4431 #else
4432     Time_t when;
4433 #endif
4434
4435 /* This test is an escape hatch, this symbol isn't set by Configure. */
4436 #ifndef PERL_NO_DEV_RANDOM
4437 #ifndef PERL_RANDOM_DEVICE
4438    /* /dev/random isn't used by default because reads from it will block
4439     * if there isn't enough entropy available.  You can compile with
4440     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4441     * is enough real entropy to fill the seed. */
4442 #  ifdef __amigaos4__
4443 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4444 #  else
4445 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4446 #  endif
4447 #endif
4448     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4449     if (fd != -1) {
4450         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4451             u = 0;
4452         PerlLIO_close(fd);
4453         if (u)
4454             return u;
4455     }
4456 #endif
4457
4458 #ifdef HAS_GETTIMEOFDAY
4459     PerlProc_gettimeofday(&when,NULL);
4460     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4461 #else
4462     (void)time(&when);
4463     u = (U32)SEED_C1 * when;
4464 #endif
4465     u += SEED_C3 * (U32)PerlProc_getpid();
4466     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4467 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4468     u += SEED_C5 * (U32)PTR2UV(&when);
4469 #endif
4470     return u;
4471 }
4472
4473 void
4474 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4475 {
4476 #ifndef NO_PERL_HASH_ENV
4477     const char *env_pv;
4478 #endif
4479     unsigned long i;
4480
4481     PERL_ARGS_ASSERT_GET_HASH_SEED;
4482
4483 #ifndef NO_PERL_HASH_ENV
4484     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4485
4486     if ( env_pv )
4487     {
4488         /* ignore leading spaces */
4489         while (isSPACE(*env_pv))
4490             env_pv++;
4491 #    ifdef USE_PERL_PERTURB_KEYS
4492         /* if they set it to "0" we disable key traversal randomization completely */
4493         if (strEQ(env_pv,"0")) {
4494             PL_hash_rand_bits_enabled= 0;
4495         } else {
4496             /* otherwise switch to deterministic mode */
4497             PL_hash_rand_bits_enabled= 2;
4498         }
4499 #    endif
4500         /* ignore a leading 0x... if it is there */
4501         if (env_pv[0] == '0' && env_pv[1] == 'x')
4502             env_pv += 2;
4503
4504         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4505             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4506             if ( isXDIGIT(*env_pv)) {
4507                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4508             }
4509         }
4510         while (isSPACE(*env_pv))
4511             env_pv++;
4512
4513         if (*env_pv && !isXDIGIT(*env_pv)) {
4514             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4515         }
4516         /* should we check for unparsed crap? */
4517         /* should we warn about unused hex? */
4518         /* should we warn about insufficient hex? */
4519     }
4520     else
4521 #endif /* NO_PERL_HASH_ENV */
4522     {
4523         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4524             seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
4525         }
4526     }
4527 #ifdef USE_PERL_PERTURB_KEYS
4528     {   /* initialize PL_hash_rand_bits from the hash seed.
4529          * This value is highly volatile, it is updated every
4530          * hash insert, and is used as part of hash bucket chain
4531          * randomization and hash iterator randomization. */
4532         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4533         for( i = 0; i < sizeof(UV) ; i++ ) {
4534             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4535             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4536         }
4537     }
4538 #  ifndef NO_PERL_HASH_ENV
4539     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4540     if (env_pv) {
4541         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4542             PL_hash_rand_bits_enabled= 0;
4543         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4544             PL_hash_rand_bits_enabled= 1;
4545         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4546             PL_hash_rand_bits_enabled= 2;
4547         } else {
4548             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4549         }
4550     }
4551 #  endif
4552 #endif
4553 }
4554
4555 #ifdef PERL_GLOBAL_STRUCT
4556
4557 #define PERL_GLOBAL_STRUCT_INIT
4558 #include "opcode.h" /* the ppaddr and check */
4559
4560 struct perl_vars *
4561 Perl_init_global_struct(pTHX)
4562 {
4563     struct perl_vars *plvarsp = NULL;
4564 # ifdef PERL_GLOBAL_STRUCT
4565     const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4566     const IV ncheck  = C_ARRAY_LENGTH(Gcheck);
4567     PERL_UNUSED_CONTEXT;
4568 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4569     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4570     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4571     if (!plvarsp)
4572         exit(1);
4573 #  else
4574     plvarsp = PL_VarsPtr;
4575 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4576 #  undef PERLVAR
4577 #  undef PERLVARA
4578 #  undef PERLVARI
4579 #  undef PERLVARIC
4580 #  define PERLVAR(prefix,var,type) /**/
4581 #  define PERLVARA(prefix,var,n,type) /**/
4582 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4583 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4584 #  include "perlvars.h"
4585 #  undef PERLVAR
4586 #  undef PERLVARA
4587 #  undef PERLVARI
4588 #  undef PERLVARIC
4589 #  ifdef PERL_GLOBAL_STRUCT
4590     plvarsp->Gppaddr =
4591         (Perl_ppaddr_t*)
4592         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4593     if (!plvarsp->Gppaddr)
4594         exit(1);
4595     plvarsp->Gcheck  =
4596         (Perl_check_t*)
4597         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4598     if (!plvarsp->Gcheck)
4599         exit(1);
4600     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
4601     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t); 
4602 #  endif
4603 #  ifdef PERL_SET_VARS
4604     PERL_SET_VARS(plvarsp);
4605 #  endif
4606 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4607     plvarsp->Gsv_placeholder.sv_flags = 0;
4608     memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4609 #  endif
4610 # undef PERL_GLOBAL_STRUCT_INIT
4611 # endif
4612     return plvarsp;
4613 }
4614
4615 #endif /* PERL_GLOBAL_STRUCT */
4616
4617 #ifdef PERL_GLOBAL_STRUCT
4618
4619 void
4620 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4621 {
4622     int veto = plvarsp->Gveto_cleanup;
4623
4624     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4625     PERL_UNUSED_CONTEXT;
4626 # ifdef PERL_GLOBAL_STRUCT
4627 #  ifdef PERL_UNSET_VARS
4628     PERL_UNSET_VARS(plvarsp);
4629 #  endif
4630     if (veto)
4631         return;
4632     free(plvarsp->Gppaddr);
4633     free(plvarsp->Gcheck);
4634 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4635     free(plvarsp);
4636 #  endif
4637 # endif
4638 }
4639
4640 #endif /* PERL_GLOBAL_STRUCT */
4641
4642 #ifdef PERL_MEM_LOG
4643
4644 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4645  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4646  * given, and you supply your own implementation.
4647  *
4648  * The default implementation reads a single env var, PERL_MEM_LOG,
4649  * expecting one or more of the following:
4650  *
4651  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4652  *    'm' - memlog      was PERL_MEM_LOG=1
4653  *    's' - svlog       was PERL_SV_LOG=1
4654  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4655  *
4656  * This makes the logger controllable enough that it can reasonably be
4657  * added to the system perl.
4658  */
4659
4660 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4661  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4662  */
4663 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4664
4665 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4666  * writes to.  In the default logger, this is settable at runtime.
4667  */
4668 #ifndef PERL_MEM_LOG_FD
4669 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4670 #endif
4671
4672 #ifndef PERL_MEM_LOG_NOIMPL
4673
4674 # ifdef DEBUG_LEAKING_SCALARS
4675 #   define SV_LOG_SERIAL_FMT        " [%lu]"
4676 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
4677 # else
4678 #   define SV_LOG_SERIAL_FMT
4679 #   define _SV_LOG_SERIAL_ARG(sv)
4680 # endif
4681
4682 static void
4683 S_mem_log_common(enum mem_log_type mlt, const UV n, 
4684                  const UV typesize, const char *type_name, const SV *sv,
4685                  Malloc_t oldalloc, Malloc_t newalloc,
4686                  const char *filename, const int linenumber,
4687                  const char *funcname)
4688 {
4689     const char *pmlenv;
4690
4691     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4692
4693     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4694     if (!pmlenv)
4695         return;
4696     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4697     {
4698         /* We can't use SVs or PerlIO for obvious reasons,
4699          * so we'll use stdio and low-level IO instead. */
4700         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4701
4702 #   ifdef HAS_GETTIMEOFDAY
4703 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
4704 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
4705         struct timeval tv;
4706         gettimeofday(&tv, 0);
4707 #   else
4708 #     define MEM_LOG_TIME_FMT   "%10d: "
4709 #     define MEM_LOG_TIME_ARG   (int)when
4710         Time_t when;
4711         (void)time(&when);
4712 #   endif
4713         /* If there are other OS specific ways of hires time than
4714          * gettimeofday() (see dist/Time-HiRes), the easiest way is
4715          * probably that they would be used to fill in the struct
4716          * timeval. */
4717         {
4718             STRLEN len;
4719             const char* endptr;
4720             int fd;
4721             UV uv;
4722             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4723                 && uv && uv <= PERL_INT_MAX
4724             ) {
4725                 fd = (int)uv;
4726             } else {
4727                 fd = PERL_MEM_LOG_FD;
4728             }
4729
4730             if (strchr(pmlenv, 't')) {
4731                 len = my_snprintf(buf, sizeof(buf),
4732                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4733                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4734             }
4735             switch (mlt) {
4736             case MLT_ALLOC:
4737                 len = my_snprintf(buf, sizeof(buf),
4738                         "alloc: %s:%d:%s: %" IVdf " %" UVuf
4739                         " %s = %" IVdf ": %" UVxf "\n",
4740                         filename, linenumber, funcname, n, typesize,
4741                         type_name, n * typesize, PTR2UV(newalloc));
4742                 break;
4743             case MLT_REALLOC:
4744                 len = my_snprintf(buf, sizeof(buf),
4745                         "realloc: %s:%d:%s: %" IVdf " %" UVuf
4746                         " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
4747                         filename, linenumber, funcname, n, typesize,
4748                         type_name, n * typesize, PTR2UV(oldalloc),
4749                         PTR2UV(newalloc));
4750                 break;
4751             case MLT_FREE:
4752                 len = my_snprintf(buf, sizeof(buf),
4753                         "free: %s:%d:%s: %" UVxf "\n",
4754                         filename, linenumber, funcname,
4755                         PTR2UV(oldalloc));
4756                 break;
4757             case MLT_NEW_SV:
4758             case MLT_DEL_SV:
4759                 len = my_snprintf(buf, sizeof(buf),
4760                         "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
4761                         mlt == MLT_NEW_SV ? "new" : "del",
4762                         filename, linenumber, funcname,
4763                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4764                 break;
4765             default:
4766                 len = 0;
4767             }
4768             PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4769         }
4770     }
4771 }
4772 #endif /* !PERL_MEM_LOG_NOIMPL */
4773
4774 #ifndef PERL_MEM_LOG_NOIMPL
4775 # define \
4776     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
4777     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
4778 #else
4779 /* this is suboptimal, but bug compatible.  User is providing their
4780    own implementation, but is getting these functions anyway, and they
4781    do nothing. But _NOIMPL users should be able to cope or fix */
4782 # define \
4783     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
4784     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
4785 #endif
4786
4787 Malloc_t
4788 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
4789                    Malloc_t newalloc, 
4790                    const char *filename, const int linenumber,
4791                    const char *funcname)
4792 {
4793     PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
4794
4795     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
4796                       NULL, NULL, newalloc,
4797                       filename, linenumber, funcname);
4798     return newalloc;
4799 }
4800
4801 Malloc_t
4802 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
4803                      Malloc_t oldalloc, Malloc_t newalloc, 
4804                      const char *filename, const int linenumber, 
4805                      const char *funcname)
4806 {
4807     PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
4808
4809     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
4810                       NULL, oldalloc, newalloc, 
4811                       filename, linenumber, funcname);
4812     return newalloc;
4813 }
4814
4815 Malloc_t
4816 Perl_mem_log_free(Malloc_t oldalloc, 
4817                   const char *filename, const int linenumber, 
4818                   const char *funcname)
4819 {
4820     PERL_ARGS_ASSERT_MEM_LOG_FREE;
4821
4822     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
4823                       filename, linenumber, funcname);
4824     return oldalloc;
4825 }
4826
4827 void
4828 Perl_mem_log_new_sv(const SV *sv, 
4829                     const char *filename, const int linenumber,
4830                     const char *funcname)
4831 {
4832     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
4833                       filename, linenumber, funcname);
4834 }
4835
4836 void
4837 Perl_mem_log_del_sv(const SV *sv,
4838                     const char *filename, const int linenumber, 
4839                     const char *funcname)
4840 {
4841     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
4842                       filename, linenumber, funcname);
4843 }
4844
4845 #endif /* PERL_MEM_LOG */
4846
4847 /*
4848 =for apidoc quadmath_format_single
4849
4850 C<quadmath_snprintf()> is very strict about its C<format> string and will
4851 fail, returning -1, if the format is invalid.  It accepts exactly
4852 one format spec.
4853
4854 C<quadmath_format_single()> checks that the intended single spec looks
4855 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
4856 and has C<Q> before it.  This is not a full "printf syntax check",
4857 just the basics.
4858
4859 Returns the format if it is valid, NULL if not.
4860
4861 C<quadmath_format_single()> can and will actually patch in the missing
4862 C<Q>, if necessary.  In this case it will return the modified copy of
4863 the format, B<which the caller will need to free.>
4864
4865 See also L</quadmath_format_needed>.
4866
4867 =cut
4868 */
4869 #ifdef USE_QUADMATH
4870 const char*
4871 Perl_quadmath_format_single(const char* format)
4872 {
4873     STRLEN len;
4874
4875     PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
4876
4877     if (format[0] != '%' || strchr(format + 1, '%'))
4878         return NULL;
4879     len = strlen(format);
4880     /* minimum length three: %Qg */
4881     if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
4882         return NULL;
4883     if (format[len - 2] != 'Q') {
4884         char* fixed;
4885         Newx(fixed, len + 1, char);
4886         memcpy(fixed, format, len - 1);
4887         fixed[len - 1] = 'Q';
4888         fixed[len    ] = format[len - 1];
4889         fixed[len + 1] = 0;
4890         return (const char*)fixed;
4891     }
4892     return format;
4893 }
4894 #endif
4895
4896 /*
4897 =for apidoc quadmath_format_needed
4898
4899 C<quadmath_format_needed()> returns true if the C<format> string seems to
4900 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
4901 or returns false otherwise.
4902
4903 The format specifier detection is not complete printf-syntax detection,
4904 but it should catch most common cases.
4905
4906 If true is returned, those arguments B<should> in theory be processed
4907 with C<quadmath_snprintf()>, but in case there is more than one such
4908 format specifier (see L</quadmath_format_single>), and if there is
4909 anything else beyond that one (even just a single byte), they
4910 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
4911 accepting only one format spec, and nothing else.
4912 In this case, the code should probably fail.
4913
4914 =cut
4915 */
4916 #ifdef USE_QUADMATH
4917 bool
4918 Perl_quadmath_format_needed(const char* format)
4919 {
4920   const char *p = format;
4921   const char *q;
4922
4923   PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
4924
4925   while ((q = strchr(p, '%'))) {
4926     q++;
4927     if (*q == '+') /* plus */
4928       q++;
4929     if (*q == '#') /* alt */
4930       q++;
4931     if (*q == '*') /* width */
4932       q++;
4933     else {
4934       if (isDIGIT(*q)) {
4935         while (isDIGIT(*q)) q++;
4936       }
4937     }
4938     if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
4939       q++;
4940       if (*q == '*')
4941         q++;
4942       else
4943         while (isDIGIT(*q)) q++;
4944     }
4945     if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
4946       return TRUE;
4947     p = q + 1;
4948   }
4949   return FALSE;
4950 }
4951 #endif
4952
4953 /*
4954 =for apidoc my_snprintf
4955
4956 The C library C<snprintf> functionality, if available and
4957 standards-compliant (uses C<vsnprintf>, actually).  However, if the
4958 C<vsnprintf> is not available, will unfortunately use the unsafe
4959 C<vsprintf> which can overrun the buffer (there is an overrun check,
4960 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
4961 getting C<vsnprintf>.
4962
4963 =cut
4964 */
4965 int
4966 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
4967 {
4968     int retval = -1;
4969     va_list ap;
4970     PERL_ARGS_ASSERT_MY_SNPRINTF;
4971 #ifndef HAS_VSNPRINTF
4972     PERL_UNUSED_VAR(len);
4973 #endif
4974     va_start(ap, format);
4975 #ifdef USE_QUADMATH
4976     {
4977         const char* qfmt = quadmath_format_single(format);
4978         bool quadmath_valid = FALSE;
4979         if (qfmt) {
4980             /* If the format looked promising, use it as quadmath. */
4981             retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
4982             if (retval == -1) {
4983                 if (qfmt != format) {
4984                     dTHX;
4985                     SAVEFREEPV(qfmt);
4986                 }
4987                 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
4988             }
4989             quadmath_valid = TRUE;
4990             if (qfmt != format)
4991                 Safefree(qfmt);
4992             qfmt = NULL;
4993         }
4994         assert(qfmt == NULL);
4995         /* quadmath_format_single() will return false for example for
4996          * "foo = %g", or simply "%g".  We could handle the %g by
4997          * using quadmath for the NV args.  More complex cases of
4998          * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
4999          * quadmath-valid but has stuff in front).
5000          *
5001          * Handling the "Q-less" cases right would require walking
5002          * through the va_list and rewriting the format, calling
5003          * quadmath for the NVs, building a new va_list, and then
5004          * letting vsnprintf/vsprintf to take care of the other
5005          * arguments.  This may be doable.
5006          *
5007          * We do not attempt that now.  But for paranoia, we here try
5008          * to detect some common (but not all) cases where the
5009          * "Q-less" %[efgaEFGA] formats are present, and die if
5010          * detected.  This doesn't fix the problem, but it stops the
5011          * vsnprintf/vsprintf pulling doubles off the va_list when
5012          * __float128 NVs should be pulled off instead.
5013          *
5014          * If quadmath_format_needed() returns false, we are reasonably
5015          * certain that we can call vnsprintf() or vsprintf() safely. */
5016         if (!quadmath_valid && quadmath_format_needed(format))
5017           Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5018
5019     }
5020 #endif
5021     if (retval == -1)
5022 #ifdef HAS_VSNPRINTF
5023         retval = vsnprintf(buffer, len, format, ap);
5024 #else
5025         retval = vsprintf(buffer, format, ap);
5026 #endif
5027     va_end(ap);
5028     /* vsprintf() shows failure with < 0 */
5029     if (retval < 0
5030 #ifdef HAS_VSNPRINTF
5031     /* vsnprintf() shows failure with >= len */
5032         ||
5033         (len > 0 && (Size_t)retval >= len)
5034 #endif
5035     )
5036         Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5037     return retval;
5038 }
5039
5040 /*
5041 =for apidoc my_vsnprintf
5042
5043 The C library C<vsnprintf> if available and standards-compliant.
5044 However, if if the C<vsnprintf> is not available, will unfortunately
5045 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5046 overrun check, but that may be too late).  Consider using
5047 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5048
5049 =cut
5050 */
5051 int
5052 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5053 {
5054 #ifdef USE_QUADMATH
5055     PERL_UNUSED_ARG(buffer);
5056     PERL_UNUSED_ARG(len);
5057     PERL_UNUSED_ARG(format);
5058     /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
5059     PERL_UNUSED_ARG((void*)ap);
5060     Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5061     return 0;
5062 #else
5063     int retval;
5064 #ifdef NEED_VA_COPY
5065     va_list apc;
5066
5067     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5068     Perl_va_copy(ap, apc);
5069 # ifdef HAS_VSNPRINTF
5070     retval = vsnprintf(buffer, len, format, apc);
5071 # else
5072     PERL_UNUSED_ARG(len);
5073     retval = vsprintf(buffer, format, apc);
5074 # endif
5075     va_end(apc);
5076 #else
5077 # ifdef HAS_VSNPRINTF
5078     retval = vsnprintf(buffer, len, format, ap);
5079 # else
5080     PERL_UNUSED_ARG(len);
5081     retval = vsprintf(buffer, format, ap);
5082 # endif
5083 #endif /* #ifdef NEED_VA_COPY */
5084     /* vsprintf() shows failure with < 0 */
5085     if (retval < 0
5086 #ifdef HAS_VSNPRINTF
5087     /* vsnprintf() shows failure with >= len */
5088         ||
5089         (len > 0 && (Size_t)retval >= len)