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