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