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