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