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