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