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