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