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