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