This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3b910965aa942d910c4f1484f3e4fb036ffb2f9b
[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     Time_t now;
3636     const struct tm* my_tm;
3637     PERL_UNUSED_CONTEXT;
3638     PERL_ARGS_ASSERT_INIT_TM;
3639     (void)time(&now);
3640     ENV_LOCALE_READ_LOCK;
3641     my_tm = localtime(&now);
3642     if (my_tm)
3643         Copy(my_tm, ptm, 1, struct tm);
3644     ENV_LOCALE_READ_UNLOCK;
3645 #else
3646     PERL_UNUSED_CONTEXT;
3647     PERL_ARGS_ASSERT_INIT_TM;
3648     PERL_UNUSED_ARG(ptm);
3649 #endif
3650 }
3651
3652 /*
3653  * mini_mktime - normalise struct tm values without the localtime()
3654  * semantics (and overhead) of mktime().
3655  */
3656 void
3657 Perl_mini_mktime(struct tm *ptm)
3658 {
3659     int yearday;
3660     int secs;
3661     int month, mday, year, jday;
3662     int odd_cent, odd_year;
3663
3664     PERL_ARGS_ASSERT_MINI_MKTIME;
3665
3666 #define DAYS_PER_YEAR   365
3667 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3668 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3669 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3670 #define SECS_PER_HOUR   (60*60)
3671 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3672 /* parentheses deliberately absent on these two, otherwise they don't work */
3673 #define MONTH_TO_DAYS   153/5
3674 #define DAYS_TO_MONTH   5/153
3675 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3676 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3677 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3678 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3679
3680 /*
3681  * Year/day algorithm notes:
3682  *
3683  * With a suitable offset for numeric value of the month, one can find
3684  * an offset into the year by considering months to have 30.6 (153/5) days,
3685  * using integer arithmetic (i.e., with truncation).  To avoid too much
3686  * messing about with leap days, we consider January and February to be
3687  * the 13th and 14th month of the previous year.  After that transformation,
3688  * we need the month index we use to be high by 1 from 'normal human' usage,
3689  * so the month index values we use run from 4 through 15.
3690  *
3691  * Given that, and the rules for the Gregorian calendar (leap years are those
3692  * divisible by 4 unless also divisible by 100, when they must be divisible
3693  * by 400 instead), we can simply calculate the number of days since some
3694  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3695  * the days we derive from our month index, and adding in the day of the
3696  * month.  The value used here is not adjusted for the actual origin which
3697  * it normally would use (1 January A.D. 1), since we're not exposing it.
3698  * We're only building the value so we can turn around and get the
3699  * normalised values for the year, month, day-of-month, and day-of-year.
3700  *
3701  * For going backward, we need to bias the value we're using so that we find
3702  * the right year value.  (Basically, we don't want the contribution of
3703  * March 1st to the number to apply while deriving the year).  Having done
3704  * that, we 'count up' the contribution to the year number by accounting for
3705  * full quadracenturies (400-year periods) with their extra leap days, plus
3706  * the contribution from full centuries (to avoid counting in the lost leap
3707  * days), plus the contribution from full quad-years (to count in the normal
3708  * leap days), plus the leftover contribution from any non-leap years.
3709  * At this point, if we were working with an actual leap day, we'll have 0
3710  * days left over.  This is also true for March 1st, however.  So, we have
3711  * to special-case that result, and (earlier) keep track of the 'odd'
3712  * century and year contributions.  If we got 4 extra centuries in a qcent,
3713  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3714  * Otherwise, we add back in the earlier bias we removed (the 123 from
3715  * figuring in March 1st), find the month index (integer division by 30.6),
3716  * and the remainder is the day-of-month.  We then have to convert back to
3717  * 'real' months (including fixing January and February from being 14/15 in
3718  * the previous year to being in the proper year).  After that, to get
3719  * tm_yday, we work with the normalised year and get a new yearday value for
3720  * January 1st, which we subtract from the yearday value we had earlier,
3721  * representing the date we've re-built.  This is done from January 1
3722  * because tm_yday is 0-origin.
3723  *
3724  * Since POSIX time routines are only guaranteed to work for times since the
3725  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3726  * applies Gregorian calendar rules even to dates before the 16th century
3727  * doesn't bother me.  Besides, you'd need cultural context for a given
3728  * date to know whether it was Julian or Gregorian calendar, and that's
3729  * outside the scope for this routine.  Since we convert back based on the
3730  * same rules we used to build the yearday, you'll only get strange results
3731  * for input which needed normalising, or for the 'odd' century years which
3732  * were leap years in the Julian calendar but not in the Gregorian one.
3733  * I can live with that.
3734  *
3735  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3736  * that's still outside the scope for POSIX time manipulation, so I don't
3737  * care.
3738  *
3739  * - lwall
3740  */
3741
3742     year = 1900 + ptm->tm_year;
3743     month = ptm->tm_mon;
3744     mday = ptm->tm_mday;
3745     jday = 0;
3746     if (month >= 2)
3747         month+=2;
3748     else
3749         month+=14, year--;
3750     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3751     yearday += month*MONTH_TO_DAYS + mday + jday;
3752     /*
3753      * Note that we don't know when leap-seconds were or will be,
3754      * so we have to trust the user if we get something which looks
3755      * like a sensible leap-second.  Wild values for seconds will
3756      * be rationalised, however.
3757      */
3758     if ((unsigned) ptm->tm_sec <= 60) {
3759         secs = 0;
3760     }
3761     else {
3762         secs = ptm->tm_sec;
3763         ptm->tm_sec = 0;
3764     }
3765     secs += 60 * ptm->tm_min;
3766     secs += SECS_PER_HOUR * ptm->tm_hour;
3767     if (secs < 0) {
3768         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3769             /* got negative remainder, but need positive time */
3770             /* back off an extra day to compensate */
3771             yearday += (secs/SECS_PER_DAY)-1;
3772             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3773         }
3774         else {
3775             yearday += (secs/SECS_PER_DAY);
3776             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3777         }
3778     }
3779     else if (secs >= SECS_PER_DAY) {
3780         yearday += (secs/SECS_PER_DAY);
3781         secs %= SECS_PER_DAY;
3782     }
3783     ptm->tm_hour = secs/SECS_PER_HOUR;
3784     secs %= SECS_PER_HOUR;
3785     ptm->tm_min = secs/60;
3786     secs %= 60;
3787     ptm->tm_sec += secs;
3788     /* done with time of day effects */
3789     /*
3790      * The algorithm for yearday has (so far) left it high by 428.
3791      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3792      * bias it by 123 while trying to figure out what year it
3793      * really represents.  Even with this tweak, the reverse
3794      * translation fails for years before A.D. 0001.
3795      * It would still fail for Feb 29, but we catch that one below.
3796      */
3797     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3798     yearday -= YEAR_ADJUST;
3799     year = (yearday / DAYS_PER_QCENT) * 400;
3800     yearday %= DAYS_PER_QCENT;
3801     odd_cent = yearday / DAYS_PER_CENT;
3802     year += odd_cent * 100;
3803     yearday %= DAYS_PER_CENT;
3804     year += (yearday / DAYS_PER_QYEAR) * 4;
3805     yearday %= DAYS_PER_QYEAR;
3806     odd_year = yearday / DAYS_PER_YEAR;
3807     year += odd_year;
3808     yearday %= DAYS_PER_YEAR;
3809     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3810         month = 1;
3811         yearday = 29;
3812     }
3813     else {
3814         yearday += YEAR_ADJUST; /* recover March 1st crock */
3815         month = yearday*DAYS_TO_MONTH;
3816         yearday -= month*MONTH_TO_DAYS;
3817         /* recover other leap-year adjustment */
3818         if (month > 13) {
3819             month-=14;
3820             year++;
3821         }
3822         else {
3823             month-=2;
3824         }
3825     }
3826     ptm->tm_year = year - 1900;
3827     if (yearday) {
3828       ptm->tm_mday = yearday;
3829       ptm->tm_mon = month;
3830     }
3831     else {
3832       ptm->tm_mday = 31;
3833       ptm->tm_mon = month - 1;
3834     }
3835     /* re-build yearday based on Jan 1 to get tm_yday */
3836     year--;
3837     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3838     yearday += 14*MONTH_TO_DAYS + 1;
3839     ptm->tm_yday = jday - yearday;
3840     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3841 }
3842
3843 char *
3844 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)
3845 {
3846 #ifdef HAS_STRFTIME
3847
3848   /* strftime(), but with a different API so that the return value is a pointer
3849    * to the formatted result (which MUST be arranged to be FREED BY THE
3850    * CALLER).  This allows this function to increase the buffer size as needed,
3851    * so that the caller doesn't have to worry about that.
3852    *
3853    * Note that yday and wday effectively are ignored by this function, as
3854    * mini_mktime() overwrites them */
3855
3856   char *buf;
3857   int buflen;
3858   struct tm mytm;
3859   int len;
3860
3861   PERL_ARGS_ASSERT_MY_STRFTIME;
3862
3863   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3864   mytm.tm_sec = sec;
3865   mytm.tm_min = min;
3866   mytm.tm_hour = hour;
3867   mytm.tm_mday = mday;
3868   mytm.tm_mon = mon;
3869   mytm.tm_year = year;
3870   mytm.tm_wday = wday;
3871   mytm.tm_yday = yday;
3872   mytm.tm_isdst = isdst;
3873   mini_mktime(&mytm);
3874   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3875 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3876   STMT_START {
3877     struct tm mytm2;
3878     mytm2 = mytm;
3879     mktime(&mytm2);
3880 #ifdef HAS_TM_TM_GMTOFF
3881     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3882 #endif
3883 #ifdef HAS_TM_TM_ZONE
3884     mytm.tm_zone = mytm2.tm_zone;
3885 #endif
3886   } STMT_END;
3887 #endif
3888   buflen = 64;
3889   Newx(buf, buflen, char);
3890
3891   GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
3892   len = strftime(buf, buflen, fmt, &mytm);
3893   GCC_DIAG_RESTORE_STMT;
3894
3895   /*
3896   ** The following is needed to handle to the situation where
3897   ** tmpbuf overflows.  Basically we want to allocate a buffer
3898   ** and try repeatedly.  The reason why it is so complicated
3899   ** is that getting a return value of 0 from strftime can indicate
3900   ** one of the following:
3901   ** 1. buffer overflowed,
3902   ** 2. illegal conversion specifier, or
3903   ** 3. the format string specifies nothing to be returned(not
3904   **      an error).  This could be because format is an empty string
3905   **    or it specifies %p that yields an empty string in some locale.
3906   ** If there is a better way to make it portable, go ahead by
3907   ** all means.
3908   */
3909   if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
3910     return buf;
3911   else {
3912     /* Possibly buf overflowed - try again with a bigger buf */
3913     const int fmtlen = strlen(fmt);
3914     int bufsize = fmtlen + buflen;
3915
3916     Renew(buf, bufsize, char);
3917     while (buf) {
3918
3919       GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
3920       buflen = strftime(buf, bufsize, fmt, &mytm);
3921       GCC_DIAG_RESTORE_STMT;
3922
3923       if (inRANGE(buflen, 1, bufsize - 1))
3924         break;
3925       /* heuristic to prevent out-of-memory errors */
3926       if (bufsize > 100*fmtlen) {
3927         Safefree(buf);
3928         buf = NULL;
3929         break;
3930       }
3931       bufsize *= 2;
3932       Renew(buf, bufsize, char);
3933     }
3934     return buf;
3935   }
3936 #else
3937   Perl_croak(aTHX_ "panic: no strftime");
3938   return NULL;
3939 #endif
3940 }
3941
3942
3943 #define SV_CWD_RETURN_UNDEF \
3944     sv_set_undef(sv); \
3945     return FALSE
3946
3947 #define SV_CWD_ISDOT(dp) \
3948     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3949         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3950
3951 /*
3952 =head1 Miscellaneous Functions
3953
3954 =for apidoc getcwd_sv
3955
3956 Fill C<sv> with current working directory
3957
3958 =cut
3959 */
3960
3961 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3962  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3963  * getcwd(3) if available
3964  * Comments from the original:
3965  *     This is a faster version of getcwd.  It's also more dangerous
3966  *     because you might chdir out of a directory that you can't chdir
3967  *     back into. */
3968
3969 int
3970 Perl_getcwd_sv(pTHX_ SV *sv)
3971 {
3972 #ifndef PERL_MICRO
3973     SvTAINTED_on(sv);
3974
3975     PERL_ARGS_ASSERT_GETCWD_SV;
3976
3977 #ifdef HAS_GETCWD
3978     {
3979         char buf[MAXPATHLEN];
3980
3981         /* Some getcwd()s automatically allocate a buffer of the given
3982          * size from the heap if they are given a NULL buffer pointer.
3983          * The problem is that this behaviour is not portable. */
3984         if (getcwd(buf, sizeof(buf) - 1)) {
3985             sv_setpv(sv, buf);
3986             return TRUE;
3987         }
3988         else {
3989             SV_CWD_RETURN_UNDEF;
3990         }
3991     }
3992
3993 #else
3994
3995     Stat_t statbuf;
3996     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3997     int pathlen=0;
3998     Direntry_t *dp;
3999
4000     SvUPGRADE(sv, SVt_PV);
4001
4002     if (PerlLIO_lstat(".", &statbuf) < 0) {
4003         SV_CWD_RETURN_UNDEF;
4004     }
4005
4006     orig_cdev = statbuf.st_dev;
4007     orig_cino = statbuf.st_ino;
4008     cdev = orig_cdev;
4009     cino = orig_cino;
4010
4011     for (;;) {
4012         DIR *dir;
4013         int namelen;
4014         odev = cdev;
4015         oino = cino;
4016
4017         if (PerlDir_chdir("..") < 0) {
4018             SV_CWD_RETURN_UNDEF;
4019         }
4020         if (PerlLIO_stat(".", &statbuf) < 0) {
4021             SV_CWD_RETURN_UNDEF;
4022         }
4023
4024         cdev = statbuf.st_dev;
4025         cino = statbuf.st_ino;
4026
4027         if (odev == cdev && oino == cino) {
4028             break;
4029         }
4030         if (!(dir = PerlDir_open("."))) {
4031             SV_CWD_RETURN_UNDEF;
4032         }
4033
4034         while ((dp = PerlDir_read(dir)) != NULL) {
4035 #ifdef DIRNAMLEN
4036             namelen = dp->d_namlen;
4037 #else
4038             namelen = strlen(dp->d_name);
4039 #endif
4040             /* skip . and .. */
4041             if (SV_CWD_ISDOT(dp)) {
4042                 continue;
4043             }
4044
4045             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4046                 SV_CWD_RETURN_UNDEF;
4047             }
4048
4049             tdev = statbuf.st_dev;
4050             tino = statbuf.st_ino;
4051             if (tino == oino && tdev == odev) {
4052                 break;
4053             }
4054         }
4055
4056         if (!dp) {
4057             SV_CWD_RETURN_UNDEF;
4058         }
4059
4060         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4061             SV_CWD_RETURN_UNDEF;
4062         }
4063
4064         SvGROW(sv, pathlen + namelen + 1);
4065
4066         if (pathlen) {
4067             /* shift down */
4068             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4069         }
4070
4071         /* prepend current directory to the front */
4072         *SvPVX(sv) = '/';
4073         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4074         pathlen += (namelen + 1);
4075
4076 #ifdef VOID_CLOSEDIR
4077         PerlDir_close(dir);
4078 #else
4079         if (PerlDir_close(dir) < 0) {
4080             SV_CWD_RETURN_UNDEF;
4081         }
4082 #endif
4083     }
4084
4085     if (pathlen) {
4086         SvCUR_set(sv, pathlen);
4087         *SvEND(sv) = '\0';
4088         SvPOK_only(sv);
4089
4090         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4091             SV_CWD_RETURN_UNDEF;
4092         }
4093     }
4094     if (PerlLIO_stat(".", &statbuf) < 0) {
4095         SV_CWD_RETURN_UNDEF;
4096     }
4097
4098     cdev = statbuf.st_dev;
4099     cino = statbuf.st_ino;
4100
4101     if (cdev != orig_cdev || cino != orig_cino) {
4102         Perl_croak(aTHX_ "Unstable directory path, "
4103                    "current directory changed unexpectedly");
4104     }
4105
4106     return TRUE;
4107 #endif
4108
4109 #else
4110     return FALSE;
4111 #endif
4112 }
4113
4114 #include "vutil.c"
4115
4116 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4117 #   define EMULATE_SOCKETPAIR_UDP
4118 #endif
4119
4120 #ifdef EMULATE_SOCKETPAIR_UDP
4121 static int
4122 S_socketpair_udp (int fd[2]) {
4123     dTHX;
4124     /* Fake a datagram socketpair using UDP to localhost.  */
4125     int sockets[2] = {-1, -1};
4126     struct sockaddr_in addresses[2];
4127     int i;
4128     Sock_size_t size = sizeof(struct sockaddr_in);
4129     unsigned short port;
4130     int got;
4131
4132     memset(&addresses, 0, sizeof(addresses));
4133     i = 1;
4134     do {
4135         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4136         if (sockets[i] == -1)
4137             goto tidy_up_and_fail;
4138
4139         addresses[i].sin_family = AF_INET;
4140         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4141         addresses[i].sin_port = 0;      /* kernel choses port.  */
4142         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4143                 sizeof(struct sockaddr_in)) == -1)
4144             goto tidy_up_and_fail;
4145     } while (i--);
4146
4147     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4148        for each connect the other socket to it.  */
4149     i = 1;
4150     do {
4151         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4152                 &size) == -1)
4153             goto tidy_up_and_fail;
4154         if (size != sizeof(struct sockaddr_in))
4155             goto abort_tidy_up_and_fail;
4156         /* !1 is 0, !0 is 1 */
4157         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4158                 sizeof(struct sockaddr_in)) == -1)
4159             goto tidy_up_and_fail;
4160     } while (i--);
4161
4162     /* Now we have 2 sockets connected to each other. I don't trust some other
4163        process not to have already sent a packet to us (by random) so send
4164        a packet from each to the other.  */
4165     i = 1;
4166     do {
4167         /* I'm going to send my own port number.  As a short.
4168            (Who knows if someone somewhere has sin_port as a bitfield and needs
4169            this routine. (I'm assuming crays have socketpair)) */
4170         port = addresses[i].sin_port;
4171         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4172         if (got != sizeof(port)) {
4173             if (got == -1)
4174                 goto tidy_up_and_fail;
4175             goto abort_tidy_up_and_fail;
4176         }
4177     } while (i--);
4178
4179     /* Packets sent. I don't trust them to have arrived though.
4180        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4181        connect to localhost will use a second kernel thread. In 2.6 the
4182        first thread running the connect() returns before the second completes,
4183        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4184        returns 0. Poor programs have tripped up. One poor program's authors'
4185        had a 50-1 reverse stock split. Not sure how connected these were.)
4186        So I don't trust someone not to have an unpredictable UDP stack.
4187     */
4188
4189     {
4190         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4191         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4192         fd_set rset;
4193
4194         FD_ZERO(&rset);
4195         FD_SET((unsigned int)sockets[0], &rset);
4196         FD_SET((unsigned int)sockets[1], &rset);
4197
4198         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4199         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4200                 || !FD_ISSET(sockets[1], &rset)) {
4201             /* I hope this is portable and appropriate.  */
4202             if (got == -1)
4203                 goto tidy_up_and_fail;
4204             goto abort_tidy_up_and_fail;
4205         }
4206     }
4207
4208     /* And the paranoia department even now doesn't trust it to have arrive
4209        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4210     {
4211         struct sockaddr_in readfrom;
4212         unsigned short buffer[2];
4213
4214         i = 1;
4215         do {
4216 #ifdef MSG_DONTWAIT
4217             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4218                     sizeof(buffer), MSG_DONTWAIT,
4219                     (struct sockaddr *) &readfrom, &size);
4220 #else
4221             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4222                     sizeof(buffer), 0,
4223                     (struct sockaddr *) &readfrom, &size);
4224 #endif
4225
4226             if (got == -1)
4227                 goto tidy_up_and_fail;
4228             if (got != sizeof(port)
4229                     || size != sizeof(struct sockaddr_in)
4230                     /* Check other socket sent us its port.  */
4231                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4232                     /* Check kernel says we got the datagram from that socket */
4233                     || readfrom.sin_family != addresses[!i].sin_family
4234                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4235                     || readfrom.sin_port != addresses[!i].sin_port)
4236                 goto abort_tidy_up_and_fail;
4237         } while (i--);
4238     }
4239     /* My caller (my_socketpair) has validated that this is non-NULL  */
4240     fd[0] = sockets[0];
4241     fd[1] = sockets[1];
4242     /* I hereby declare this connection open.  May God bless all who cross
4243        her.  */
4244     return 0;
4245
4246   abort_tidy_up_and_fail:
4247     errno = ECONNABORTED;
4248   tidy_up_and_fail:
4249     {
4250         dSAVE_ERRNO;
4251         if (sockets[0] != -1)
4252             PerlLIO_close(sockets[0]);
4253         if (sockets[1] != -1)
4254             PerlLIO_close(sockets[1]);
4255         RESTORE_ERRNO;
4256         return -1;
4257     }
4258 }
4259 #endif /*  EMULATE_SOCKETPAIR_UDP */
4260
4261 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4262 int
4263 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4264     /* Stevens says that family must be AF_LOCAL, protocol 0.
4265        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4266     dTHXa(NULL);
4267     int listener = -1;
4268     int connector = -1;
4269     int acceptor = -1;
4270     struct sockaddr_in listen_addr;
4271     struct sockaddr_in connect_addr;
4272     Sock_size_t size;
4273
4274     if (protocol
4275 #ifdef AF_UNIX
4276         || family != AF_UNIX
4277 #endif
4278     ) {
4279         errno = EAFNOSUPPORT;
4280         return -1;
4281     }
4282     if (!fd) {
4283         errno = EINVAL;
4284         return -1;
4285     }
4286
4287 #ifdef SOCK_CLOEXEC
4288     type &= ~SOCK_CLOEXEC;
4289 #endif
4290
4291 #ifdef EMULATE_SOCKETPAIR_UDP
4292     if (type == SOCK_DGRAM)
4293         return S_socketpair_udp(fd);
4294 #endif
4295
4296     aTHXa(PERL_GET_THX);
4297     listener = PerlSock_socket(AF_INET, type, 0);
4298     if (listener == -1)
4299         return -1;
4300     memset(&listen_addr, 0, sizeof(listen_addr));
4301     listen_addr.sin_family = AF_INET;
4302     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4303     listen_addr.sin_port = 0;   /* kernel choses port.  */
4304     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4305             sizeof(listen_addr)) == -1)
4306         goto tidy_up_and_fail;
4307     if (PerlSock_listen(listener, 1) == -1)
4308         goto tidy_up_and_fail;
4309
4310     connector = PerlSock_socket(AF_INET, type, 0);
4311     if (connector == -1)
4312         goto tidy_up_and_fail;
4313     /* We want to find out the port number to connect to.  */
4314     size = sizeof(connect_addr);
4315     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4316             &size) == -1)
4317         goto tidy_up_and_fail;
4318     if (size != sizeof(connect_addr))
4319         goto abort_tidy_up_and_fail;
4320     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4321             sizeof(connect_addr)) == -1)
4322         goto tidy_up_and_fail;
4323
4324     size = sizeof(listen_addr);
4325     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4326             &size);
4327     if (acceptor == -1)
4328         goto tidy_up_and_fail;
4329     if (size != sizeof(listen_addr))
4330         goto abort_tidy_up_and_fail;
4331     PerlLIO_close(listener);
4332     /* Now check we are talking to ourself by matching port and host on the
4333        two sockets.  */
4334     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4335             &size) == -1)
4336         goto tidy_up_and_fail;
4337     if (size != sizeof(connect_addr)
4338             || listen_addr.sin_family != connect_addr.sin_family
4339             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4340             || listen_addr.sin_port != connect_addr.sin_port) {
4341         goto abort_tidy_up_and_fail;
4342     }
4343     fd[0] = connector;
4344     fd[1] = acceptor;
4345     return 0;
4346
4347   abort_tidy_up_and_fail:
4348 #ifdef ECONNABORTED
4349   errno = ECONNABORTED; /* This would be the standard thing to do. */
4350 #elif defined(ECONNREFUSED)
4351   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4352 #else
4353   errno = ETIMEDOUT;    /* Desperation time. */
4354 #endif
4355   tidy_up_and_fail:
4356     {
4357         dSAVE_ERRNO;
4358         if (listener != -1)
4359             PerlLIO_close(listener);
4360         if (connector != -1)
4361             PerlLIO_close(connector);
4362         if (acceptor != -1)
4363             PerlLIO_close(acceptor);
4364         RESTORE_ERRNO;
4365         return -1;
4366     }
4367 }
4368 #else
4369 /* In any case have a stub so that there's code corresponding
4370  * to the my_socketpair in embed.fnc. */
4371 int
4372 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4373 #ifdef HAS_SOCKETPAIR
4374     return socketpair(family, type, protocol, fd);
4375 #else
4376     return -1;
4377 #endif
4378 }
4379 #endif
4380
4381 /*
4382
4383 =for apidoc sv_nosharing
4384
4385 Dummy routine which "shares" an SV when there is no sharing module present.
4386 Or "locks" it.  Or "unlocks" it.  In other
4387 words, ignores its single SV argument.
4388 Exists to avoid test for a C<NULL> function pointer and because it could
4389 potentially warn under some level of strict-ness.
4390
4391 =cut
4392 */
4393
4394 void
4395 Perl_sv_nosharing(pTHX_ SV *sv)
4396 {
4397     PERL_UNUSED_CONTEXT;
4398     PERL_UNUSED_ARG(sv);
4399 }
4400
4401 /*
4402
4403 =for apidoc sv_destroyable
4404
4405 Dummy routine which reports that object can be destroyed when there is no
4406 sharing module present.  It ignores its single SV argument, and returns
4407 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4408 could potentially warn under some level of strict-ness.
4409
4410 =cut
4411 */
4412
4413 bool
4414 Perl_sv_destroyable(pTHX_ SV *sv)
4415 {
4416     PERL_UNUSED_CONTEXT;
4417     PERL_UNUSED_ARG(sv);
4418     return TRUE;
4419 }
4420
4421 U32
4422 Perl_parse_unicode_opts(pTHX_ const char **popt)
4423 {
4424   const char *p = *popt;
4425   U32 opt = 0;
4426
4427   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4428
4429   if (*p) {
4430        if (isDIGIT(*p)) {
4431             const char* endptr = p + strlen(p);
4432             UV uv;
4433             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4434                 opt = (U32)uv;
4435                 p = endptr;
4436                 if (p && *p && *p != '\n' && *p != '\r') {
4437                     if (isSPACE(*p))
4438                         goto the_end_of_the_opts_parser;
4439                     else
4440                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4441                 }
4442             }
4443             else {
4444                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4445             }
4446         }
4447         else {
4448             for (; *p; p++) {
4449                  switch (*p) {
4450                  case PERL_UNICODE_STDIN:
4451                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4452                  case PERL_UNICODE_STDOUT:
4453                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4454                  case PERL_UNICODE_STDERR:
4455                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4456                  case PERL_UNICODE_STD:
4457                       opt |= PERL_UNICODE_STD_FLAG;     break;
4458                  case PERL_UNICODE_IN:
4459                       opt |= PERL_UNICODE_IN_FLAG;      break;
4460                  case PERL_UNICODE_OUT:
4461                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4462                  case PERL_UNICODE_INOUT:
4463                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4464                  case PERL_UNICODE_LOCALE:
4465                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4466                  case PERL_UNICODE_ARGV:
4467                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4468                  case PERL_UNICODE_UTF8CACHEASSERT:
4469                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4470                  default:
4471                       if (*p != '\n' && *p != '\r') {
4472                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4473                         else
4474                           Perl_croak(aTHX_
4475                                      "Unknown Unicode option letter '%c'", *p);
4476                       }
4477                  }
4478             }
4479        }
4480   }
4481   else
4482        opt = PERL_UNICODE_DEFAULT_FLAGS;
4483
4484   the_end_of_the_opts_parser:
4485
4486   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4487        Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4488                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4489
4490   *popt = p;
4491
4492   return opt;
4493 }
4494
4495 #ifdef VMS
4496 #  include <starlet.h>
4497 #endif
4498
4499 U32
4500 Perl_seed(pTHX)
4501 {
4502     /*
4503      * This is really just a quick hack which grabs various garbage
4504      * values.  It really should be a real hash algorithm which
4505      * spreads the effect of every input bit onto every output bit,
4506      * if someone who knows about such things would bother to write it.
4507      * Might be a good idea to add that function to CORE as well.
4508      * No numbers below come from careful analysis or anything here,
4509      * except they are primes and SEED_C1 > 1E6 to get a full-width
4510      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4511      * probably be bigger too.
4512      */
4513 #if RANDBITS > 16
4514 #  define SEED_C1       1000003
4515 #define   SEED_C4       73819
4516 #else
4517 #  define SEED_C1       25747
4518 #define   SEED_C4       20639
4519 #endif
4520 #define   SEED_C2       3
4521 #define   SEED_C3       269
4522 #define   SEED_C5       26107
4523
4524 #ifndef PERL_NO_DEV_RANDOM
4525     int fd;
4526 #endif
4527     U32 u;
4528 #ifdef HAS_GETTIMEOFDAY
4529     struct timeval when;
4530 #else
4531     Time_t when;
4532 #endif
4533
4534 /* This test is an escape hatch, this symbol isn't set by Configure. */
4535 #ifndef PERL_NO_DEV_RANDOM
4536 #ifndef PERL_RANDOM_DEVICE
4537    /* /dev/random isn't used by default because reads from it will block
4538     * if there isn't enough entropy available.  You can compile with
4539     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4540     * is enough real entropy to fill the seed. */
4541 #  ifdef __amigaos4__
4542 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4543 #  else
4544 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4545 #  endif
4546 #endif
4547     fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
4548     if (fd != -1) {
4549         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4550             u = 0;
4551         PerlLIO_close(fd);
4552         if (u)
4553             return u;
4554     }
4555 #endif
4556
4557 #ifdef HAS_GETTIMEOFDAY
4558     PerlProc_gettimeofday(&when,NULL);
4559     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4560 #else
4561     (void)time(&when);
4562     u = (U32)SEED_C1 * when;
4563 #endif
4564     u += SEED_C3 * (U32)PerlProc_getpid();
4565     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4566 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4567     u += SEED_C5 * (U32)PTR2UV(&when);
4568 #endif
4569     return u;
4570 }
4571
4572 void
4573 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4574 {
4575 #ifndef NO_PERL_HASH_ENV
4576     const char *env_pv;
4577 #endif
4578     unsigned long i;
4579
4580     PERL_ARGS_ASSERT_GET_HASH_SEED;
4581
4582 #ifndef NO_PERL_HASH_ENV
4583     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4584
4585     if ( env_pv )
4586     {
4587         /* ignore leading spaces */
4588         while (isSPACE(*env_pv))
4589             env_pv++;
4590 #    ifdef USE_PERL_PERTURB_KEYS
4591         /* if they set it to "0" we disable key traversal randomization completely */
4592         if (strEQ(env_pv,"0")) {
4593             PL_hash_rand_bits_enabled= 0;
4594         } else {
4595             /* otherwise switch to deterministic mode */
4596             PL_hash_rand_bits_enabled= 2;
4597         }
4598 #    endif
4599         /* ignore a leading 0x... if it is there */
4600         if (env_pv[0] == '0' && env_pv[1] == 'x')
4601             env_pv += 2;
4602
4603         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4604             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4605             if ( isXDIGIT(*env_pv)) {
4606                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4607             }
4608         }
4609         while (isSPACE(*env_pv))
4610             env_pv++;
4611
4612         if (*env_pv && !isXDIGIT(*env_pv)) {
4613             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4614         }
4615         /* should we check for unparsed crap? */
4616         /* should we warn about unused hex? */
4617         /* should we warn about insufficient hex? */
4618     }
4619     else
4620 #endif /* NO_PERL_HASH_ENV */
4621     {
4622         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4623             seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
4624         }
4625     }
4626 #ifdef USE_PERL_PERTURB_KEYS
4627     {   /* initialize PL_hash_rand_bits from the hash seed.
4628          * This value is highly volatile, it is updated every
4629          * hash insert, and is used as part of hash bucket chain
4630          * randomization and hash iterator randomization. */
4631         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4632         for( i = 0; i < sizeof(UV) ; i++ ) {
4633             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4634             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4635         }
4636     }
4637 #  ifndef NO_PERL_HASH_ENV
4638     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4639     if (env_pv) {
4640         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4641             PL_hash_rand_bits_enabled= 0;
4642         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4643             PL_hash_rand_bits_enabled= 1;
4644         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4645             PL_hash_rand_bits_enabled= 2;
4646         } else {
4647             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4648         }
4649     }
4650 #  endif
4651 #endif
4652 }
4653
4654 #ifdef PERL_GLOBAL_STRUCT
4655
4656 #define PERL_GLOBAL_STRUCT_INIT
4657 #include "opcode.h" /* the ppaddr and check */
4658
4659 struct perl_vars *
4660 Perl_init_global_struct(pTHX)
4661 {
4662     struct perl_vars *plvarsp = NULL;
4663 # ifdef PERL_GLOBAL_STRUCT
4664     const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4665     const IV ncheck  = C_ARRAY_LENGTH(Gcheck);
4666     PERL_UNUSED_CONTEXT;
4667 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4668     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4669     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4670     if (!plvarsp)
4671         exit(1);
4672 #  else
4673     plvarsp = PL_VarsPtr;
4674 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4675 #  undef PERLVAR
4676 #  undef PERLVARA
4677 #  undef PERLVARI
4678 #  undef PERLVARIC
4679 #  define PERLVAR(prefix,var,type) /**/
4680 #  define PERLVARA(prefix,var,n,type) /**/
4681 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4682 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4683 #  include "perlvars.h"
4684 #  undef PERLVAR
4685 #  undef PERLVARA
4686 #  undef PERLVARI
4687 #  undef PERLVARIC
4688 #  ifdef PERL_GLOBAL_STRUCT
4689     plvarsp->Gppaddr =
4690         (Perl_ppaddr_t*)
4691         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4692     if (!plvarsp->Gppaddr)
4693         exit(1);
4694     plvarsp->Gcheck  =
4695         (Perl_check_t*)
4696         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4697     if (!plvarsp->Gcheck)
4698         exit(1);
4699     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
4700     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t); 
4701 #  endif
4702 #  ifdef PERL_SET_VARS
4703     PERL_SET_VARS(plvarsp);
4704 #  endif
4705 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4706     plvarsp->Gsv_placeholder.sv_flags = 0;
4707     memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4708 #  endif
4709 # undef PERL_GLOBAL_STRUCT_INIT
4710 # endif
4711     return plvarsp;
4712 }
4713
4714 #endif /* PERL_GLOBAL_STRUCT */
4715
4716 #ifdef PERL_GLOBAL_STRUCT
4717
4718 void
4719 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4720 {
4721     int veto = plvarsp->Gveto_cleanup;
4722
4723     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4724     PERL_UNUSED_CONTEXT;
4725 # ifdef PERL_GLOBAL_STRUCT
4726 #  ifdef PERL_UNSET_VARS
4727     PERL_UNSET_VARS(plvarsp);
4728 #  endif
4729     if (veto)
4730         return;
4731     free(plvarsp->Gppaddr);
4732     free(plvarsp->Gcheck);
4733 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4734     free(plvarsp);
4735 #  endif
4736 # endif
4737 }
4738
4739 #endif /* PERL_GLOBAL_STRUCT */
4740
4741 #ifdef PERL_MEM_LOG
4742
4743 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4744  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4745  * given, and you supply your own implementation.
4746  *
4747  * The default implementation reads a single env var, PERL_MEM_LOG,
4748  * expecting one or more of the following:
4749  *
4750  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4751  *    'm' - memlog      was PERL_MEM_LOG=1
4752  *    's' - svlog       was PERL_SV_LOG=1
4753  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4754  *
4755  * This makes the logger controllable enough that it can reasonably be
4756  * added to the system perl.
4757  */
4758
4759 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4760  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4761  */
4762 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4763
4764 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4765  * writes to.  In the default logger, this is settable at runtime.
4766  */
4767 #ifndef PERL_MEM_LOG_FD
4768 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4769 #endif
4770
4771 #ifndef PERL_MEM_LOG_NOIMPL
4772
4773 # ifdef DEBUG_LEAKING_SCALARS
4774 #   define SV_LOG_SERIAL_FMT        " [%lu]"
4775 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
4776 # else
4777 #   define SV_LOG_SERIAL_FMT
4778 #   define _SV_LOG_SERIAL_ARG(sv)
4779 # endif
4780
4781 static void
4782 S_mem_log_common(enum mem_log_type mlt, const UV n, 
4783                  const UV typesize, const char *type_name, const SV *sv,
4784                  Malloc_t oldalloc, Malloc_t newalloc,
4785                  const char *filename, const int linenumber,
4786                  const char *funcname)
4787 {
4788     const char *pmlenv;
4789
4790     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4791
4792     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4793     if (!pmlenv)
4794         return;
4795     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4796     {
4797         /* We can't use SVs or PerlIO for obvious reasons,
4798          * so we'll use stdio and low-level IO instead. */
4799         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4800
4801 #   ifdef HAS_GETTIMEOFDAY
4802 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
4803 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
4804         struct timeval tv;
4805         gettimeofday(&tv, 0);
4806 #   else
4807 #     define MEM_LOG_TIME_FMT   "%10d: "
4808 #     define MEM_LOG_TIME_ARG   (int)when
4809         Time_t when;
4810         (void)time(&when);
4811 #   endif
4812         /* If there are other OS specific ways of hires time than
4813          * gettimeofday() (see dist/Time-HiRes), the easiest way is
4814          * probably that they would be used to fill in the struct
4815          * timeval. */
4816         {
4817             STRLEN len;
4818             const char* endptr = pmlenv + strlen(pmlenv);
4819             int fd;
4820             UV uv;
4821             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4822                 && uv && uv <= PERL_INT_MAX
4823             ) {
4824                 fd = (int)uv;
4825             } else {
4826                 fd = PERL_MEM_LOG_FD;
4827             }
4828
4829             if (strchr(pmlenv, 't')) {
4830                 len = my_snprintf(buf, sizeof(buf),
4831                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4832                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4833             }
4834             switch (mlt) {
4835             case MLT_ALLOC:
4836                 len = my_snprintf(buf, sizeof(buf),
4837                         "alloc: %s:%d:%s: %" IVdf " %" UVuf
4838                         " %s = %" IVdf ": %" UVxf "\n",
4839                         filename, linenumber, funcname, n, typesize,
4840                         type_name, n * typesize, PTR2UV(newalloc));
4841                 break;
4842             case MLT_REALLOC:
4843                 len = my_snprintf(buf, sizeof(buf),
4844                         "realloc: %s:%d:%s: %" IVdf " %" UVuf
4845                         " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
4846                         filename, linenumber, funcname, n, typesize,
4847                         type_name, n * typesize, PTR2UV(oldalloc),
4848                         PTR2UV(newalloc));
4849                 break;
4850             case MLT_FREE:
4851                 len = my_snprintf(buf, sizeof(buf),
4852                         "free: %s:%d:%s: %" UVxf "\n",
4853                         filename, linenumber, funcname,
4854                         PTR2UV(oldalloc));
4855                 break;
4856             case MLT_NEW_SV:
4857             case MLT_DEL_SV:
4858                 len = my_snprintf(buf, sizeof(buf),
4859                         "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
4860                         mlt == MLT_NEW_SV ? "new" : "del",
4861                         filename, linenumber, funcname,
4862                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4863                 break;
4864             default:
4865                 len = 0;
4866             }
4867             PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4868         }
4869     }
4870 }
4871 #endif /* !PERL_MEM_LOG_NOIMPL */
4872
4873 #ifndef PERL_MEM_LOG_NOIMPL
4874 # define \
4875     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
4876     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
4877 #else
4878 /* this is suboptimal, but bug compatible.  User is providing their
4879    own implementation, but is getting these functions anyway, and they
4880    do nothing. But _NOIMPL users should be able to cope or fix */
4881 # define \
4882     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
4883     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
4884 #endif
4885
4886 Malloc_t
4887 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
4888                    Malloc_t newalloc, 
4889                    const char *filename, const int linenumber,
4890                    const char *funcname)
4891 {
4892     PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
4893
4894     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
4895                       NULL, NULL, newalloc,
4896                       filename, linenumber, funcname);
4897     return newalloc;
4898 }
4899
4900 Malloc_t
4901 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
4902                      Malloc_t oldalloc, Malloc_t newalloc, 
4903                      const char *filename, const int linenumber, 
4904                      const char *funcname)
4905 {
4906     PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
4907
4908     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
4909                       NULL, oldalloc, newalloc, 
4910                       filename, linenumber, funcname);
4911     return newalloc;
4912 }
4913
4914 Malloc_t
4915 Perl_mem_log_free(Malloc_t oldalloc, 
4916                   const char *filename, const int linenumber, 
4917                   const char *funcname)
4918 {
4919     PERL_ARGS_ASSERT_MEM_LOG_FREE;
4920
4921     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
4922                       filename, linenumber, funcname);
4923     return oldalloc;
4924 }
4925
4926 void
4927 Perl_mem_log_new_sv(const SV *sv, 
4928                     const char *filename, const int linenumber,
4929                     const char *funcname)
4930 {
4931     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
4932                       filename, linenumber, funcname);
4933 }
4934
4935 void
4936 Perl_mem_log_del_sv(const SV *sv,
4937                     const char *filename, const int linenumber, 
4938                     const char *funcname)
4939 {
4940     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
4941                       filename, linenumber, funcname);
4942 }
4943
4944 #endif /* PERL_MEM_LOG */
4945
4946 /*
4947 =for apidoc quadmath_format_valid
4948
4949 C<quadmath_snprintf()> is very strict about its C<format> string and will
4950 fail, returning -1, if the format is invalid.  It accepts exactly
4951 one format spec.
4952
4953 C<quadmath_format_valid()> checks that the intended single spec looks
4954 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
4955 and has C<Q> before it.  This is not a full "printf syntax check",
4956 just the basics.
4957
4958 Returns true if it is valid, false if not.
4959
4960 See also L</quadmath_format_needed>.
4961
4962 =cut
4963 */
4964 #ifdef USE_QUADMATH
4965 bool
4966 Perl_quadmath_format_valid(const char* format)
4967 {
4968     STRLEN len;
4969
4970     PERL_ARGS_ASSERT_QUADMATH_FORMAT_VALID;
4971
4972     if (format[0] != '%' || strchr(format + 1, '%'))
4973         return FALSE;
4974     len = strlen(format);
4975     /* minimum length three: %Qg */
4976     if (len < 3 || memCHRs("efgaEFGA", format[len - 1]) == NULL)
4977         return FALSE;
4978     if (format[len - 2] != 'Q')
4979         return FALSE;
4980     return TRUE;
4981 }
4982 #endif
4983
4984 /*
4985 =for apidoc quadmath_format_needed
4986
4987 C<quadmath_format_needed()> returns true if the C<format> string seems to
4988 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
4989 or returns false otherwise.
4990
4991 The format specifier detection is not complete printf-syntax detection,
4992 but it should catch most common cases.
4993
4994 If true is returned, those arguments B<should> in theory be processed
4995 with C<quadmath_snprintf()>, but in case there is more than one such
4996 format specifier (see L</quadmath_format_valid>), and if there is
4997 anything else beyond that one (even just a single byte), they
4998 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
4999 accepting only one format spec, and nothing else.
5000 In this case, the code should probably fail.
5001
5002 =cut
5003 */
5004 #ifdef USE_QUADMATH
5005 bool
5006 Perl_quadmath_format_needed(const char* format)
5007 {
5008   const char *p = format;
5009   const char *q;
5010
5011   PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5012
5013   while ((q = strchr(p, '%'))) {
5014     q++;
5015     if (*q == '+') /* plus */
5016       q++;
5017     if (*q == '#') /* alt */
5018       q++;
5019     if (*q == '*') /* width */
5020       q++;
5021     else {
5022       if (isDIGIT(*q)) {
5023         while (isDIGIT(*q)) q++;
5024       }
5025     }
5026     if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5027       q++;
5028       if (*q == '*')
5029         q++;
5030       else
5031         while (isDIGIT(*q)) q++;
5032     }
5033     if (memCHRs("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5034       return TRUE;
5035     p = q + 1;
5036   }
5037   return FALSE;
5038 }
5039 #endif
5040
5041 /*
5042 =for apidoc my_snprintf
5043
5044 The C library C<snprintf> functionality, if available and
5045 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5046 C<vsnprintf> is not available, will unfortunately use the unsafe
5047 C<vsprintf> which can overrun the buffer (there is an overrun check,
5048 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5049 getting C<vsnprintf>.
5050
5051 =cut
5052 */
5053 int
5054 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5055 {
5056     int retval = -1;
5057     va_list ap;
5058     PERL_ARGS_ASSERT_MY_SNPRINTF;
5059 #ifndef HAS_VSNPRINTF
5060     PERL_UNUSED_VAR(len);
5061 #endif
5062     va_start(ap, format);
5063 #ifdef USE_QUADMATH
5064     {
5065         bool quadmath_valid = FALSE;
5066         if (quadmath_format_valid(format)) {
5067             /* If the format looked promising, use it as quadmath. */
5068             retval = quadmath_snprintf(