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