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