This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
53b410971a0ed8b9a7ba79567439be643fec40c8
[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         if (PL_curcop) {
1522             const COP *cop =
1523                 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1524             if (!cop)
1525                 cop = PL_curcop;
1526
1527             if (CopLINE(cop))
1528                 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1529                                 OutCopFILE(cop), (IV)CopLINE(cop));
1530         }
1531
1532         /* Seems that GvIO() can be untrustworthy during global destruction. */
1533         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1534                 && IoLINES(GvIOp(PL_last_in_gv)))
1535         {
1536             STRLEN l;
1537             const bool line_mode = (RsSIMPLE(PL_rs) &&
1538                                    *SvPV_const(PL_rs,l) == '\n' && l == 1);
1539             Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
1540                            SVfARG(PL_last_in_gv == PL_argvgv
1541                                  ? &PL_sv_no
1542                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1543                            line_mode ? "line" : "chunk",
1544                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1545         }
1546         if (PL_phase == PERL_PHASE_DESTRUCT)
1547             sv_catpvs(sv, " during global destruction");
1548         sv_catpvs(sv, ".\n");
1549     }
1550     return sv;
1551 }
1552
1553 /*
1554 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1555
1556 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1557 argument list, respectively.  These are used to generate a string message.  If
1558 the
1559 message does not end with a newline, then it will be extended with
1560 some indication of the current location in the code, as described for
1561 L</mess_sv>.
1562
1563 Normally, the resulting message is returned in a new mortal SV.
1564 During global destruction a single SV may be shared between uses of
1565 this function.
1566
1567 =cut
1568 */
1569
1570 SV *
1571 Perl_vmess(pTHX_ const char *pat, va_list *args)
1572 {
1573     SV * const sv = mess_alloc();
1574
1575     PERL_ARGS_ASSERT_VMESS;
1576
1577     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1578     return mess_sv(sv, 1);
1579 }
1580
1581 void
1582 Perl_write_to_stderr(pTHX_ SV* msv)
1583 {
1584     IO *io;
1585     MAGIC *mg;
1586
1587     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1588
1589     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
1590         && (io = GvIO(PL_stderrgv))
1591         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
1592         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1593                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1594     else {
1595         PerlIO * const serr = Perl_error_log;
1596
1597         do_print(msv, serr);
1598         (void)PerlIO_flush(serr);
1599     }
1600 }
1601
1602 /*
1603 =head1 Warning and Dieing
1604 */
1605
1606 /* Common code used in dieing and warning */
1607
1608 STATIC SV *
1609 S_with_queued_errors(pTHX_ SV *ex)
1610 {
1611     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1612     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1613         sv_catsv(PL_errors, ex);
1614         ex = sv_mortalcopy(PL_errors);
1615         SvCUR_set(PL_errors, 0);
1616     }
1617     return ex;
1618 }
1619
1620 STATIC bool
1621 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1622 {
1623     HV *stash;
1624     GV *gv;
1625     CV *cv;
1626     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1627     /* sv_2cv might call Perl_croak() or Perl_warner() */
1628     SV * const oldhook = *hook;
1629
1630     if (!oldhook)
1631         return FALSE;
1632
1633     ENTER;
1634     SAVESPTR(*hook);
1635     *hook = NULL;
1636     cv = sv_2cv(oldhook, &stash, &gv, 0);
1637     LEAVE;
1638     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1639         dSP;
1640         SV *exarg;
1641
1642         ENTER;
1643         save_re_context();
1644         if (warn) {
1645             SAVESPTR(*hook);
1646             *hook = NULL;
1647         }
1648         exarg = newSVsv(ex);
1649         SvREADONLY_on(exarg);
1650         SAVEFREESV(exarg);
1651
1652         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1653         PUSHMARK(SP);
1654         XPUSHs(exarg);
1655         PUTBACK;
1656         call_sv(MUTABLE_SV(cv), G_DISCARD);
1657         POPSTACK;
1658         LEAVE;
1659         return TRUE;
1660     }
1661     return FALSE;
1662 }
1663
1664 /*
1665 =for apidoc Am|OP *|die_sv|SV *baseex
1666
1667 Behaves the same as L</croak_sv>, except for the return type.
1668 It should be used only where the C<OP *> return type is required.
1669 The function never actually returns.
1670
1671 =cut
1672 */
1673
1674 #ifdef _MSC_VER
1675 #  pragma warning( push )
1676 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1677     __declspec(noreturn) has non-void return type */
1678 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1679 __declspec(noreturn) has a return statement */
1680 #endif
1681 OP *
1682 Perl_die_sv(pTHX_ SV *baseex)
1683 {
1684     PERL_ARGS_ASSERT_DIE_SV;
1685     croak_sv(baseex);
1686     /* NOTREACHED */
1687     NORETURN_FUNCTION_END;
1688 }
1689 #ifdef _MSC_VER
1690 #  pragma warning( pop )
1691 #endif
1692
1693 /*
1694 =for apidoc Am|OP *|die|const char *pat|...
1695
1696 Behaves the same as L</croak>, except for the return type.
1697 It should be used only where the C<OP *> return type is required.
1698 The function never actually returns.
1699
1700 =cut
1701 */
1702
1703 #if defined(PERL_IMPLICIT_CONTEXT)
1704 #ifdef _MSC_VER
1705 #  pragma warning( push )
1706 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1707     __declspec(noreturn) has non-void return type */
1708 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1709 __declspec(noreturn) has a return statement */
1710 #endif
1711 OP *
1712 Perl_die_nocontext(const char* pat, ...)
1713 {
1714     dTHX;
1715     va_list args;
1716     va_start(args, pat);
1717     vcroak(pat, &args);
1718     NOT_REACHED; /* NOTREACHED */
1719     va_end(args);
1720     NORETURN_FUNCTION_END;
1721 }
1722 #ifdef _MSC_VER
1723 #  pragma warning( pop )
1724 #endif
1725 #endif /* PERL_IMPLICIT_CONTEXT */
1726
1727 #ifdef _MSC_VER
1728 #  pragma warning( push )
1729 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1730     __declspec(noreturn) has non-void return type */
1731 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1732 __declspec(noreturn) has a return statement */
1733 #endif
1734 OP *
1735 Perl_die(pTHX_ const char* pat, ...)
1736 {
1737     va_list args;
1738     va_start(args, pat);
1739     vcroak(pat, &args);
1740     NOT_REACHED; /* NOTREACHED */
1741     va_end(args);
1742     NORETURN_FUNCTION_END;
1743 }
1744 #ifdef _MSC_VER
1745 #  pragma warning( pop )
1746 #endif
1747
1748 /*
1749 =for apidoc Am|void|croak_sv|SV *baseex
1750
1751 This is an XS interface to Perl's C<die> function.
1752
1753 C<baseex> is the error message or object.  If it is a reference, it
1754 will be used as-is.  Otherwise it is used as a string, and if it does
1755 not end with a newline then it will be extended with some indication of
1756 the current location in the code, as described for L</mess_sv>.
1757
1758 The error message or object will be used as an exception, by default
1759 returning control to the nearest enclosing C<eval>, but subject to
1760 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1761 function never returns normally.
1762
1763 To die with a simple string message, the L</croak> function may be
1764 more convenient.
1765
1766 =cut
1767 */
1768
1769 void
1770 Perl_croak_sv(pTHX_ SV *baseex)
1771 {
1772     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1773     PERL_ARGS_ASSERT_CROAK_SV;
1774     invoke_exception_hook(ex, FALSE);
1775     die_unwind(ex);
1776 }
1777
1778 /*
1779 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1780
1781 This is an XS interface to Perl's C<die> function.
1782
1783 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1784 argument list.  These are used to generate a string message.  If the
1785 message does not end with a newline, then it will be extended with
1786 some indication of the current location in the code, as described for
1787 L</mess_sv>.
1788
1789 The error message will be used as an exception, by default
1790 returning control to the nearest enclosing C<eval>, but subject to
1791 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1792 function never returns normally.
1793
1794 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1795 (C<$@>) will be used as an error message or object instead of building an
1796 error message from arguments.  If you want to throw a non-string object,
1797 or build an error message in an SV yourself, it is preferable to use
1798 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1799
1800 =cut
1801 */
1802
1803 void
1804 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1805 {
1806     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1807     invoke_exception_hook(ex, FALSE);
1808     die_unwind(ex);
1809 }
1810
1811 /*
1812 =for apidoc Am|void|croak|const char *pat|...
1813
1814 This is an XS interface to Perl's C<die> function.
1815
1816 Take a sprintf-style format pattern and argument list.  These are used to
1817 generate a string message.  If the message does not end with a newline,
1818 then it will be extended with some indication of the current location
1819 in the code, as described for L</mess_sv>.
1820
1821 The error message will be used as an exception, by default
1822 returning control to the nearest enclosing C<eval>, but subject to
1823 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1824 function never returns normally.
1825
1826 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1827 (C<$@>) will be used as an error message or object instead of building an
1828 error message from arguments.  If you want to throw a non-string object,
1829 or build an error message in an SV yourself, it is preferable to use
1830 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1831
1832 =cut
1833 */
1834
1835 #if defined(PERL_IMPLICIT_CONTEXT)
1836 void
1837 Perl_croak_nocontext(const char *pat, ...)
1838 {
1839     dTHX;
1840     va_list args;
1841     va_start(args, pat);
1842     vcroak(pat, &args);
1843     NOT_REACHED; /* NOTREACHED */
1844     va_end(args);
1845 }
1846 #endif /* PERL_IMPLICIT_CONTEXT */
1847
1848 void
1849 Perl_croak(pTHX_ const char *pat, ...)
1850 {
1851     va_list args;
1852     va_start(args, pat);
1853     vcroak(pat, &args);
1854     NOT_REACHED; /* NOTREACHED */
1855     va_end(args);
1856 }
1857
1858 /*
1859 =for apidoc Am|void|croak_no_modify
1860
1861 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1862 terser object code than using C<Perl_croak>.  Less code used on exception code
1863 paths reduces CPU cache pressure.
1864
1865 =cut
1866 */
1867
1868 void
1869 Perl_croak_no_modify(void)
1870 {
1871     Perl_croak_nocontext( "%s", PL_no_modify);
1872 }
1873
1874 /* does not return, used in util.c perlio.c and win32.c
1875    This is typically called when malloc returns NULL.
1876 */
1877 void
1878 Perl_croak_no_mem(void)
1879 {
1880     dTHX;
1881
1882     int fd = PerlIO_fileno(Perl_error_log);
1883     if (fd < 0)
1884         SETERRNO(EBADF,RMS_IFI);
1885     else {
1886         /* Can't use PerlIO to write as it allocates memory */
1887         PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
1888     }
1889     my_exit(1);
1890 }
1891
1892 /* does not return, used only in POPSTACK */
1893 void
1894 Perl_croak_popstack(void)
1895 {
1896     dTHX;
1897     PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1898     my_exit(1);
1899 }
1900
1901 /*
1902 =for apidoc Am|void|warn_sv|SV *baseex
1903
1904 This is an XS interface to Perl's C<warn> function.
1905
1906 C<baseex> is the error message or object.  If it is a reference, it
1907 will be used as-is.  Otherwise it is used as a string, and if it does
1908 not end with a newline then it will be extended with some indication of
1909 the current location in the code, as described for L</mess_sv>.
1910
1911 The error message or object will by default be written to standard error,
1912 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1913
1914 To warn with a simple string message, the L</warn> function may be
1915 more convenient.
1916
1917 =cut
1918 */
1919
1920 void
1921 Perl_warn_sv(pTHX_ SV *baseex)
1922 {
1923     SV *ex = mess_sv(baseex, 0);
1924     PERL_ARGS_ASSERT_WARN_SV;
1925     if (!invoke_exception_hook(ex, TRUE))
1926         write_to_stderr(ex);
1927 }
1928
1929 /*
1930 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1931
1932 This is an XS interface to Perl's C<warn> function.
1933
1934 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1935 argument list.  These are used to generate a string message.  If the
1936 message does not end with a newline, then it will be extended with
1937 some indication of the current location in the code, as described for
1938 L</mess_sv>.
1939
1940 The error message or object will by default be written to standard error,
1941 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1942
1943 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1944
1945 =cut
1946 */
1947
1948 void
1949 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1950 {
1951     SV *ex = vmess(pat, args);
1952     PERL_ARGS_ASSERT_VWARN;
1953     if (!invoke_exception_hook(ex, TRUE))
1954         write_to_stderr(ex);
1955 }
1956
1957 /*
1958 =for apidoc Am|void|warn|const char *pat|...
1959
1960 This is an XS interface to Perl's C<warn> function.
1961
1962 Take a sprintf-style format pattern and argument list.  These are used to
1963 generate a string message.  If the message does not end with a newline,
1964 then it will be extended with some indication of the current location
1965 in the code, as described for L</mess_sv>.
1966
1967 The error message or object will by default be written to standard error,
1968 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1969
1970 Unlike with L</croak>, C<pat> is not permitted to be null.
1971
1972 =cut
1973 */
1974
1975 #if defined(PERL_IMPLICIT_CONTEXT)
1976 void
1977 Perl_warn_nocontext(const char *pat, ...)
1978 {
1979     dTHX;
1980     va_list args;
1981     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1982     va_start(args, pat);
1983     vwarn(pat, &args);
1984     va_end(args);
1985 }
1986 #endif /* PERL_IMPLICIT_CONTEXT */
1987
1988 void
1989 Perl_warn(pTHX_ const char *pat, ...)
1990 {
1991     va_list args;
1992     PERL_ARGS_ASSERT_WARN;
1993     va_start(args, pat);
1994     vwarn(pat, &args);
1995     va_end(args);
1996 }
1997
1998 #if defined(PERL_IMPLICIT_CONTEXT)
1999 void
2000 Perl_warner_nocontext(U32 err, const char *pat, ...)
2001 {
2002     dTHX; 
2003     va_list args;
2004     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
2005     va_start(args, pat);
2006     vwarner(err, pat, &args);
2007     va_end(args);
2008 }
2009 #endif /* PERL_IMPLICIT_CONTEXT */
2010
2011 void
2012 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2013 {
2014     PERL_ARGS_ASSERT_CK_WARNER_D;
2015
2016     if (Perl_ckwarn_d(aTHX_ err)) {
2017         va_list args;
2018         va_start(args, pat);
2019         vwarner(err, pat, &args);
2020         va_end(args);
2021     }
2022 }
2023
2024 void
2025 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2026 {
2027     PERL_ARGS_ASSERT_CK_WARNER;
2028
2029     if (Perl_ckwarn(aTHX_ err)) {
2030         va_list args;
2031         va_start(args, pat);
2032         vwarner(err, pat, &args);
2033         va_end(args);
2034     }
2035 }
2036
2037 void
2038 Perl_warner(pTHX_ U32  err, const char* pat,...)
2039 {
2040     va_list args;
2041     PERL_ARGS_ASSERT_WARNER;
2042     va_start(args, pat);
2043     vwarner(err, pat, &args);
2044     va_end(args);
2045 }
2046
2047 void
2048 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
2049 {
2050     dVAR;
2051     PERL_ARGS_ASSERT_VWARNER;
2052     if (
2053         (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2054         !(PL_in_eval & EVAL_KEEPERR)
2055     ) {
2056         SV * const msv = vmess(pat, args);
2057
2058         if (PL_parser && PL_parser->error_count) {
2059             qerror(msv);
2060         }
2061         else {
2062             invoke_exception_hook(msv, FALSE);
2063             die_unwind(msv);
2064         }
2065     }
2066     else {
2067         Perl_vwarn(aTHX_ pat, args);
2068     }
2069 }
2070
2071 /* implements the ckWARN? macros */
2072
2073 bool
2074 Perl_ckwarn(pTHX_ U32 w)
2075 {
2076     /* If lexical warnings have not been set, use $^W.  */
2077     if (isLEXWARN_off)
2078         return PL_dowarn & G_WARN_ON;
2079
2080     return ckwarn_common(w);
2081 }
2082
2083 /* implements the ckWARN?_d macro */
2084
2085 bool
2086 Perl_ckwarn_d(pTHX_ U32 w)
2087 {
2088     /* If lexical warnings have not been set then default classes warn.  */
2089     if (isLEXWARN_off)
2090         return TRUE;
2091
2092     return ckwarn_common(w);
2093 }
2094
2095 static bool
2096 S_ckwarn_common(pTHX_ U32 w)
2097 {
2098     if (PL_curcop->cop_warnings == pWARN_ALL)
2099         return TRUE;
2100
2101     if (PL_curcop->cop_warnings == pWARN_NONE)
2102         return FALSE;
2103
2104     /* Check the assumption that at least the first slot is non-zero.  */
2105     assert(unpackWARN1(w));
2106
2107     /* Check the assumption that it is valid to stop as soon as a zero slot is
2108        seen.  */
2109     if (!unpackWARN2(w)) {
2110         assert(!unpackWARN3(w));
2111         assert(!unpackWARN4(w));
2112     } else if (!unpackWARN3(w)) {
2113         assert(!unpackWARN4(w));
2114     }
2115         
2116     /* Right, dealt with all the special cases, which are implemented as non-
2117        pointers, so there is a pointer to a real warnings mask.  */
2118     do {
2119         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2120             return TRUE;
2121     } while (w >>= WARNshift);
2122
2123     return FALSE;
2124 }
2125
2126 /* Set buffer=NULL to get a new one.  */
2127 STRLEN *
2128 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2129                            STRLEN size) {
2130     const MEM_SIZE len_wanted =
2131         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2132     PERL_UNUSED_CONTEXT;
2133     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2134
2135     buffer = (STRLEN*)
2136         (specialWARN(buffer) ?
2137          PerlMemShared_malloc(len_wanted) :
2138          PerlMemShared_realloc(buffer, len_wanted));
2139     buffer[0] = size;
2140     Copy(bits, (buffer + 1), size, char);
2141     if (size < WARNsize)
2142         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2143     return buffer;
2144 }
2145
2146 /* since we've already done strlen() for both nam and val
2147  * we can use that info to make things faster than
2148  * sprintf(s, "%s=%s", nam, val)
2149  */
2150 #define my_setenv_format(s, nam, nlen, val, vlen) \
2151    Copy(nam, s, nlen, char); \
2152    *(s+nlen) = '='; \
2153    Copy(val, s+(nlen+1), vlen, char); \
2154    *(s+(nlen+1+vlen)) = '\0'
2155
2156 #ifdef USE_ENVIRON_ARRAY
2157        /* VMS' my_setenv() is in vms.c */
2158 #if !defined(WIN32) && !defined(NETWARE)
2159 void
2160 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2161 {
2162   dVAR;
2163 #ifdef __amigaos4__
2164   amigaos4_obtain_environ(__FUNCTION__);
2165 #endif
2166 #ifdef USE_ITHREADS
2167   /* only parent thread can modify process environment */
2168   if (PL_curinterp == aTHX)
2169 #endif
2170   {
2171 #ifndef PERL_USE_SAFE_PUTENV
2172     if (!PL_use_safe_putenv) {
2173         /* most putenv()s leak, so we manipulate environ directly */
2174         I32 i;
2175         const I32 len = strlen(nam);
2176         int nlen, vlen;
2177
2178         /* where does it go? */
2179         for (i = 0; environ[i]; i++) {
2180             if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2181                 break;
2182         }
2183
2184         if (environ == PL_origenviron) {   /* need we copy environment? */
2185             I32 j;
2186             I32 max;
2187             char **tmpenv;
2188
2189             max = i;
2190             while (environ[max])
2191                 max++;
2192             tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2193             for (j=0; j<max; j++) {         /* copy environment */
2194                 const int len = strlen(environ[j]);
2195                 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2196                 Copy(environ[j], tmpenv[j], len+1, char);
2197             }
2198             tmpenv[max] = NULL;
2199             environ = tmpenv;               /* tell exec where it is now */
2200         }
2201         if (!val) {
2202             safesysfree(environ[i]);
2203             while (environ[i]) {
2204                 environ[i] = environ[i+1];
2205                 i++;
2206             }
2207 #ifdef __amigaos4__
2208             goto my_setenv_out;
2209 #else
2210             return;
2211 #endif
2212         }
2213         if (!environ[i]) {                 /* does not exist yet */
2214             environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2215             environ[i+1] = NULL;    /* make sure it's null terminated */
2216         }
2217         else
2218             safesysfree(environ[i]);
2219         nlen = strlen(nam);
2220         vlen = strlen(val);
2221
2222         environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2223         /* all that work just for this */
2224         my_setenv_format(environ[i], nam, nlen, val, vlen);
2225     } else {
2226 # endif
2227     /* This next branch should only be called #if defined(HAS_SETENV), but
2228        Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
2229        were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2230     */
2231 #   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2232 #       if defined(HAS_UNSETENV)
2233         if (val == NULL) {
2234             (void)unsetenv(nam);
2235         } else {
2236             (void)setenv(nam, val, 1);
2237         }
2238 #       else /* ! HAS_UNSETENV */
2239         (void)setenv(nam, val, 1);
2240 #       endif /* HAS_UNSETENV */
2241 #   else
2242 #       if defined(HAS_UNSETENV)
2243         if (val == NULL) {
2244             if (environ) /* old glibc can crash with null environ */
2245                 (void)unsetenv(nam);
2246         } else {
2247             const int nlen = strlen(nam);
2248             const int vlen = strlen(val);
2249             char * const new_env =
2250                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2251             my_setenv_format(new_env, nam, nlen, val, vlen);
2252             (void)putenv(new_env);
2253         }
2254 #       else /* ! HAS_UNSETENV */
2255         char *new_env;
2256         const int nlen = strlen(nam);
2257         int vlen;
2258         if (!val) {
2259            val = "";
2260         }
2261         vlen = strlen(val);
2262         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2263         /* all that work just for this */
2264         my_setenv_format(new_env, nam, nlen, val, vlen);
2265         (void)putenv(new_env);
2266 #       endif /* HAS_UNSETENV */
2267 #   endif /* __CYGWIN__ */
2268 #ifndef PERL_USE_SAFE_PUTENV
2269     }
2270 #endif
2271   }
2272 #ifdef __amigaos4__
2273 my_setenv_out:
2274   amigaos4_release_environ(__FUNCTION__);
2275 #endif
2276 }
2277
2278 #else /* WIN32 || NETWARE */
2279
2280 void
2281 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2282 {
2283     dVAR;
2284     char *envstr;
2285     const int nlen = strlen(nam);
2286     int vlen;
2287
2288     if (!val) {
2289        val = "";
2290     }
2291     vlen = strlen(val);
2292     Newx(envstr, nlen+vlen+2, char);
2293     my_setenv_format(envstr, nam, nlen, val, vlen);
2294     (void)PerlEnv_putenv(envstr);
2295     Safefree(envstr);
2296 }
2297
2298 #endif /* WIN32 || NETWARE */
2299
2300 #endif /* !VMS */
2301
2302 #ifdef UNLINK_ALL_VERSIONS
2303 I32
2304 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2305 {
2306     I32 retries = 0;
2307
2308     PERL_ARGS_ASSERT_UNLNK;
2309
2310     while (PerlLIO_unlink(f) >= 0)
2311         retries++;
2312     return retries ? 0 : -1;
2313 }
2314 #endif
2315
2316 /* this is a drop-in replacement for bcopy(), except for the return
2317  * value, which we need to be able to emulate memcpy()  */
2318 #if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
2319 void *
2320 Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
2321 {
2322 #if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
2323     bcopy(vfrom, vto, len);
2324 #else
2325     const unsigned char *from = (const unsigned char *)vfrom;
2326     unsigned char *to = (unsigned char *)vto;
2327
2328     PERL_ARGS_ASSERT_MY_BCOPY;
2329
2330     if (from - to >= 0) {
2331         while (len--)
2332             *to++ = *from++;
2333     }
2334     else {
2335         to += len;
2336         from += len;
2337         while (len--)
2338             *(--to) = *(--from);
2339     }
2340 #endif
2341
2342     return vto;
2343 }
2344 #endif
2345
2346 /* this is a drop-in replacement for memset() */
2347 #ifndef HAS_MEMSET
2348 void *
2349 Perl_my_memset(void *vloc, int ch, size_t len)
2350 {
2351     unsigned char *loc = (unsigned char *)vloc;
2352
2353     PERL_ARGS_ASSERT_MY_MEMSET;
2354
2355     while (len--)
2356         *loc++ = ch;
2357     return vloc;
2358 }
2359 #endif
2360
2361 /* this is a drop-in replacement for bzero() */
2362 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2363 void *
2364 Perl_my_bzero(void *vloc, size_t len)
2365 {
2366     unsigned char *loc = (unsigned char *)vloc;
2367
2368     PERL_ARGS_ASSERT_MY_BZERO;
2369
2370     while (len--)
2371         *loc++ = 0;
2372     return vloc;
2373 }
2374 #endif
2375
2376 /* this is a drop-in replacement for memcmp() */
2377 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2378 int
2379 Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
2380 {
2381     const U8 *a = (const U8 *)vs1;
2382     const U8 *b = (const U8 *)vs2;
2383     int tmp;
2384
2385     PERL_ARGS_ASSERT_MY_MEMCMP;
2386
2387     while (len--) {
2388         if ((tmp = *a++ - *b++))
2389             return tmp;
2390     }
2391     return 0;
2392 }
2393 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2394
2395 #ifndef HAS_VPRINTF
2396 /* This vsprintf replacement should generally never get used, since
2397    vsprintf was available in both System V and BSD 2.11.  (There may
2398    be some cross-compilation or embedded set-ups where it is needed,
2399    however.)
2400
2401    If you encounter a problem in this function, it's probably a symptom
2402    that Configure failed to detect your system's vprintf() function.
2403    See the section on "item vsprintf" in the INSTALL file.
2404
2405    This version may compile on systems with BSD-ish <stdio.h>,
2406    but probably won't on others.
2407 */
2408
2409 #ifdef USE_CHAR_VSPRINTF
2410 char *
2411 #else
2412 int
2413 #endif
2414 vsprintf(char *dest, const char *pat, void *args)
2415 {
2416     FILE fakebuf;
2417
2418 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2419     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2420     FILE_cnt(&fakebuf) = 32767;
2421 #else
2422     /* These probably won't compile -- If you really need
2423        this, you'll have to figure out some other method. */
2424     fakebuf._ptr = dest;
2425     fakebuf._cnt = 32767;
2426 #endif
2427 #ifndef _IOSTRG
2428 #define _IOSTRG 0
2429 #endif
2430     fakebuf._flag = _IOWRT|_IOSTRG;
2431     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2432 #if defined(STDIO_PTR_LVALUE)
2433     *(FILE_ptr(&fakebuf)++) = '\0';
2434 #else
2435     /* PerlIO has probably #defined away fputc, but we want it here. */
2436 #  ifdef fputc
2437 #    undef fputc  /* XXX Should really restore it later */
2438 #  endif
2439     (void)fputc('\0', &fakebuf);
2440 #endif
2441 #ifdef USE_CHAR_VSPRINTF
2442     return(dest);
2443 #else
2444     return 0;           /* perl doesn't use return value */
2445 #endif
2446 }
2447
2448 #endif /* HAS_VPRINTF */
2449
2450 PerlIO *
2451 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2452 {
2453 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2454     int p[2];
2455     I32 This, that;
2456     Pid_t pid;
2457     SV *sv;
2458     I32 did_pipes = 0;
2459     int pp[2];
2460
2461     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2462
2463     PERL_FLUSHALL_FOR_CHILD;
2464     This = (*mode == 'w');
2465     that = !This;
2466     if (TAINTING_get) {
2467         taint_env();
2468         taint_proper("Insecure %s%s", "EXEC");
2469     }
2470     if (PerlProc_pipe(p) < 0)
2471         return NULL;
2472     /* Try for another pipe pair for error return */
2473     if (PerlProc_pipe(pp) >= 0)
2474         did_pipes = 1;
2475     while ((pid = PerlProc_fork()) < 0) {
2476         if (errno != EAGAIN) {
2477             PerlLIO_close(p[This]);
2478             PerlLIO_close(p[that]);
2479             if (did_pipes) {
2480                 PerlLIO_close(pp[0]);
2481                 PerlLIO_close(pp[1]);
2482             }
2483             return NULL;
2484         }
2485         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2486         sleep(5);
2487     }
2488     if (pid == 0) {
2489         /* Child */
2490 #undef THIS
2491 #undef THAT
2492 #define THIS that
2493 #define THAT This
2494         /* Close parent's end of error status pipe (if any) */
2495         if (did_pipes) {
2496             PerlLIO_close(pp[0]);
2497 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2498             /* Close error pipe automatically if exec works */
2499             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2500                 return NULL;
2501 #endif
2502         }
2503         /* Now dup our end of _the_ pipe to right position */
2504         if (p[THIS] != (*mode == 'r')) {
2505             PerlLIO_dup2(p[THIS], *mode == 'r');
2506             PerlLIO_close(p[THIS]);
2507             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2508                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2509         }
2510         else
2511             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2512 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2513         /* No automatic close - do it by hand */
2514 #  ifndef NOFILE
2515 #  define NOFILE 20
2516 #  endif
2517         {
2518             int fd;
2519
2520             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2521                 if (fd != pp[1])
2522                     PerlLIO_close(fd);
2523             }
2524         }
2525 #endif
2526         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2527         PerlProc__exit(1);
2528 #undef THIS
2529 #undef THAT
2530     }
2531     /* Parent */
2532     do_execfree();      /* free any memory malloced by child on fork */
2533     if (did_pipes)
2534         PerlLIO_close(pp[1]);
2535     /* Keep the lower of the two fd numbers */
2536     if (p[that] < p[This]) {
2537         PerlLIO_dup2(p[This], p[that]);
2538         PerlLIO_close(p[This]);
2539         p[This] = p[that];
2540     }
2541     else
2542         PerlLIO_close(p[that]);         /* close child's end of pipe */
2543
2544     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2545     SvUPGRADE(sv,SVt_IV);
2546     SvIV_set(sv, pid);
2547     PL_forkprocess = pid;
2548     /* If we managed to get status pipe check for exec fail */
2549     if (did_pipes && pid > 0) {
2550         int errkid;
2551         unsigned n = 0;
2552         SSize_t n1;
2553
2554         while (n < sizeof(int)) {
2555             n1 = PerlLIO_read(pp[0],
2556                               (void*)(((char*)&errkid)+n),
2557                               (sizeof(int)) - n);
2558             if (n1 <= 0)
2559                 break;
2560             n += n1;
2561         }
2562         PerlLIO_close(pp[0]);
2563         did_pipes = 0;
2564         if (n) {                        /* Error */
2565             int pid2, status;
2566             PerlLIO_close(p[This]);
2567             if (n != sizeof(int))
2568                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2569             do {
2570                 pid2 = wait4pid(pid, &status, 0);
2571             } while (pid2 == -1 && errno == EINTR);
2572             errno = errkid;             /* Propagate errno from kid */
2573             return NULL;
2574         }
2575     }
2576     if (did_pipes)
2577          PerlLIO_close(pp[0]);
2578     return PerlIO_fdopen(p[This], mode);
2579 #else
2580 #  if defined(OS2)      /* Same, without fork()ing and all extra overhead... */
2581     return my_syspopen4(aTHX_ NULL, mode, n, args);
2582 #  elif defined(WIN32)
2583     return win32_popenlist(mode, n, args);
2584 #  else
2585     Perl_croak(aTHX_ "List form of piped open not implemented");
2586     return (PerlIO *) NULL;
2587 #  endif
2588 #endif
2589 }
2590
2591     /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2592 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2593 PerlIO *
2594 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2595 {
2596     int p[2];
2597     I32 This, that;
2598     Pid_t pid;
2599     SV *sv;
2600     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2601     I32 did_pipes = 0;
2602     int pp[2];
2603
2604     PERL_ARGS_ASSERT_MY_POPEN;
2605
2606     PERL_FLUSHALL_FOR_CHILD;
2607 #ifdef OS2
2608     if (doexec) {
2609         return my_syspopen(aTHX_ cmd,mode);
2610     }
2611 #endif
2612     This = (*mode == 'w');
2613     that = !This;
2614     if (doexec && TAINTING_get) {
2615         taint_env();
2616         taint_proper("Insecure %s%s", "EXEC");
2617     }
2618     if (PerlProc_pipe(p) < 0)
2619         return NULL;
2620     if (doexec && PerlProc_pipe(pp) >= 0)
2621         did_pipes = 1;
2622     while ((pid = PerlProc_fork()) < 0) {
2623         if (errno != EAGAIN) {
2624             PerlLIO_close(p[This]);
2625             PerlLIO_close(p[that]);
2626             if (did_pipes) {
2627                 PerlLIO_close(pp[0]);
2628                 PerlLIO_close(pp[1]);
2629             }
2630             if (!doexec)
2631                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2632             return NULL;
2633         }
2634         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2635         sleep(5);
2636     }
2637     if (pid == 0) {
2638
2639 #undef THIS
2640 #undef THAT
2641 #define THIS that
2642 #define THAT This
2643         if (did_pipes) {
2644             PerlLIO_close(pp[0]);
2645 #if defined(HAS_FCNTL) && defined(F_SETFD)
2646             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2647                 return NULL;
2648 #endif
2649         }
2650         if (p[THIS] != (*mode == 'r')) {
2651             PerlLIO_dup2(p[THIS], *mode == 'r');
2652             PerlLIO_close(p[THIS]);
2653             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2654                 PerlLIO_close(p[THAT]);
2655         }
2656         else
2657             PerlLIO_close(p[THAT]);
2658 #ifndef OS2
2659         if (doexec) {
2660 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2661 #ifndef NOFILE
2662 #define NOFILE 20
2663 #endif
2664             {
2665                 int fd;
2666
2667                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2668                     if (fd != pp[1])
2669                         PerlLIO_close(fd);
2670             }
2671 #endif
2672             /* may or may not use the shell */
2673             do_exec3(cmd, pp[1], did_pipes);
2674             PerlProc__exit(1);
2675         }
2676 #endif  /* defined OS2 */
2677
2678 #ifdef PERLIO_USING_CRLF
2679    /* Since we circumvent IO layers when we manipulate low-level
2680       filedescriptors directly, need to manually switch to the
2681       default, binary, low-level mode; see PerlIOBuf_open(). */
2682    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2683 #endif 
2684         PL_forkprocess = 0;
2685 #ifdef PERL_USES_PL_PIDSTATUS
2686         hv_clear(PL_pidstatus); /* we have no children */
2687 #endif
2688         return NULL;
2689 #undef THIS
2690 #undef THAT
2691     }
2692     do_execfree();      /* free any memory malloced by child on vfork */
2693     if (did_pipes)
2694         PerlLIO_close(pp[1]);
2695     if (p[that] < p[This]) {
2696         PerlLIO_dup2(p[This], p[that]);
2697         PerlLIO_close(p[This]);
2698         p[This] = p[that];
2699     }
2700     else
2701         PerlLIO_close(p[that]);
2702
2703     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2704     SvUPGRADE(sv,SVt_IV);
2705     SvIV_set(sv, pid);
2706     PL_forkprocess = pid;
2707     if (did_pipes && pid > 0) {
2708         int errkid;
2709         unsigned n = 0;
2710         SSize_t n1;
2711
2712         while (n < sizeof(int)) {
2713             n1 = PerlLIO_read(pp[0],
2714                               (void*)(((char*)&errkid)+n),
2715                               (sizeof(int)) - n);
2716             if (n1 <= 0)
2717                 break;
2718             n += n1;
2719         }
2720         PerlLIO_close(pp[0]);
2721         did_pipes = 0;
2722         if (n) {                        /* Error */
2723             int pid2, status;
2724             PerlLIO_close(p[This]);
2725             if (n != sizeof(int))
2726                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2727             do {
2728                 pid2 = wait4pid(pid, &status, 0);
2729             } while (pid2 == -1 && errno == EINTR);
2730             errno = errkid;             /* Propagate errno from kid */
2731             return NULL;
2732         }
2733     }
2734     if (did_pipes)
2735          PerlLIO_close(pp[0]);
2736     return PerlIO_fdopen(p[This], mode);
2737 }
2738 #else
2739 #if defined(DJGPP)
2740 FILE *djgpp_popen();
2741 PerlIO *
2742 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2743 {
2744     PERL_FLUSHALL_FOR_CHILD;
2745     /* Call system's popen() to get a FILE *, then import it.
2746        used 0 for 2nd parameter to PerlIO_importFILE;
2747        apparently not used
2748     */
2749     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2750 }
2751 #else
2752 #if defined(__LIBCATAMOUNT__)
2753 PerlIO *
2754 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2755 {
2756     return NULL;
2757 }
2758 #endif
2759 #endif
2760
2761 #endif /* !DOSISH */
2762
2763 /* this is called in parent before the fork() */
2764 void
2765 Perl_atfork_lock(void)
2766 #if defined(USE_ITHREADS)
2767 #  ifdef USE_PERLIO
2768   PERL_TSA_ACQUIRE(PL_perlio_mutex)
2769 #  endif
2770 #  ifdef MYMALLOC
2771   PERL_TSA_ACQUIRE(PL_malloc_mutex)
2772 #  endif
2773   PERL_TSA_ACQUIRE(PL_op_mutex)
2774 #endif
2775 {
2776 #if defined(USE_ITHREADS)
2777     dVAR;
2778     /* locks must be held in locking order (if any) */
2779 #  ifdef USE_PERLIO
2780     MUTEX_LOCK(&PL_perlio_mutex);
2781 #  endif
2782 #  ifdef MYMALLOC
2783     MUTEX_LOCK(&PL_malloc_mutex);
2784 #  endif
2785     OP_REFCNT_LOCK;
2786 #endif
2787 }
2788
2789 /* this is called in both parent and child after the fork() */
2790 void
2791 Perl_atfork_unlock(void)
2792 #if defined(USE_ITHREADS)
2793 #  ifdef USE_PERLIO
2794   PERL_TSA_RELEASE(PL_perlio_mutex)
2795 #  endif
2796 #  ifdef MYMALLOC
2797   PERL_TSA_RELEASE(PL_malloc_mutex)
2798 #  endif
2799   PERL_TSA_RELEASE(PL_op_mutex)
2800 #endif
2801 {
2802 #if defined(USE_ITHREADS)
2803     dVAR;
2804     /* locks must be released in same order as in atfork_lock() */
2805 #  ifdef USE_PERLIO
2806     MUTEX_UNLOCK(&PL_perlio_mutex);
2807 #  endif
2808 #  ifdef MYMALLOC
2809     MUTEX_UNLOCK(&PL_malloc_mutex);
2810 #  endif
2811     OP_REFCNT_UNLOCK;
2812 #endif
2813 }
2814
2815 Pid_t
2816 Perl_my_fork(void)
2817 {
2818 #if defined(HAS_FORK)
2819     Pid_t pid;
2820 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2821     atfork_lock();
2822     pid = fork();
2823     atfork_unlock();
2824 #else
2825     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2826      * handlers elsewhere in the code */
2827     pid = fork();
2828 #endif
2829     return pid;
2830 #elif defined(__amigaos4__)
2831     return amigaos_fork();
2832 #else
2833     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2834     Perl_croak_nocontext("fork() not available");
2835     return 0;
2836 #endif /* HAS_FORK */
2837 }
2838
2839 #ifndef HAS_DUP2
2840 int
2841 dup2(int oldfd, int newfd)
2842 {
2843 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2844     if (oldfd == newfd)
2845         return oldfd;
2846     PerlLIO_close(newfd);
2847     return fcntl(oldfd, F_DUPFD, newfd);
2848 #else
2849 #define DUP2_MAX_FDS 256
2850     int fdtmp[DUP2_MAX_FDS];
2851     I32 fdx = 0;
2852     int fd;
2853
2854     if (oldfd == newfd)
2855         return oldfd;
2856     PerlLIO_close(newfd);
2857     /* good enough for low fd's... */
2858     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2859         if (fdx >= DUP2_MAX_FDS) {
2860             PerlLIO_close(fd);
2861             fd = -1;
2862             break;
2863         }
2864         fdtmp[fdx++] = fd;
2865     }
2866     while (fdx > 0)
2867         PerlLIO_close(fdtmp[--fdx]);
2868     return fd;
2869 #endif
2870 }
2871 #endif
2872
2873 #ifndef PERL_MICRO
2874 #ifdef HAS_SIGACTION
2875
2876 Sighandler_t
2877 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2878 {
2879     struct sigaction act, oact;
2880
2881 #ifdef USE_ITHREADS
2882     dVAR;
2883     /* only "parent" interpreter can diddle signals */
2884     if (PL_curinterp != aTHX)
2885         return (Sighandler_t) SIG_ERR;
2886 #endif
2887
2888     act.sa_handler = (void(*)(int))handler;
2889     sigemptyset(&act.sa_mask);
2890     act.sa_flags = 0;
2891 #ifdef SA_RESTART
2892     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2893         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2894 #endif
2895 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2896     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2897         act.sa_flags |= SA_NOCLDWAIT;
2898 #endif
2899     if (sigaction(signo, &act, &oact) == -1)
2900         return (Sighandler_t) SIG_ERR;
2901     else
2902         return (Sighandler_t) oact.sa_handler;
2903 }
2904
2905 Sighandler_t
2906 Perl_rsignal_state(pTHX_ int signo)
2907 {
2908     struct sigaction oact;
2909     PERL_UNUSED_CONTEXT;
2910
2911     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2912         return (Sighandler_t) SIG_ERR;
2913     else
2914         return (Sighandler_t) oact.sa_handler;
2915 }
2916
2917 int
2918 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2919 {
2920 #ifdef USE_ITHREADS
2921     dVAR;
2922 #endif
2923     struct sigaction act;
2924
2925     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2926
2927 #ifdef USE_ITHREADS
2928     /* only "parent" interpreter can diddle signals */
2929     if (PL_curinterp != aTHX)
2930         return -1;
2931 #endif
2932
2933     act.sa_handler = (void(*)(int))handler;
2934     sigemptyset(&act.sa_mask);
2935     act.sa_flags = 0;
2936 #ifdef SA_RESTART
2937     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2938         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2939 #endif
2940 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2941     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2942         act.sa_flags |= SA_NOCLDWAIT;
2943 #endif
2944     return sigaction(signo, &act, save);
2945 }
2946
2947 int
2948 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2949 {
2950 #ifdef USE_ITHREADS
2951     dVAR;
2952 #endif
2953     PERL_UNUSED_CONTEXT;
2954 #ifdef USE_ITHREADS
2955     /* only "parent" interpreter can diddle signals */
2956     if (PL_curinterp != aTHX)
2957         return -1;
2958 #endif
2959
2960     return sigaction(signo, save, (struct sigaction *)NULL);
2961 }
2962
2963 #else /* !HAS_SIGACTION */
2964
2965 Sighandler_t
2966 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2967 {
2968 #if defined(USE_ITHREADS) && !defined(WIN32)
2969     /* only "parent" interpreter can diddle signals */
2970     if (PL_curinterp != aTHX)
2971         return (Sighandler_t) SIG_ERR;
2972 #endif
2973
2974     return PerlProc_signal(signo, handler);
2975 }
2976
2977 static Signal_t
2978 sig_trap(int signo)
2979 {
2980     dVAR;
2981     PL_sig_trapped++;
2982 }
2983
2984 Sighandler_t
2985 Perl_rsignal_state(pTHX_ int signo)
2986 {
2987     dVAR;
2988     Sighandler_t oldsig;
2989
2990 #if defined(USE_ITHREADS) && !defined(WIN32)
2991     /* only "parent" interpreter can diddle signals */
2992     if (PL_curinterp != aTHX)
2993         return (Sighandler_t) SIG_ERR;
2994 #endif
2995
2996     PL_sig_trapped = 0;
2997     oldsig = PerlProc_signal(signo, sig_trap);
2998     PerlProc_signal(signo, oldsig);
2999     if (PL_sig_trapped)
3000         PerlProc_kill(PerlProc_getpid(), signo);
3001     return oldsig;
3002 }
3003
3004 int
3005 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3006 {
3007 #if defined(USE_ITHREADS) && !defined(WIN32)
3008     /* only "parent" interpreter can diddle signals */
3009     if (PL_curinterp != aTHX)
3010         return -1;
3011 #endif
3012     *save = PerlProc_signal(signo, handler);
3013     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3014 }
3015
3016 int
3017 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3018 {
3019 #if defined(USE_ITHREADS) && !defined(WIN32)
3020     /* only "parent" interpreter can diddle signals */
3021     if (PL_curinterp != aTHX)
3022         return -1;
3023 #endif
3024     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3025 }
3026
3027 #endif /* !HAS_SIGACTION */
3028 #endif /* !PERL_MICRO */
3029
3030     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3031 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3032 I32
3033 Perl_my_pclose(pTHX_ PerlIO *ptr)
3034 {
3035     int status;
3036     SV **svp;
3037     Pid_t pid;
3038     Pid_t pid2 = 0;
3039     bool close_failed;
3040     dSAVEDERRNO;
3041     const int fd = PerlIO_fileno(ptr);
3042     bool should_wait;
3043
3044     svp = av_fetch(PL_fdpid,fd,TRUE);
3045     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3046     SvREFCNT_dec(*svp);
3047     *svp = NULL;
3048
3049 #if defined(USE_PERLIO)
3050     /* Find out whether the refcount is low enough for us to wait for the
3051        child proc without blocking. */
3052     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3053 #else
3054     should_wait = pid > 0;
3055 #endif
3056
3057 #ifdef OS2
3058     if (pid == -1) {                    /* Opened by popen. */
3059         return my_syspclose(ptr);
3060     }
3061 #endif
3062     close_failed = (PerlIO_close(ptr) == EOF);
3063     SAVE_ERRNO;
3064     if (should_wait) do {
3065         pid2 = wait4pid(pid, &status, 0);
3066     } while (pid2 == -1 && errno == EINTR);
3067     if (close_failed) {
3068         RESTORE_ERRNO;
3069         return -1;
3070     }
3071     return(
3072       should_wait
3073        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3074        : 0
3075     );
3076 }
3077 #else
3078 #if defined(__LIBCATAMOUNT__)
3079 I32
3080 Perl_my_pclose(pTHX_ PerlIO *ptr)
3081 {
3082     return -1;
3083 }
3084 #endif
3085 #endif /* !DOSISH */
3086
3087 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3088 I32
3089 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3090 {
3091     I32 result = 0;
3092     PERL_ARGS_ASSERT_WAIT4PID;
3093 #ifdef PERL_USES_PL_PIDSTATUS
3094     if (!pid) {
3095         /* PERL_USES_PL_PIDSTATUS is only defined when neither
3096            waitpid() nor wait4() is available, or on OS/2, which
3097            doesn't appear to support waiting for a progress group
3098            member, so we can only treat a 0 pid as an unknown child.
3099         */
3100         errno = ECHILD;
3101         return -1;
3102     }
3103     {
3104         if (pid > 0) {
3105             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3106                pid, rather than a string form.  */
3107             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3108             if (svp && *svp != &PL_sv_undef) {
3109                 *statusp = SvIVX(*svp);
3110                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3111                                 G_DISCARD);
3112                 return pid;
3113             }
3114         }
3115         else {
3116             HE *entry;
3117
3118             hv_iterinit(PL_pidstatus);
3119             if ((entry = hv_iternext(PL_pidstatus))) {
3120                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3121                 I32 len;
3122                 const char * const spid = hv_iterkey(entry,&len);
3123
3124                 assert (len == sizeof(Pid_t));
3125                 memcpy((char *)&pid, spid, len);
3126                 *statusp = SvIVX(sv);
3127                 /* The hash iterator is currently on this entry, so simply
3128                    calling hv_delete would trigger the lazy delete, which on
3129                    aggregate does more work, because next call to hv_iterinit()
3130                    would spot the flag, and have to call the delete routine,
3131                    while in the meantime any new entries can't re-use that
3132                    memory.  */
3133                 hv_iterinit(PL_pidstatus);
3134                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3135                 return pid;
3136             }
3137         }
3138     }
3139 #endif
3140 #ifdef HAS_WAITPID
3141 #  ifdef HAS_WAITPID_RUNTIME
3142     if (!HAS_WAITPID_RUNTIME)
3143         goto hard_way;
3144 #  endif
3145     result = PerlProc_waitpid(pid,statusp,flags);
3146     goto finish;
3147 #endif
3148 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3149     result = wait4(pid,statusp,flags,NULL);
3150     goto finish;
3151 #endif
3152 #ifdef PERL_USES_PL_PIDSTATUS
3153 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3154   hard_way:
3155 #endif
3156     {
3157         if (flags)
3158             Perl_croak(aTHX_ "Can't do waitpid with flags");
3159         else {
3160             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3161                 pidgone(result,*statusp);
3162             if (result < 0)
3163                 *statusp = -1;
3164         }
3165     }
3166 #endif
3167 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3168   finish:
3169 #endif
3170     if (result < 0 && errno == EINTR) {
3171         PERL_ASYNC_CHECK();
3172         errno = EINTR; /* reset in case a signal handler changed $! */
3173     }
3174     return result;
3175 }
3176 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3177
3178 #ifdef PERL_USES_PL_PIDSTATUS
3179 void
3180 S_pidgone(pTHX_ Pid_t pid, int status)
3181 {
3182     SV *sv;
3183
3184     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3185     SvUPGRADE(sv,SVt_IV);
3186     SvIV_set(sv, status);
3187     return;
3188 }
3189 #endif
3190
3191 #if defined(OS2)
3192 int pclose();
3193 #ifdef HAS_FORK
3194 int                                     /* Cannot prototype with I32
3195                                            in os2ish.h. */
3196 my_syspclose(PerlIO *ptr)
3197 #else
3198 I32
3199 Perl_my_pclose(pTHX_ PerlIO *ptr)
3200 #endif
3201 {
3202     /* Needs work for PerlIO ! */
3203     FILE * const f = PerlIO_findFILE(ptr);
3204     const I32 result = pclose(f);
3205     PerlIO_releaseFILE(ptr,f);
3206     return result;
3207 }
3208 #endif
3209
3210 #if defined(DJGPP)
3211 int djgpp_pclose();
3212 I32
3213 Perl_my_pclose(pTHX_ PerlIO *ptr)
3214 {
3215     /* Needs work for PerlIO ! */
3216     FILE * const f = PerlIO_findFILE(ptr);
3217     I32 result = djgpp_pclose(f);
3218     result = (result << 8) & 0xff00;
3219     PerlIO_releaseFILE(ptr,f);
3220     return result;
3221 }
3222 #endif
3223
3224 #define PERL_REPEATCPY_LINEAR 4
3225 void
3226 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3227 {
3228     PERL_ARGS_ASSERT_REPEATCPY;
3229
3230     assert(len >= 0);
3231
3232     if (count < 0)
3233         croak_memory_wrap();
3234
3235     if (len == 1)
3236         memset(to, *from, count);
3237     else if (count) {
3238         char *p = to;
3239         IV items, linear, half;
3240
3241         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3242         for (items = 0; items < linear; ++items) {
3243             const char *q = from;
3244             IV todo;
3245             for (todo = len; todo > 0; todo--)
3246                 *p++ = *q++;
3247         }
3248
3249         half = count / 2;
3250         while (items <= half) {
3251             IV size = items * len;
3252             memcpy(p, to, size);
3253             p     += size;
3254             items *= 2;
3255         }
3256
3257         if (count > items)
3258             memcpy(p, to, (count - items) * len);
3259     }
3260 }
3261
3262 #ifndef HAS_RENAME
3263 I32
3264 Perl_same_dirent(pTHX_ const char *a, const char *b)
3265 {
3266     char *fa = strrchr(a,'/');
3267     char *fb = strrchr(b,'/');
3268     Stat_t tmpstatbuf1;
3269     Stat_t tmpstatbuf2;
3270     SV * const tmpsv = sv_newmortal();
3271
3272     PERL_ARGS_ASSERT_SAME_DIRENT;
3273
3274     if (fa)
3275         fa++;
3276     else
3277         fa = a;
3278     if (fb)
3279         fb++;
3280     else
3281         fb = b;
3282     if (strNE(a,b))
3283         return FALSE;
3284     if (fa == a)
3285         sv_setpvs(tmpsv, ".");
3286     else
3287         sv_setpvn(tmpsv, a, fa - a);
3288     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3289         return FALSE;
3290     if (fb == b)
3291         sv_setpvs(tmpsv, ".");
3292     else
3293         sv_setpvn(tmpsv, b, fb - b);
3294     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3295         return FALSE;
3296     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3297            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3298 }
3299 #endif /* !HAS_RENAME */
3300
3301 char*
3302 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3303                  const char *const *const search_ext, I32 flags)
3304 {
3305     const char *xfound = NULL;
3306     char *xfailed = NULL;
3307     char tmpbuf[MAXPATHLEN];
3308     char *s;
3309     I32 len = 0;
3310     int retval;
3311     char *bufend;
3312 #if defined(DOSISH) && !defined(OS2)
3313 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3314 #  define MAX_EXT_LEN 4
3315 #endif
3316 #ifdef OS2
3317 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3318 #  define MAX_EXT_LEN 4
3319 #endif
3320 #ifdef VMS
3321 #  define SEARCH_EXTS ".pl", ".com", NULL
3322 #  define MAX_EXT_LEN 4
3323 #endif
3324     /* additional extensions to try in each dir if scriptname not found */
3325 #ifdef SEARCH_EXTS
3326     static const char *const exts[] = { SEARCH_EXTS };
3327     const char *const *const ext = search_ext ? search_ext : exts;
3328     int extidx = 0, i = 0;
3329     const char *curext = NULL;
3330 #else
3331     PERL_UNUSED_ARG(search_ext);
3332 #  define MAX_EXT_LEN 0
3333 #endif
3334
3335     PERL_ARGS_ASSERT_FIND_SCRIPT;
3336
3337     /*
3338      * If dosearch is true and if scriptname does not contain path
3339      * delimiters, search the PATH for scriptname.
3340      *
3341      * If SEARCH_EXTS is also defined, will look for each
3342      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3343      * while searching the PATH.
3344      *
3345      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3346      * proceeds as follows:
3347      *   If DOSISH or VMSISH:
3348      *     + look for ./scriptname{,.foo,.bar}
3349      *     + search the PATH for scriptname{,.foo,.bar}
3350      *
3351      *   If !DOSISH:
3352      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3353      *       this will not look in '.' if it's not in the PATH)
3354      */
3355     tmpbuf[0] = '\0';
3356
3357 #ifdef VMS
3358 #  ifdef ALWAYS_DEFTYPES
3359     len = strlen(scriptname);
3360     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3361         int idx = 0, deftypes = 1;
3362         bool seen_dot = 1;
3363
3364         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3365 #  else
3366     if (dosearch) {
3367         int idx = 0, deftypes = 1;
3368         bool seen_dot = 1;
3369
3370         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3371 #  endif
3372         /* The first time through, just add SEARCH_EXTS to whatever we
3373          * already have, so we can check for default file types. */
3374         while (deftypes ||
3375                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3376         {
3377             Stat_t statbuf;
3378             if (deftypes) {
3379                 deftypes = 0;
3380                 *tmpbuf = '\0';
3381             }
3382             if ((strlen(tmpbuf) + strlen(scriptname)
3383                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3384                 continue;       /* don't search dir with too-long name */
3385             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3386 #else  /* !VMS */
3387
3388 #ifdef DOSISH
3389     if (strEQ(scriptname, "-"))
3390         dosearch = 0;
3391     if (dosearch) {             /* Look in '.' first. */
3392         const char *cur = scriptname;
3393 #ifdef SEARCH_EXTS
3394         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3395             while (ext[i])
3396                 if (strEQ(ext[i++],curext)) {
3397                     extidx = -1;                /* already has an ext */
3398                     break;
3399                 }
3400         do {
3401 #endif
3402             DEBUG_p(PerlIO_printf(Perl_debug_log,
3403                                   "Looking for %s\n",cur));
3404             {
3405                 Stat_t statbuf;
3406                 if (PerlLIO_stat(cur,&statbuf) >= 0
3407                     && !S_ISDIR(statbuf.st_mode)) {
3408                     dosearch = 0;
3409                     scriptname = cur;
3410 #ifdef SEARCH_EXTS
3411                     break;
3412 #endif
3413                 }
3414             }
3415 #ifdef SEARCH_EXTS
3416             if (cur == scriptname) {
3417                 len = strlen(scriptname);
3418                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3419                     break;
3420                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3421                 cur = tmpbuf;
3422             }
3423         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3424                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3425 #endif
3426     }
3427 #endif
3428
3429     if (dosearch && !strchr(scriptname, '/')
3430 #ifdef DOSISH
3431                  && !strchr(scriptname, '\\')
3432 #endif
3433                  && (s = PerlEnv_getenv("PATH")))
3434     {
3435         bool seen_dot = 0;
3436
3437         bufend = s + strlen(s);
3438         while (s < bufend) {
3439             Stat_t statbuf;
3440 #  ifdef DOSISH
3441             for (len = 0; *s
3442                     && *s != ';'; len++, s++) {
3443                 if (len < sizeof tmpbuf)
3444                     tmpbuf[len] = *s;
3445             }
3446             if (len < sizeof tmpbuf)
3447                 tmpbuf[len] = '\0';
3448 #  else
3449             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3450                         ':',
3451                         &len);
3452 #  endif
3453             if (s < bufend)
3454                 s++;
3455             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3456                 continue;       /* don't search dir with too-long name */
3457             if (len
3458 #  ifdef DOSISH
3459                 && tmpbuf[len - 1] != '/'
3460                 && tmpbuf[len - 1] != '\\'
3461 #  endif
3462                )
3463                 tmpbuf[len++] = '/';
3464             if (len == 2 && tmpbuf[0] == '.')
3465                 seen_dot = 1;
3466             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3467 #endif  /* !VMS */
3468
3469 #ifdef SEARCH_EXTS
3470             len = strlen(tmpbuf);
3471             if (extidx > 0)     /* reset after previous loop */
3472                 extidx = 0;
3473             do {
3474 #endif
3475                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3476                 retval = PerlLIO_stat(tmpbuf,&statbuf);
3477                 if (S_ISDIR(statbuf.st_mode)) {
3478                     retval = -1;
3479                 }
3480 #ifdef SEARCH_EXTS
3481             } while (  retval < 0               /* not there */
3482                     && extidx>=0 && ext[extidx] /* try an extension? */
3483                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3484                 );
3485 #endif
3486             if (retval < 0)
3487                 continue;
3488             if (S_ISREG(statbuf.st_mode)
3489                 && cando(S_IRUSR,TRUE,&statbuf)
3490 #if !defined(DOSISH)
3491                 && cando(S_IXUSR,TRUE,&statbuf)
3492 #endif
3493                 )
3494             {
3495                 xfound = tmpbuf;                /* bingo! */
3496                 break;
3497             }
3498             if (!xfailed)
3499                 xfailed = savepv(tmpbuf);
3500         }
3501 #ifndef DOSISH
3502         {
3503             Stat_t statbuf;
3504             if (!xfound && !seen_dot && !xfailed &&
3505                 (PerlLIO_stat(scriptname,&statbuf) < 0
3506                  || S_ISDIR(statbuf.st_mode)))
3507 #endif
3508                 seen_dot = 1;                   /* Disable message. */
3509 #ifndef DOSISH
3510         }
3511 #endif
3512         if (!xfound) {
3513             if (flags & 1) {                    /* do or die? */
3514                 /* diag_listed_as: Can't execute %s */
3515                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3516                       (xfailed ? "execute" : "find"),
3517                       (xfailed ? xfailed : scriptname),
3518                       (xfailed ? "" : " on PATH"),
3519                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3520             }
3521             scriptname = NULL;
3522         }
3523         Safefree(xfailed);
3524         scriptname = xfound;
3525     }
3526     return (scriptname ? savepv(scriptname) : NULL);
3527 }
3528
3529 #ifndef PERL_GET_CONTEXT_DEFINED
3530
3531 void *
3532 Perl_get_context(void)
3533 {
3534 #if defined(USE_ITHREADS)
3535     dVAR;
3536 #  ifdef OLD_PTHREADS_API
3537     pthread_addr_t t;
3538     int error = pthread_getspecific(PL_thr_key, &t)
3539     if (error)
3540         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3541     return (void*)t;
3542 #  else
3543 #    ifdef I_MACH_CTHREADS
3544     return (void*)cthread_data(cthread_self());
3545 #    else
3546     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3547 #    endif
3548 #  endif
3549 #else
3550     return (void*)NULL;
3551 #endif
3552 }
3553
3554 void
3555 Perl_set_context(void *t)
3556 {
3557 #if defined(USE_ITHREADS)
3558     dVAR;
3559 #endif
3560     PERL_ARGS_ASSERT_SET_CONTEXT;
3561 #if defined(USE_ITHREADS)
3562 #  ifdef I_MACH_CTHREADS
3563     cthread_set_data(cthread_self(), t);
3564 #  else
3565     {
3566         const int error = pthread_setspecific(PL_thr_key, t);
3567         if (error)
3568             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3569     }
3570 #  endif
3571 #else
3572     PERL_UNUSED_ARG(t);
3573 #endif
3574 }
3575
3576 #endif /* !PERL_GET_CONTEXT_DEFINED */
3577
3578 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3579 struct perl_vars *
3580 Perl_GetVars(pTHX)
3581 {
3582     PERL_UNUSED_CONTEXT;
3583     return &PL_Vars;
3584 }
3585 #endif
3586
3587 char **
3588 Perl_get_op_names(pTHX)
3589 {
3590     PERL_UNUSED_CONTEXT;
3591     return (char **)PL_op_name;
3592 }
3593
3594 char **
3595 Perl_get_op_descs(pTHX)
3596 {
3597     PERL_UNUSED_CONTEXT;
3598     return (char **)PL_op_desc;
3599 }
3600
3601 const char *
3602 Perl_get_no_modify(pTHX)
3603 {
3604     PERL_UNUSED_CONTEXT;
3605     return PL_no_modify;
3606 }
3607
3608 U32 *
3609 Perl_get_opargs(pTHX)
3610 {
3611     PERL_UNUSED_CONTEXT;
3612     return (U32 *)PL_opargs;
3613 }
3614
3615 PPADDR_t*
3616 Perl_get_ppaddr(pTHX)
3617 {
3618     dVAR;
3619     PERL_UNUSED_CONTEXT;
3620     return (PPADDR_t*)PL_ppaddr;
3621 }
3622
3623 #ifndef HAS_GETENV_LEN
3624 char *
3625 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3626 {
3627     char * const env_trans = PerlEnv_getenv(env_elem);
3628     PERL_UNUSED_CONTEXT;
3629     PERL_ARGS_ASSERT_GETENV_LEN;
3630     if (env_trans)
3631         *len = strlen(env_trans);
3632     return env_trans;
3633 }
3634 #endif
3635
3636
3637 MGVTBL*
3638 Perl_get_vtbl(pTHX_ int vtbl_id)
3639 {
3640     PERL_UNUSED_CONTEXT;
3641
3642     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3643         ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3644 }
3645
3646 I32
3647 Perl_my_fflush_all(pTHX)
3648 {
3649 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3650     return PerlIO_flush(NULL);
3651 #else
3652 # if defined(HAS__FWALK)
3653     extern int fflush(FILE *);
3654     /* undocumented, unprototyped, but very useful BSDism */
3655     extern void _fwalk(int (*)(FILE *));
3656     _fwalk(&fflush);
3657     return 0;
3658 # else
3659 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3660     long open_max = -1;
3661 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3662     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3663 #   else
3664 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3665     open_max = sysconf(_SC_OPEN_MAX);
3666 #     else
3667 #      ifdef FOPEN_MAX
3668     open_max = FOPEN_MAX;
3669 #      else
3670 #       ifdef OPEN_MAX
3671     open_max = OPEN_MAX;
3672 #       else
3673 #        ifdef _NFILE
3674     open_max = _NFILE;
3675 #        endif
3676 #       endif
3677 #      endif
3678 #     endif
3679 #    endif
3680     if (open_max > 0) {
3681       long i;
3682       for (i = 0; i < open_max; i++)
3683             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3684                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3685                 STDIO_STREAM_ARRAY[i]._flag)
3686                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3687       return 0;
3688     }
3689 #  endif
3690     SETERRNO(EBADF,RMS_IFI);
3691     return EOF;
3692 # endif
3693 #endif
3694 }
3695
3696 void
3697 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3698 {
3699     if (ckWARN(WARN_IO)) {
3700         HEK * const name
3701            = gv && (isGV_with_GP(gv))
3702                 ? GvENAME_HEK((gv))
3703                 : NULL;
3704         const char * const direction = have == '>' ? "out" : "in";
3705
3706         if (name && HEK_LEN(name))
3707             Perl_warner(aTHX_ packWARN(WARN_IO),
3708                         "Filehandle %" HEKf " opened only for %sput",
3709                         HEKfARG(name), direction);
3710         else
3711             Perl_warner(aTHX_ packWARN(WARN_IO),
3712                         "Filehandle opened only for %sput", direction);
3713     }
3714 }
3715
3716 void
3717 Perl_report_evil_fh(pTHX_ const GV *gv)
3718 {
3719     const IO *io = gv ? GvIO(gv) : NULL;
3720     const PERL_BITFIELD16 op = PL_op->op_type;
3721     const char *vile;
3722     I32 warn_type;
3723
3724     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3725         vile = "closed";
3726         warn_type = WARN_CLOSED;
3727     }
3728     else {
3729         vile = "unopened";
3730         warn_type = WARN_UNOPENED;
3731     }
3732
3733     if (ckWARN(warn_type)) {
3734         SV * const name
3735             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3736                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3737         const char * const pars =
3738             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3739         const char * const func =
3740             (const char *)
3741             (op == OP_READLINE || op == OP_RCATLINE
3742                                  ? "readline"  :        /* "<HANDLE>" not nice */
3743              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3744              PL_op_desc[op]);
3745         const char * const type =
3746             (const char *)
3747             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3748              ? "socket" : "filehandle");
3749         const bool have_name = name && SvCUR(name);
3750         Perl_warner(aTHX_ packWARN(warn_type),
3751                    "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3752                     have_name ? " " : "",
3753                     SVfARG(have_name ? name : &PL_sv_no));
3754         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3755                 Perl_warner(
3756                             aTHX_ packWARN(warn_type),
3757                         "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3758                         func, pars, have_name ? " " : "",
3759                         SVfARG(have_name ? name : &PL_sv_no)
3760                             );
3761     }
3762 }
3763
3764 /* To workaround core dumps from the uninitialised tm_zone we get the
3765  * system to give us a reasonable struct to copy.  This fix means that
3766  * strftime uses the tm_zone and tm_gmtoff values returned by
3767  * localtime(time()). That should give the desired result most of the
3768  * time. But probably not always!
3769  *
3770  * This does not address tzname aspects of NETaa14816.
3771  *
3772  */
3773
3774 #ifdef __GLIBC__
3775 # ifndef STRUCT_TM_HASZONE
3776 #    define STRUCT_TM_HASZONE
3777 # endif
3778 #endif
3779
3780 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3781 # ifndef HAS_TM_TM_ZONE
3782 #    define HAS_TM_TM_ZONE
3783 # endif
3784 #endif
3785
3786 void
3787 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3788 {
3789 #ifdef HAS_TM_TM_ZONE
3790     Time_t now;
3791     const struct tm* my_tm;
3792     PERL_UNUSED_CONTEXT;
3793     PERL_ARGS_ASSERT_INIT_TM;
3794     (void)time(&now);
3795     my_tm = localtime(&now);
3796     if (my_tm)
3797         Copy(my_tm, ptm, 1, struct tm);
3798 #else
3799     PERL_UNUSED_CONTEXT;
3800     PERL_ARGS_ASSERT_INIT_TM;
3801     PERL_UNUSED_ARG(ptm);
3802 #endif
3803 }
3804
3805 /*
3806  * mini_mktime - normalise struct tm values without the localtime()
3807  * semantics (and overhead) of mktime().
3808  */
3809 void
3810 Perl_mini_mktime(struct tm *ptm)
3811 {
3812     int yearday;
3813     int secs;
3814     int month, mday, year, jday;
3815     int odd_cent, odd_year;
3816
3817     PERL_ARGS_ASSERT_MINI_MKTIME;
3818
3819 #define DAYS_PER_YEAR   365
3820 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3821 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3822 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3823 #define SECS_PER_HOUR   (60*60)
3824 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3825 /* parentheses deliberately absent on these two, otherwise they don't work */
3826 #define MONTH_TO_DAYS   153/5
3827 #define DAYS_TO_MONTH   5/153
3828 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3829 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3830 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3831 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3832
3833 /*
3834  * Year/day algorithm notes:
3835  *
3836  * With a suitable offset for numeric value of the month, one can find
3837  * an offset into the year by considering months to have 30.6 (153/5) days,
3838  * using integer arithmetic (i.e., with truncation).  To avoid too much
3839  * messing about with leap days, we consider January and February to be
3840  * the 13th and 14th month of the previous year.  After that transformation,
3841  * we need the month index we use to be high by 1 from 'normal human' usage,
3842  * so the month index values we use run from 4 through 15.
3843  *
3844  * Given that, and the rules for the Gregorian calendar (leap years are those
3845  * divisible by 4 unless also divisible by 100, when they must be divisible
3846  * by 400 instead), we can simply calculate the number of days since some
3847  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3848  * the days we derive from our month index, and adding in the day of the
3849  * month.  The value used here is not adjusted for the actual origin which
3850  * it normally would use (1 January A.D. 1), since we're not exposing it.
3851  * We're only building the value so we can turn around and get the
3852  * normalised values for the year, month, day-of-month, and day-of-year.
3853  *
3854  * For going backward, we need to bias the value we're using so that we find
3855  * the right year value.  (Basically, we don't want the contribution of
3856  * March 1st to the number to apply while deriving the year).  Having done
3857  * that, we 'count up' the contribution to the year number by accounting for
3858  * full quadracenturies (400-year periods) with their extra leap days, plus
3859  * the contribution from full centuries (to avoid counting in the lost leap
3860  * days), plus the contribution from full quad-years (to count in the normal
3861  * leap days), plus the leftover contribution from any non-leap years.
3862  * At this point, if we were working with an actual leap day, we'll have 0
3863  * days left over.  This is also true for March 1st, however.  So, we have
3864  * to special-case that result, and (earlier) keep track of the 'odd'
3865  * century and year contributions.  If we got 4 extra centuries in a qcent,
3866  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3867  * Otherwise, we add back in the earlier bias we removed (the 123 from
3868  * figuring in March 1st), find the month index (integer division by 30.6),
3869  * and the remainder is the day-of-month.  We then have to convert back to
3870  * 'real' months (including fixing January and February from being 14/15 in
3871  * the previous year to being in the proper year).  After that, to get
3872  * tm_yday, we work with the normalised year and get a new yearday value for
3873  * January 1st, which we subtract from the yearday value we had earlier,
3874  * representing the date we've re-built.  This is done from January 1
3875  * because tm_yday is 0-origin.
3876  *
3877  * Since POSIX time routines are only guaranteed to work for times since the
3878  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3879  * applies Gregorian calendar rules even to dates before the 16th century
3880  * doesn't bother me.  Besides, you'd need cultural context for a given
3881  * date to know whether it was Julian or Gregorian calendar, and that's
3882  * outside the scope for this routine.  Since we convert back based on the
3883  * same rules we used to build the yearday, you'll only get strange results
3884  * for input which needed normalising, or for the 'odd' century years which
3885  * were leap years in the Julian calendar but not in the Gregorian one.
3886  * I can live with that.
3887  *
3888  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3889  * that's still outside the scope for POSIX time manipulation, so I don't
3890  * care.
3891  */
3892
3893     year = 1900 + ptm->tm_year;
3894     month = ptm->tm_mon;
3895     mday = ptm->tm_mday;
3896     jday = 0;
3897     if (month >= 2)
3898         month+=2;
3899     else
3900         month+=14, year--;
3901     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3902     yearday += month*MONTH_TO_DAYS + mday + jday;
3903     /*
3904      * Note that we don't know when leap-seconds were or will be,
3905      * so we have to trust the user if we get something which looks
3906      * like a sensible leap-second.  Wild values for seconds will
3907      * be rationalised, however.
3908      */
3909     if ((unsigned) ptm->tm_sec <= 60) {
3910         secs = 0;
3911     }
3912     else {
3913         secs = ptm->tm_sec;
3914         ptm->tm_sec = 0;
3915     }
3916     secs += 60 * ptm->tm_min;
3917     secs += SECS_PER_HOUR * ptm->tm_hour;
3918     if (secs < 0) {
3919         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3920             /* got negative remainder, but need positive time */
3921             /* back off an extra day to compensate */
3922             yearday += (secs/SECS_PER_DAY)-1;
3923             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3924         }
3925         else {
3926             yearday += (secs/SECS_PER_DAY);
3927             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3928         }
3929     }
3930     else if (secs >= SECS_PER_DAY) {
3931         yearday += (secs/SECS_PER_DAY);
3932         secs %= SECS_PER_DAY;
3933     }
3934     ptm->tm_hour = secs/SECS_PER_HOUR;
3935     secs %= SECS_PER_HOUR;
3936     ptm->tm_min = secs/60;
3937     secs %= 60;
3938     ptm->tm_sec += secs;
3939     /* done with time of day effects */
3940     /*
3941      * The algorithm for yearday has (so far) left it high by 428.
3942      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3943      * bias it by 123 while trying to figure out what year it
3944      * really represents.  Even with this tweak, the reverse
3945      * translation fails for years before A.D. 0001.
3946      * It would still fail for Feb 29, but we catch that one below.
3947      */
3948     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3949     yearday -= YEAR_ADJUST;
3950     year = (yearday / DAYS_PER_QCENT) * 400;
3951     yearday %= DAYS_PER_QCENT;
3952     odd_cent = yearday / DAYS_PER_CENT;
3953     year += odd_cent * 100;
3954     yearday %= DAYS_PER_CENT;
3955     year += (yearday / DAYS_PER_QYEAR) * 4;
3956     yearday %= DAYS_PER_QYEAR;
3957     odd_year = yearday / DAYS_PER_YEAR;
3958     year += odd_year;
3959     yearday %= DAYS_PER_YEAR;
3960     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3961         month = 1;
3962         yearday = 29;
3963     }
3964     else {
3965         yearday += YEAR_ADJUST; /* recover March 1st crock */
3966         month = yearday*DAYS_TO_MONTH;
3967         yearday -= month*MONTH_TO_DAYS;
3968         /* recover other leap-year adjustment */
3969         if (month > 13) {
3970             month-=14;
3971             year++;
3972         }
3973         else {
3974             month-=2;
3975         }
3976     }
3977     ptm->tm_year = year - 1900;
3978     if (yearday) {
3979       ptm->tm_mday = yearday;
3980       ptm->tm_mon = month;
3981     }
3982     else {
3983       ptm->tm_mday = 31;
3984       ptm->tm_mon = month - 1;
3985     }
3986     /* re-build yearday based on Jan 1 to get tm_yday */
3987     year--;
3988     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3989     yearday += 14*MONTH_TO_DAYS + 1;
3990     ptm->tm_yday = jday - yearday;
3991     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3992 }
3993
3994 char *
3995 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)
3996 {
3997 #ifdef HAS_STRFTIME
3998
3999   /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
4000
4001   char *buf;
4002   int buflen;
4003   struct tm mytm;
4004   int len;
4005
4006   PERL_ARGS_ASSERT_MY_STRFTIME;
4007
4008   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4009   mytm.tm_sec = sec;
4010   mytm.tm_min = min;
4011   mytm.tm_hour = hour;
4012   mytm.tm_mday = mday;
4013   mytm.tm_mon = mon;
4014   mytm.tm_year = year;
4015   mytm.tm_wday = wday;
4016   mytm.tm_yday = yday;
4017   mytm.tm_isdst = isdst;
4018   mini_mktime(&mytm);
4019   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4020 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4021   STMT_START {
4022     struct tm mytm2;
4023     mytm2 = mytm;
4024     mktime(&mytm2);
4025 #ifdef HAS_TM_TM_GMTOFF
4026     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4027 #endif
4028 #ifdef HAS_TM_TM_ZONE
4029     mytm.tm_zone = mytm2.tm_zone;
4030 #endif
4031   } STMT_END;
4032 #endif
4033   buflen = 64;
4034   Newx(buf, buflen, char);
4035
4036   GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4037   len = strftime(buf, buflen, fmt, &mytm);
4038   GCC_DIAG_RESTORE;
4039
4040   /*
4041   ** The following is needed to handle to the situation where
4042   ** tmpbuf overflows.  Basically we want to allocate a buffer
4043   ** and try repeatedly.  The reason why it is so complicated
4044   ** is that getting a return value of 0 from strftime can indicate
4045   ** one of the following:
4046   ** 1. buffer overflowed,
4047   ** 2. illegal conversion specifier, or
4048   ** 3. the format string specifies nothing to be returned(not
4049   **      an error).  This could be because format is an empty string
4050   **    or it specifies %p that yields an empty string in some locale.
4051   ** If there is a better way to make it portable, go ahead by
4052   ** all means.
4053   */
4054   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4055     return buf;
4056   else {
4057     /* Possibly buf overflowed - try again with a bigger buf */
4058     const int fmtlen = strlen(fmt);
4059     int bufsize = fmtlen + buflen;
4060
4061     Renew(buf, bufsize, char);
4062     while (buf) {
4063
4064       GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4065       buflen = strftime(buf, bufsize, fmt, &mytm);
4066       GCC_DIAG_RESTORE;
4067
4068       if (buflen > 0 && buflen < bufsize)
4069         break;
4070       /* heuristic to prevent out-of-memory errors */
4071       if (bufsize > 100*fmtlen) {
4072         Safefree(buf);
4073         buf = NULL;
4074         break;
4075       }
4076       bufsize *= 2;
4077       Renew(buf, bufsize, char);
4078     }
4079     return buf;
4080   }
4081 #else
4082   Perl_croak(aTHX_ "panic: no strftime");
4083   return NULL;
4084 #endif
4085 }
4086
4087
4088 #define SV_CWD_RETURN_UNDEF \
4089     sv_set_undef(sv); \
4090     return FALSE
4091
4092 #define SV_CWD_ISDOT(dp) \
4093     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4094         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4095
4096 /*
4097 =head1 Miscellaneous Functions
4098
4099 =for apidoc getcwd_sv
4100
4101 Fill C<sv> with current working directory
4102
4103 =cut
4104 */
4105
4106 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4107  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4108  * getcwd(3) if available
4109  * Comments from the original:
4110  *     This is a faster version of getcwd.  It's also more dangerous
4111  *     because you might chdir out of a directory that you can't chdir
4112  *     back into. */
4113
4114 int
4115 Perl_getcwd_sv(pTHX_ SV *sv)
4116 {
4117 #ifndef PERL_MICRO
4118     SvTAINTED_on(sv);
4119
4120     PERL_ARGS_ASSERT_GETCWD_SV;
4121
4122 #ifdef HAS_GETCWD
4123     {
4124         char buf[MAXPATHLEN];
4125
4126         /* Some getcwd()s automatically allocate a buffer of the given
4127          * size from the heap if they are given a NULL buffer pointer.
4128          * The problem is that this behaviour is not portable. */
4129         if (getcwd(buf, sizeof(buf) - 1)) {
4130             sv_setpv(sv, buf);
4131             return TRUE;
4132         }
4133         else {
4134             SV_CWD_RETURN_UNDEF;
4135         }
4136     }
4137
4138 #else
4139
4140     Stat_t statbuf;
4141     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4142     int pathlen=0;
4143     Direntry_t *dp;
4144
4145     SvUPGRADE(sv, SVt_PV);
4146
4147     if (PerlLIO_lstat(".", &statbuf) < 0) {
4148         SV_CWD_RETURN_UNDEF;
4149     }
4150
4151     orig_cdev = statbuf.st_dev;
4152     orig_cino = statbuf.st_ino;
4153     cdev = orig_cdev;
4154     cino = orig_cino;
4155
4156     for (;;) {
4157         DIR *dir;
4158         int namelen;
4159         odev = cdev;
4160         oino = cino;
4161
4162         if (PerlDir_chdir("..") < 0) {
4163             SV_CWD_RETURN_UNDEF;
4164         }
4165         if (PerlLIO_stat(".", &statbuf) < 0) {
4166             SV_CWD_RETURN_UNDEF;
4167         }
4168
4169         cdev = statbuf.st_dev;
4170         cino = statbuf.st_ino;
4171
4172         if (odev == cdev && oino == cino) {
4173             break;
4174         }
4175         if (!(dir = PerlDir_open("."))) {
4176             SV_CWD_RETURN_UNDEF;
4177         }
4178
4179         while ((dp = PerlDir_read(dir)) != NULL) {
4180 #ifdef DIRNAMLEN
4181             namelen = dp->d_namlen;
4182 #else
4183             namelen = strlen(dp->d_name);
4184 #endif
4185             /* skip . and .. */
4186             if (SV_CWD_ISDOT(dp)) {
4187                 continue;
4188             }
4189
4190             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4191                 SV_CWD_RETURN_UNDEF;
4192             }
4193
4194             tdev = statbuf.st_dev;
4195             tino = statbuf.st_ino;
4196             if (tino == oino && tdev == odev) {
4197                 break;
4198             }
4199         }
4200
4201         if (!dp) {
4202             SV_CWD_RETURN_UNDEF;
4203         }
4204
4205         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4206             SV_CWD_RETURN_UNDEF;
4207         }
4208
4209         SvGROW(sv, pathlen + namelen + 1);
4210
4211         if (pathlen) {
4212             /* shift down */
4213             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4214         }
4215
4216         /* prepend current directory to the front */
4217         *SvPVX(sv) = '/';
4218         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4219         pathlen += (namelen + 1);
4220
4221 #ifdef VOID_CLOSEDIR
4222         PerlDir_close(dir);
4223 #else
4224         if (PerlDir_close(dir) < 0) {
4225             SV_CWD_RETURN_UNDEF;
4226         }
4227 #endif
4228     }
4229
4230     if (pathlen) {
4231         SvCUR_set(sv, pathlen);
4232         *SvEND(sv) = '\0';
4233         SvPOK_only(sv);
4234
4235         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4236             SV_CWD_RETURN_UNDEF;
4237         }
4238     }
4239     if (PerlLIO_stat(".", &statbuf) < 0) {
4240         SV_CWD_RETURN_UNDEF;
4241     }
4242
4243     cdev = statbuf.st_dev;
4244     cino = statbuf.st_ino;
4245
4246     if (cdev != orig_cdev || cino != orig_cino) {
4247         Perl_croak(aTHX_ "Unstable directory path, "
4248                    "current directory changed unexpectedly");
4249     }
4250
4251     return TRUE;
4252 #endif
4253
4254 #else
4255     return FALSE;
4256 #endif
4257 }
4258
4259 #include "vutil.c"
4260
4261 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4262 #   define EMULATE_SOCKETPAIR_UDP
4263 #endif
4264
4265 #ifdef EMULATE_SOCKETPAIR_UDP
4266 static int
4267 S_socketpair_udp (int fd[2]) {
4268     dTHX;
4269     /* Fake a datagram socketpair using UDP to localhost.  */
4270     int sockets[2] = {-1, -1};
4271     struct sockaddr_in addresses[2];
4272     int i;
4273     Sock_size_t size = sizeof(struct sockaddr_in);
4274     unsigned short port;
4275     int got;
4276
4277     memset(&addresses, 0, sizeof(addresses));
4278     i = 1;
4279     do {
4280         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4281         if (sockets[i] == -1)
4282             goto tidy_up_and_fail;
4283
4284         addresses[i].sin_family = AF_INET;
4285         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4286         addresses[i].sin_port = 0;      /* kernel choses port.  */
4287         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4288                 sizeof(struct sockaddr_in)) == -1)
4289             goto tidy_up_and_fail;
4290     } while (i--);
4291
4292     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4293        for each connect the other socket to it.  */
4294     i = 1;
4295     do {
4296         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4297                 &size) == -1)
4298             goto tidy_up_and_fail;
4299         if (size != sizeof(struct sockaddr_in))
4300             goto abort_tidy_up_and_fail;
4301         /* !1 is 0, !0 is 1 */
4302         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4303                 sizeof(struct sockaddr_in)) == -1)
4304             goto tidy_up_and_fail;
4305     } while (i--);
4306
4307     /* Now we have 2 sockets connected to each other. I don't trust some other
4308        process not to have already sent a packet to us (by random) so send
4309        a packet from each to the other.  */
4310     i = 1;
4311     do {
4312         /* I'm going to send my own port number.  As a short.
4313            (Who knows if someone somewhere has sin_port as a bitfield and needs
4314            this routine. (I'm assuming crays have socketpair)) */
4315         port = addresses[i].sin_port;
4316         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4317         if (got != sizeof(port)) {
4318             if (got == -1)
4319                 goto tidy_up_and_fail;
4320             goto abort_tidy_up_and_fail;
4321         }
4322     } while (i--);
4323
4324     /* Packets sent. I don't trust them to have arrived though.
4325        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4326        connect to localhost will use a second kernel thread. In 2.6 the
4327        first thread running the connect() returns before the second completes,
4328        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4329        returns 0. Poor programs have tripped up. One poor program's authors'
4330        had a 50-1 reverse stock split. Not sure how connected these were.)
4331        So I don't trust someone not to have an unpredictable UDP stack.
4332     */
4333
4334     {
4335         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4336         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4337         fd_set rset;
4338
4339         FD_ZERO(&rset);
4340         FD_SET((unsigned int)sockets[0], &rset);
4341         FD_SET((unsigned int)sockets[1], &rset);
4342
4343         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4344         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4345                 || !FD_ISSET(sockets[1], &rset)) {
4346             /* I hope this is portable and appropriate.  */
4347             if (got == -1)
4348                 goto tidy_up_and_fail;
4349             goto abort_tidy_up_and_fail;
4350         }
4351     }
4352
4353     /* And the paranoia department even now doesn't trust it to have arrive
4354        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4355     {
4356         struct sockaddr_in readfrom;
4357         unsigned short buffer[2];
4358
4359         i = 1;
4360         do {
4361 #ifdef MSG_DONTWAIT
4362             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4363                     sizeof(buffer), MSG_DONTWAIT,
4364                     (struct sockaddr *) &readfrom, &size);
4365 #else
4366             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4367                     sizeof(buffer), 0,
4368                     (struct sockaddr *) &readfrom, &size);
4369 #endif
4370
4371             if (got == -1)
4372                 goto tidy_up_and_fail;
4373             if (got != sizeof(port)
4374                     || size != sizeof(struct sockaddr_in)
4375                     /* Check other socket sent us its port.  */
4376                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4377                     /* Check kernel says we got the datagram from that socket */
4378                     || readfrom.sin_family != addresses[!i].sin_family
4379                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4380                     || readfrom.sin_port != addresses[!i].sin_port)
4381                 goto abort_tidy_up_and_fail;
4382         } while (i--);
4383     }
4384     /* My caller (my_socketpair) has validated that this is non-NULL  */
4385     fd[0] = sockets[0];
4386     fd[1] = sockets[1];
4387     /* I hereby declare this connection open.  May God bless all who cross
4388        her.  */
4389     return 0;
4390
4391   abort_tidy_up_and_fail:
4392     errno = ECONNABORTED;
4393   tidy_up_and_fail:
4394     {
4395         dSAVE_ERRNO;
4396         if (sockets[0] != -1)
4397             PerlLIO_close(sockets[0]);
4398         if (sockets[1] != -1)
4399             PerlLIO_close(sockets[1]);
4400         RESTORE_ERRNO;
4401         return -1;
4402     }
4403 }
4404 #endif /*  EMULATE_SOCKETPAIR_UDP */
4405
4406 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4407 int
4408 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4409     /* Stevens says that family must be AF_LOCAL, protocol 0.
4410        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4411     dTHXa(NULL);
4412     int listener = -1;
4413     int connector = -1;
4414     int acceptor = -1;
4415     struct sockaddr_in listen_addr;
4416     struct sockaddr_in connect_addr;
4417     Sock_size_t size;
4418
4419     if (protocol
4420 #ifdef AF_UNIX
4421         || family != AF_UNIX
4422 #endif
4423     ) {
4424         errno = EAFNOSUPPORT;
4425         return -1;
4426     }
4427     if (!fd) {
4428         errno = EINVAL;
4429         return -1;
4430     }
4431
4432 #ifdef EMULATE_SOCKETPAIR_UDP
4433     if (type == SOCK_DGRAM)
4434         return S_socketpair_udp(fd);
4435 #endif
4436
4437     aTHXa(PERL_GET_THX);
4438     listener = PerlSock_socket(AF_INET, type, 0);
4439     if (listener == -1)
4440         return -1;
4441     memset(&listen_addr, 0, sizeof(listen_addr));
4442     listen_addr.sin_family = AF_INET;
4443     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4444     listen_addr.sin_port = 0;   /* kernel choses port.  */
4445     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4446             sizeof(listen_addr)) == -1)
4447         goto tidy_up_and_fail;
4448     if (PerlSock_listen(listener, 1) == -1)
4449         goto tidy_up_and_fail;
4450
4451     connector = PerlSock_socket(AF_INET, type, 0);
4452     if (connector == -1)
4453         goto tidy_up_and_fail;
4454     /* We want to find out the port number to connect to.  */
4455     size = sizeof(connect_addr);
4456     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4457             &size) == -1)
4458         goto tidy_up_and_fail;
4459     if (size != sizeof(connect_addr))
4460         goto abort_tidy_up_and_fail;
4461     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4462             sizeof(connect_addr)) == -1)
4463         goto tidy_up_and_fail;
4464
4465     size = sizeof(listen_addr);
4466     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4467             &size);
4468     if (acceptor == -1)
4469         goto tidy_up_and_fail;
4470     if (size != sizeof(listen_addr))
4471         goto abort_tidy_up_and_fail;
4472     PerlLIO_close(listener);
4473     /* Now check we are talking to ourself by matching port and host on the
4474        two sockets.  */
4475     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4476             &size) == -1)
4477         goto tidy_up_and_fail;
4478     if (size != sizeof(connect_addr)
4479             || listen_addr.sin_family != connect_addr.sin_family
4480             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4481             || listen_addr.sin_port != connect_addr.sin_port) {
4482         goto abort_tidy_up_and_fail;
4483     }
4484     fd[0] = connector;
4485     fd[1] = acceptor;
4486     return 0;
4487
4488   abort_tidy_up_and_fail:
4489 #ifdef ECONNABORTED
4490   errno = ECONNABORTED; /* This would be the standard thing to do. */
4491 #else
4492 #  ifdef ECONNREFUSED
4493   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4494 #  else
4495   errno = ETIMEDOUT;    /* Desperation time. */
4496 #  endif
4497 #endif
4498   tidy_up_and_fail:
4499     {
4500         dSAVE_ERRNO;
4501         if (listener != -1)
4502             PerlLIO_close(listener);
4503         if (connector != -1)
4504             PerlLIO_close(connector);
4505         if (acceptor != -1)
4506             PerlLIO_close(acceptor);
4507         RESTORE_ERRNO;
4508         return -1;
4509     }
4510 }
4511 #else
4512 /* In any case have a stub so that there's code corresponding
4513  * to the my_socketpair in embed.fnc. */
4514 int
4515 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4516 #ifdef HAS_SOCKETPAIR
4517     return socketpair(family, type, protocol, fd);
4518 #else
4519     return -1;
4520 #endif
4521 }
4522 #endif
4523
4524 /*
4525
4526 =for apidoc sv_nosharing
4527
4528 Dummy routine which "shares" an SV when there is no sharing module present.
4529 Or "locks" it.  Or "unlocks" it.  In other
4530 words, ignores its single SV argument.
4531 Exists to avoid test for a C<NULL> function pointer and because it could
4532 potentially warn under some level of strict-ness.
4533
4534 =cut
4535 */
4536
4537 void
4538 Perl_sv_nosharing(pTHX_ SV *sv)
4539 {
4540     PERL_UNUSED_CONTEXT;
4541     PERL_UNUSED_ARG(sv);
4542 }
4543
4544 /*
4545
4546 =for apidoc sv_destroyable
4547
4548 Dummy routine which reports that object can be destroyed when there is no
4549 sharing module present.  It ignores its single SV argument, and returns
4550 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4551 could potentially warn under some level of strict-ness.
4552
4553 =cut
4554 */
4555
4556 bool
4557 Perl_sv_destroyable(pTHX_ SV *sv)
4558 {
4559     PERL_UNUSED_CONTEXT;
4560     PERL_UNUSED_ARG(sv);
4561     return TRUE;
4562 }
4563
4564 U32
4565 Perl_parse_unicode_opts(pTHX_ const char **popt)
4566 {
4567   const char *p = *popt;
4568   U32 opt = 0;
4569
4570   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4571
4572   if (*p) {
4573        if (isDIGIT(*p)) {
4574             const char* endptr;
4575             UV uv;
4576             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4577                 opt = (U32)uv;
4578                 p = endptr;
4579                 if (p && *p && *p != '\n' && *p != '\r') {
4580                     if (isSPACE(*p))
4581                         goto the_end_of_the_opts_parser;
4582                     else
4583                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4584                 }
4585             }
4586             else {
4587                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4588             }
4589         }
4590         else {
4591             for (; *p; p++) {
4592                  switch (*p) {
4593                  case PERL_UNICODE_STDIN:
4594                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4595                  case PERL_UNICODE_STDOUT:
4596                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4597                  case PERL_UNICODE_STDERR:
4598                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4599                  case PERL_UNICODE_STD:
4600                       opt |= PERL_UNICODE_STD_FLAG;     break;
4601                  case PERL_UNICODE_IN:
4602                       opt |= PERL_UNICODE_IN_FLAG;      break;
4603                  case PERL_UNICODE_OUT:
4604                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4605                  case PERL_UNICODE_INOUT:
4606                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4607                  case PERL_UNICODE_LOCALE:
4608                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4609                  case PERL_UNICODE_ARGV:
4610                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4611                  case PERL_UNICODE_UTF8CACHEASSERT:
4612                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4613                  default:
4614                       if (*p != '\n' && *p != '\r') {
4615                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4616                         else
4617                           Perl_croak(aTHX_
4618                                      "Unknown Unicode option letter '%c'", *p);
4619                       }
4620                  }
4621             }
4622        }
4623   }
4624   else
4625        opt = PERL_UNICODE_DEFAULT_FLAGS;
4626
4627   the_end_of_the_opts_parser:
4628
4629   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4630        Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4631                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4632
4633   *popt = p;
4634
4635   return opt;
4636 }
4637
4638 #ifdef VMS
4639 #  include <starlet.h>
4640 #endif
4641
4642 U32
4643 Perl_seed(pTHX)
4644 {
4645     /*
4646      * This is really just a quick hack which grabs various garbage
4647      * values.  It really should be a real hash algorithm which
4648      * spreads the effect of every input bit onto every output bit,
4649      * if someone who knows about such things would bother to write it.
4650      * Might be a good idea to add that function to CORE as well.
4651      * No numbers below come from careful analysis or anything here,
4652      * except they are primes and SEED_C1 > 1E6 to get a full-width
4653      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4654      * probably be bigger too.
4655      */
4656 #if RANDBITS > 16
4657 #  define SEED_C1       1000003
4658 #define   SEED_C4       73819
4659 #else
4660 #  define SEED_C1       25747
4661 #define   SEED_C4       20639
4662 #endif
4663 #define   SEED_C2       3
4664 #define   SEED_C3       269
4665 #define   SEED_C5       26107
4666
4667 #ifndef PERL_NO_DEV_RANDOM
4668     int fd;
4669 #endif
4670     U32 u;
4671 #ifdef HAS_GETTIMEOFDAY
4672     struct timeval when;
4673 #else
4674     Time_t when;
4675 #endif
4676
4677 /* This test is an escape hatch, this symbol isn't set by Configure. */
4678 #ifndef PERL_NO_DEV_RANDOM
4679 #ifndef PERL_RANDOM_DEVICE
4680    /* /dev/random isn't used by default because reads from it will block
4681     * if there isn't enough entropy available.  You can compile with
4682     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4683     * is enough real entropy to fill the seed. */
4684 #  ifdef __amigaos4__
4685 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4686 #  else
4687 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4688 #  endif
4689 #endif
4690     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4691     if (fd != -1) {
4692         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4693             u = 0;
4694         PerlLIO_close(fd);
4695         if (u)
4696             return u;
4697     }
4698 #endif
4699
4700 #ifdef HAS_GETTIMEOFDAY
4701     PerlProc_gettimeofday(&when,NULL);
4702     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4703 #else
4704     (void)time(&when);
4705     u = (U32)SEED_C1 * when;
4706 #endif
4707     u += SEED_C3 * (U32)PerlProc_getpid();
4708     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4709 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4710     u += SEED_C5 * (U32)PTR2UV(&when);
4711 #endif
4712     return u;
4713 }
4714
4715 void
4716 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4717 {
4718 #ifndef NO_PERL_HASH_ENV
4719     const char *env_pv;
4720 #endif
4721     unsigned long i;
4722
4723     PERL_ARGS_ASSERT_GET_HASH_SEED;
4724
4725 #ifndef NO_PERL_HASH_ENV
4726     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4727
4728     if ( env_pv )
4729 #  ifndef USE_HASH_SEED_EXPLICIT
4730     {
4731         /* ignore leading spaces */
4732         while (isSPACE(*env_pv))
4733             env_pv++;
4734 #    ifdef USE_PERL_PERTURB_KEYS
4735         /* if they set it to "0" we disable key traversal randomization completely */
4736         if (strEQ(env_pv,"0")) {
4737             PL_hash_rand_bits_enabled= 0;
4738         } else {
4739             /* otherwise switch to deterministic mode */
4740             PL_hash_rand_bits_enabled= 2;
4741         }
4742 #    endif
4743         /* ignore a leading 0x... if it is there */
4744         if (env_pv[0] == '0' && env_pv[1] == 'x')
4745             env_pv += 2;
4746
4747         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4748             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4749             if ( isXDIGIT(*env_pv)) {
4750                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4751             }
4752         }
4753         while (isSPACE(*env_pv))
4754             env_pv++;
4755
4756         if (*env_pv && !isXDIGIT(*env_pv)) {
4757             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4758         }
4759         /* should we check for unparsed crap? */
4760         /* should we warn about unused hex? */
4761         /* should we warn about insufficient hex? */
4762     }
4763     else
4764 #  endif
4765 #endif
4766     {
4767         (void)seedDrand01((Rand_seed_t)seed());
4768
4769         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4770             seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4771         }
4772     }
4773 #ifdef USE_PERL_PERTURB_KEYS
4774     {   /* initialize PL_hash_rand_bits from the hash seed.
4775          * This value is highly volatile, it is updated every
4776          * hash insert, and is used as part of hash bucket chain
4777          * randomization and hash iterator randomization. */
4778         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4779         for( i = 0; i < sizeof(UV) ; i++ ) {
4780             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4781             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4782         }
4783     }
4784 #  ifndef NO_PERL_HASH_ENV
4785     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4786     if (env_pv) {
4787         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4788             PL_hash_rand_bits_enabled= 0;
4789         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4790             PL_hash_rand_bits_enabled= 1;
4791         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4792             PL_hash_rand_bits_enabled= 2;
4793         } else {
4794             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4795         }
4796     }
4797 #  endif
4798 #endif
4799 }
4800
4801 #ifdef PERL_GLOBAL_STRUCT
4802
4803 #define PERL_GLOBAL_STRUCT_INIT
4804 #include "opcode.h" /* the ppaddr and check */
4805
4806 struct perl_vars *
4807 Perl_init_global_struct(pTHX)
4808 {
4809     struct perl_vars *plvarsp = NULL;
4810 # ifdef PERL_GLOBAL_STRUCT
4811     const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4812     const IV ncheck  = C_ARRAY_LENGTH(Gcheck);
4813     PERL_UNUSED_CONTEXT;
4814 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4815     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4816     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4817     if (!plvarsp)
4818         exit(1);
4819 #  else
4820     plvarsp = PL_VarsPtr;
4821 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4822 #  undef PERLVAR
4823 #  undef PERLVARA
4824 #  undef PERLVARI
4825 #  undef PERLVARIC
4826 #  define PERLVAR(prefix,var,type) /**/
4827 #  define PERLVARA(prefix,var,n,type) /**/
4828 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4829 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4830 #  include "perlvars.h"
4831 #  undef PERLVAR
4832 #  undef PERLVARA
4833 #  undef PERLVARI
4834 #  undef PERLVARIC
4835 #  ifdef PERL_GLOBAL_STRUCT
4836     plvarsp->Gppaddr =
4837         (Perl_ppaddr_t*)
4838         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4839     if (!plvarsp->Gppaddr)
4840         exit(1);
4841     plvarsp->Gcheck  =
4842         (Perl_check_t*)
4843         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4844     if (!plvarsp->Gcheck)
4845         exit(1);
4846     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
4847     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t); 
4848 #  endif
4849 #  ifdef PERL_SET_VARS
4850     PERL_SET_VARS(plvarsp);
4851 #  endif
4852 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4853     plvarsp->Gsv_placeholder.sv_flags = 0;
4854     memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4855 #  endif
4856 # undef PERL_GLOBAL_STRUCT_INIT
4857 # endif
4858     return plvarsp;
4859 }
4860
4861 #endif /* PERL_GLOBAL_STRUCT */
4862
4863 #ifdef PERL_GLOBAL_STRUCT
4864
4865 void
4866 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4867 {
4868     int veto = plvarsp->Gveto_cleanup;
4869
4870     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4871     PERL_UNUSED_CONTEXT;
4872 # ifdef PERL_GLOBAL_STRUCT
4873 #  ifdef PERL_UNSET_VARS
4874     PERL_UNSET_VARS(plvarsp);
4875 #  endif
4876     if (veto)
4877         return;
4878     free(plvarsp->Gppaddr);
4879     free(plvarsp->Gcheck);
4880 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4881     free(plvarsp);
4882 #  endif
4883 # endif
4884 }
4885
4886 #endif /* PERL_GLOBAL_STRUCT */
4887
4888 #ifdef PERL_MEM_LOG
4889
4890 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4891  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4892  * given, and you supply your own implementation.
4893  *
4894  * The default implementation reads a single env var, PERL_MEM_LOG,
4895  * expecting one or more of the following:
4896  *
4897  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4898  *    'm' - memlog      was PERL_MEM_LOG=1
4899  *    's' - svlog       was PERL_SV_LOG=1
4900  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4901  *
4902  * This makes the logger controllable enough that it can reasonably be
4903  * added to the system perl.
4904  */
4905
4906 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4907  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4908  */
4909 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4910
4911 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4912  * writes to.  In the default logger, this is settable at runtime.
4913  */
4914 #ifndef PERL_MEM_LOG_FD
4915 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4916 #endif
4917
4918 #ifndef PERL_MEM_LOG_NOIMPL
4919
4920 # ifdef DEBUG_LEAKING_SCALARS
4921 #   define SV_LOG_SERIAL_FMT        " [%lu]"
4922 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
4923 # else
4924 #   define SV_LOG_SERIAL_FMT
4925 #   define _SV_LOG_SERIAL_ARG(sv)
4926 # endif
4927
4928 static void
4929 S_mem_log_common(enum mem_log_type mlt, const UV n, 
4930                  const UV typesize, const char *type_name, const SV *sv,
4931                  Malloc_t oldalloc, Malloc_t newalloc,
4932                  const char *filename, const int linenumber,
4933                  const char *funcname)
4934 {
4935     const char *pmlenv;
4936
4937     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4938
4939     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4940     if (!pmlenv)
4941         return;
4942     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4943     {
4944         /* We can't use SVs or PerlIO for obvious reasons,
4945          * so we'll use stdio and low-level IO instead. */
4946         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4947
4948 #   ifdef HAS_GETTIMEOFDAY
4949 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
4950 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
4951         struct timeval tv;
4952         gettimeofday(&tv, 0);
4953 #   else
4954 #     define MEM_LOG_TIME_FMT   "%10d: "
4955 #     define MEM_LOG_TIME_ARG   (int)when
4956         Time_t when;
4957         (void)time(&when);
4958 #   endif
4959         /* If there are other OS specific ways of hires time than
4960          * gettimeofday() (see dist/Time-HiRes), the easiest way is
4961          * probably that they would be used to fill in the struct
4962          * timeval. */
4963         {
4964             STRLEN len;
4965             const char* endptr;
4966             int fd;
4967             UV uv;
4968             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4969                 && uv && uv <= PERL_INT_MAX
4970             ) {
4971                 fd = (int)uv;
4972             } else {
4973                 fd = PERL_MEM_LOG_FD;
4974             }
4975
4976             if (strchr(pmlenv, 't')) {
4977                 len = my_snprintf(buf, sizeof(buf),
4978                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4979                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4980             }
4981             switch (mlt) {
4982             case MLT_ALLOC:
4983                 len = my_snprintf(buf, sizeof(buf),
4984                         "alloc: %s:%d:%s: %" IVdf " %" UVuf
4985                         " %s = %" IVdf ": %" UVxf "\n",
4986                         filename, linenumber, funcname, n, typesize,
4987                         type_name, n * typesize, PTR2UV(newalloc));
4988                 break;
4989             case MLT_REALLOC:
4990                 len = my_snprintf(buf, sizeof(buf),
4991                         "realloc: %s:%d:%s: %" IVdf " %" UVuf
4992                         " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
4993                         filename, linenumber, funcname, n, typesize,
4994                         type_name, n * typesize, PTR2UV(oldalloc),
4995                         PTR2UV(newalloc));
4996                 break;
4997             case MLT_FREE:
4998                 len = my_snprintf(buf, sizeof(buf),
4999                         "free: %s:%d:%s: %" UVxf "\n",
5000                         filename, linenumber, funcname,
5001                         PTR2UV(oldalloc));
5002                 break;
5003             case MLT_NEW_SV:
5004             case MLT_DEL_SV:
5005                 len = my_snprintf(buf, sizeof(buf),
5006                         "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
5007                         mlt == MLT_NEW_SV ? "new" : "del",
5008                         filename, linenumber, funcname,
5009                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5010                 break;
5011             default:
5012                 len = 0;
5013             }
5014             PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5015         }
5016     }
5017 }
5018 #endif /* !PERL_MEM_LOG_NOIMPL */
5019
5020 #ifndef PERL_MEM_LOG_NOIMPL
5021 # define \
5022     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5023     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5024 #else
5025 /* this is suboptimal, but bug compatible.  User is providing their
5026    own implementation, but is getting these functions anyway, and they
5027    do nothing. But _NOIMPL users should be able to cope or fix */
5028 # define \
5029     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5030     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5031 #endif
5032
5033 Malloc_t
5034 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5035                    Malloc_t newalloc, 
5036                    const char *filename, const int linenumber,
5037                    const char *funcname)
5038 {
5039     PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5040
5041     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5042                       NULL, NULL, newalloc,
5043                       filename, linenumber, funcname);
5044     return newalloc;
5045 }
5046
5047 Malloc_t
5048 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5049                      Malloc_t oldalloc, Malloc_t newalloc, 
5050                      const char *filename, const int linenumber, 
5051                      const char *funcname)
5052 {
5053     PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5054
5055     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5056                       NULL, oldalloc, newalloc, 
5057                       filename, linenumber, funcname);
5058     return newalloc;
5059 }
5060
5061 Malloc_t
5062 Perl_mem_log_free(Malloc_t oldalloc, 
5063                   const char *filename, const int linenumber, 
5064                   const char *funcname)
5065 {
5066     PERL_ARGS_ASSERT_MEM_LOG_FREE;