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