This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Import perl5321delta.pod
[perl5.git] / util.c
1 /*    util.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13  *  not content.'                                    --Gandalf to Pippin
14  *
15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16  */
17
18 /* This file contains assorted utility routines.
19  * Which is a polite way of saying any stuff that people couldn't think of
20  * a better place for. Amongst other things, it includes the warning and
21  * dieing stuff, plus wrappers for malloc code.
22  */
23
24 #include "EXTERN.h"
25 #define PERL_IN_UTIL_C
26 #include "perl.h"
27 #include "reentr.h"
28
29 #if defined(USE_PERLIO)
30 #include "perliol.h" /* For PerlIOUnix_refcnt */
31 #endif
32
33 #ifndef PERL_MICRO
34 #include <signal.h>
35 #ifndef SIG_ERR
36 # define SIG_ERR ((Sighandler_t) -1)
37 #endif
38 #endif
39
40 #include <math.h>
41 #include <stdlib.h>
42
43 #ifdef __Lynx__
44 /* Missing protos on LynxOS */
45 int putenv(char *);
46 #endif
47
48 #ifdef __amigaos__
49 # include "amigaos4/amigaio.h"
50 #endif
51
52 #ifdef HAS_SELECT
53 # ifdef I_SYS_SELECT
54 #  include <sys/select.h>
55 # endif
56 #endif
57
58 #ifdef USE_C_BACKTRACE
59 #  ifdef I_BFD
60 #    define USE_BFD
61 #    ifdef PERL_DARWIN
62 #      undef USE_BFD /* BFD is useless in OS X. */
63 #    endif
64 #    ifdef USE_BFD
65 #      include <bfd.h>
66 #    endif
67 #  endif
68 #  ifdef I_DLFCN
69 #    include <dlfcn.h>
70 #  endif
71 #  ifdef I_EXECINFO
72 #    include <execinfo.h>
73 #  endif
74 #endif
75
76 #ifdef PERL_DEBUG_READONLY_COW
77 # include <sys/mman.h>
78 #endif
79
80 #define FLUSH
81
82 /* NOTE:  Do not call the next three routines directly.  Use the macros
83  * in handy.h, so that we can easily redefine everything to do tracking of
84  * allocated hunks back to the original New to track down any memory leaks.
85  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
86  */
87
88 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
89 #  define ALWAYS_NEED_THX
90 #endif
91
92 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
93 static void
94 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
95 {
96     if (header->readonly
97      && mprotect(header, header->size, PROT_READ|PROT_WRITE))
98         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
99                          header, header->size, errno);
100 }
101
102 static void
103 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
104 {
105     if (header->readonly
106      && mprotect(header, header->size, PROT_READ))
107         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
108                          header, header->size, errno);
109 }
110 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
111 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
112 #else
113 # define maybe_protect_rw(foo) NOOP
114 # define maybe_protect_ro(foo) NOOP
115 #endif
116
117 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
118  /* Use memory_debug_header */
119 # define USE_MDH
120 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
121    || defined(PERL_DEBUG_READONLY_COW)
122 #  define MDH_HAS_SIZE
123 # endif
124 #endif
125
126 /*
127 =for apidoc_section $memory
128 =for apidoc safesysmalloc
129 Paranoid version of system's malloc()
130
131 =cut
132 */
133
134 Malloc_t
135 Perl_safesysmalloc(MEM_SIZE size)
136 {
137 #ifdef ALWAYS_NEED_THX
138     dTHX;
139 #endif
140     Malloc_t ptr;
141     dSAVEDERRNO;
142
143 #ifdef USE_MDH
144     if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
145         goto out_of_memory;
146     size += PERL_MEMORY_DEBUG_HEADER_SIZE;
147 #endif
148 #ifdef DEBUGGING
149     if ((SSize_t)size < 0)
150         Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
151 #endif
152     if (!size) size = 1;        /* malloc(0) is NASTY on our system */
153     SAVE_ERRNO;
154 #ifdef PERL_DEBUG_READONLY_COW
155     if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
156                     MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
157         perror("mmap failed");
158         abort();
159     }
160 #else
161     ptr = (Malloc_t)PerlMem_malloc(size);
162 #endif
163     PERL_ALLOC_CHECK(ptr);
164     if (ptr != NULL) {
165 #ifdef USE_MDH
166         struct perl_memory_debug_header *const header
167             = (struct perl_memory_debug_header *)ptr;
168 #endif
169
170 #ifdef PERL_POISON
171         PoisonNew(((char *)ptr), size, char);
172 #endif
173
174 #ifdef PERL_TRACK_MEMPOOL
175         header->interpreter = aTHX;
176         /* Link us into the list.  */
177         header->prev = &PL_memory_debug_header;
178         header->next = PL_memory_debug_header.next;
179         PL_memory_debug_header.next = header;
180         maybe_protect_rw(header->next);
181         header->next->prev = header;
182         maybe_protect_ro(header->next);
183 #  ifdef PERL_DEBUG_READONLY_COW
184         header->readonly = 0;
185 #  endif
186 #endif
187 #ifdef MDH_HAS_SIZE
188         header->size = size;
189 #endif
190         ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
191         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
192
193         /* malloc() can modify errno() even on success, but since someone
194            writing perl code doesn't have any control over when perl calls
195            malloc() we need to hide that.
196         */
197         RESTORE_ERRNO;
198     }
199     else {
200 #ifdef USE_MDH
201       out_of_memory:
202 #endif
203         {
204 #ifndef ALWAYS_NEED_THX
205             dTHX;
206 #endif
207             if (PL_nomemok)
208                 ptr =  NULL;
209             else
210                 croak_no_mem();
211         }
212     }
213     return ptr;
214 }
215
216 /*
217 =for apidoc safesysrealloc
218 Paranoid version of system's realloc()
219
220 =cut
221 */
222
223 Malloc_t
224 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
225 {
226 #ifdef ALWAYS_NEED_THX
227     dTHX;
228 #endif
229     Malloc_t ptr;
230 #ifdef PERL_DEBUG_READONLY_COW
231     const MEM_SIZE oldsize = where
232         ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
233         : 0;
234 #endif
235
236     if (!size) {
237         safesysfree(where);
238         ptr = NULL;
239     }
240     else if (!where) {
241         ptr = safesysmalloc(size);
242     }
243     else {
244         dSAVE_ERRNO;
245 #ifdef USE_MDH
246         where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
247         if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
248             goto out_of_memory;
249         size += PERL_MEMORY_DEBUG_HEADER_SIZE;
250         {
251             struct perl_memory_debug_header *const header
252                 = (struct perl_memory_debug_header *)where;
253
254 # ifdef PERL_TRACK_MEMPOOL
255             if (header->interpreter != aTHX) {
256                 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
257                                      header->interpreter, aTHX);
258             }
259             assert(header->next->prev == header);
260             assert(header->prev->next == header);
261 #  ifdef PERL_POISON
262             if (header->size > size) {
263                 const MEM_SIZE freed_up = header->size - size;
264                 char *start_of_freed = ((char *)where) + size;
265                 PoisonFree(start_of_freed, freed_up, char);
266             }
267 #  endif
268 # endif
269 # ifdef MDH_HAS_SIZE
270             header->size = size;
271 # endif
272         }
273 #endif
274 #ifdef DEBUGGING
275         if ((SSize_t)size < 0)
276             Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
277 #endif
278 #ifdef PERL_DEBUG_READONLY_COW
279         if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
280                         MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
281             perror("mmap failed");
282             abort();
283         }
284         Copy(where,ptr,oldsize < size ? oldsize : size,char);
285         if (munmap(where, oldsize)) {
286             perror("munmap failed");
287             abort();
288         }
289 #else
290         ptr = (Malloc_t)PerlMem_realloc(where,size);
291 #endif
292         PERL_ALLOC_CHECK(ptr);
293
294     /* MUST do this fixup first, before doing ANYTHING else, as anything else
295        might allocate memory/free/move memory, and until we do the fixup, it
296        may well be chasing (and writing to) free memory.  */
297         if (ptr != NULL) {
298 #ifdef PERL_TRACK_MEMPOOL
299             struct perl_memory_debug_header *const header
300                 = (struct perl_memory_debug_header *)ptr;
301
302 #  ifdef PERL_POISON
303             if (header->size < size) {
304                 const MEM_SIZE fresh = size - header->size;
305                 char *start_of_fresh = ((char *)ptr) + size;
306                 PoisonNew(start_of_fresh, fresh, char);
307             }
308 #  endif
309
310             maybe_protect_rw(header->next);
311             header->next->prev = header;
312             maybe_protect_ro(header->next);
313             maybe_protect_rw(header->prev);
314             header->prev->next = header;
315             maybe_protect_ro(header->prev);
316 #endif
317             ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
318
319             /* realloc() can modify errno() even on success, but since someone
320                writing perl code doesn't have any control over when perl calls
321                realloc() we need to hide that.
322             */
323             RESTORE_ERRNO;
324         }
325
326     /* In particular, must do that fixup above before logging anything via
327      *printf(), as it can reallocate memory, which can cause SEGVs.  */
328
329         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
330         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
331
332         if (ptr == NULL) {
333 #ifdef USE_MDH
334           out_of_memory:
335 #endif
336             {
337 #ifndef ALWAYS_NEED_THX
338                 dTHX;
339 #endif
340                 if (PL_nomemok)
341                     ptr = NULL;
342                 else
343                     croak_no_mem();
344             }
345         }
346     }
347     return ptr;
348 }
349
350 /*
351 =for apidoc safesysfree
352 Safe version of system's free()
353
354 =cut
355 */
356
357 Free_t
358 Perl_safesysfree(Malloc_t where)
359 {
360 #ifdef ALWAYS_NEED_THX
361     dTHX;
362 #endif
363     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
364     if (where) {
365 #ifdef USE_MDH
366         Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
367         {
368             struct perl_memory_debug_header *const header
369                 = (struct perl_memory_debug_header *)where_intrn;
370
371 # ifdef MDH_HAS_SIZE
372             const MEM_SIZE size = header->size;
373 # endif
374 # ifdef PERL_TRACK_MEMPOOL
375             if (header->interpreter != aTHX) {
376                 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
377                                      header->interpreter, aTHX);
378             }
379             if (!header->prev) {
380                 Perl_croak_nocontext("panic: duplicate free");
381             }
382             if (!(header->next))
383                 Perl_croak_nocontext("panic: bad free, header->next==NULL");
384             if (header->next->prev != header || header->prev->next != header) {
385                 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
386                                      "header=%p, ->prev->next=%p",
387                                      header->next->prev, header,
388                                      header->prev->next);
389             }
390             /* Unlink us from the chain.  */
391             maybe_protect_rw(header->next);
392             header->next->prev = header->prev;
393             maybe_protect_ro(header->next);
394             maybe_protect_rw(header->prev);
395             header->prev->next = header->next;
396             maybe_protect_ro(header->prev);
397             maybe_protect_rw(header);
398 #  ifdef PERL_POISON
399             PoisonNew(where_intrn, size, char);
400 #  endif
401             /* Trigger the duplicate free warning.  */
402             header->next = NULL;
403 # endif
404 # ifdef PERL_DEBUG_READONLY_COW
405             if (munmap(where_intrn, size)) {
406                 perror("munmap failed");
407                 abort();
408             }   
409 # endif
410         }
411 #else
412         Malloc_t where_intrn = where;
413 #endif /* USE_MDH */
414 #ifndef PERL_DEBUG_READONLY_COW
415         PerlMem_free(where_intrn);
416 #endif
417     }
418 }
419
420 /*
421 =for apidoc safesyscalloc
422 Safe version of system's calloc()
423
424 =cut
425 */
426
427 Malloc_t
428 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
429 {
430 #ifdef ALWAYS_NEED_THX
431     dTHX;
432 #endif
433     Malloc_t ptr;
434 #if defined(USE_MDH) || defined(DEBUGGING)
435     MEM_SIZE total_size = 0;
436 #endif
437
438     /* Even though calloc() for zero bytes is strange, be robust. */
439     if (size && (count <= MEM_SIZE_MAX / size)) {
440 #if defined(USE_MDH) || defined(DEBUGGING)
441         total_size = size * count;
442 #endif
443     }
444     else
445         croak_memory_wrap();
446 #ifdef USE_MDH
447     if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
448         total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
449     else
450         croak_memory_wrap();
451 #endif
452 #ifdef DEBUGGING
453     if ((SSize_t)size < 0 || (SSize_t)count < 0)
454         Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
455                              (UV)size, (UV)count);
456 #endif
457 #ifdef PERL_DEBUG_READONLY_COW
458     if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
459                     MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
460         perror("mmap failed");
461         abort();
462     }
463 #elif defined(PERL_TRACK_MEMPOOL)
464     /* Have to use malloc() because we've added some space for our tracking
465        header.  */
466     /* malloc(0) is non-portable. */
467     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
468 #else
469     /* Use calloc() because it might save a memset() if the memory is fresh
470        and clean from the OS.  */
471     if (count && size)
472         ptr = (Malloc_t)PerlMem_calloc(count, size);
473     else /* calloc(0) is non-portable. */
474         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
475 #endif
476     PERL_ALLOC_CHECK(ptr);
477     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
478     if (ptr != NULL) {
479 #ifdef USE_MDH
480         {
481             struct perl_memory_debug_header *const header
482                 = (struct perl_memory_debug_header *)ptr;
483
484 #  ifndef PERL_DEBUG_READONLY_COW
485             memset((void*)ptr, 0, total_size);
486 #  endif
487 #  ifdef PERL_TRACK_MEMPOOL
488             header->interpreter = aTHX;
489             /* Link us into the list.  */
490             header->prev = &PL_memory_debug_header;
491             header->next = PL_memory_debug_header.next;
492             PL_memory_debug_header.next = header;
493             maybe_protect_rw(header->next);
494             header->next->prev = header;
495             maybe_protect_ro(header->next);
496 #    ifdef PERL_DEBUG_READONLY_COW
497             header->readonly = 0;
498 #    endif
499 #  endif
500 #  ifdef MDH_HAS_SIZE
501             header->size = total_size;
502 #  endif
503             ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
504         }
505 #endif
506         return ptr;
507     }
508     else {
509 #ifndef ALWAYS_NEED_THX
510         dTHX;
511 #endif
512         if (PL_nomemok)
513             return NULL;
514         croak_no_mem();
515     }
516 }
517
518 /* These must be defined when not using Perl's malloc for binary
519  * compatibility */
520
521 #ifndef MYMALLOC
522
523 Malloc_t Perl_malloc (MEM_SIZE nbytes)
524 {
525 #ifdef PERL_IMPLICIT_SYS
526     dTHX;
527 #endif
528     return (Malloc_t)PerlMem_malloc(nbytes);
529 }
530
531 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
532 {
533 #ifdef PERL_IMPLICIT_SYS
534     dTHX;
535 #endif
536     return (Malloc_t)PerlMem_calloc(elements, size);
537 }
538
539 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
540 {
541 #ifdef PERL_IMPLICIT_SYS
542     dTHX;
543 #endif
544     return (Malloc_t)PerlMem_realloc(where, nbytes);
545 }
546
547 Free_t   Perl_mfree (Malloc_t where)
548 {
549 #ifdef PERL_IMPLICIT_SYS
550     dTHX;
551 #endif
552     PerlMem_free(where);
553 }
554
555 #endif
556
557 /* This is the value stored in *retlen in the two delimcpy routines below when
558  * there wasn't enough room in the destination to store everything it was asked
559  * to.  The value is deliberately very large so that hopefully if code uses it
560  * unquestioninly to access memory, it will likely segfault.  And it is small
561  * enough that if the caller does some arithmetic on it before accessing, it
562  * won't overflow into a small legal number. */
563 #define DELIMCPY_OUT_OF_BOUNDS_RET  I32_MAX
564
565 /*
566 =for apidoc_section $string
567 =for apidoc delimcpy_no_escape
568
569 Copy a source buffer to a destination buffer, stopping at (but not including)
570 the first occurrence in the source of the delimiter byte, C<delim>.  The source
571 is the bytes between S<C<from> and C<from_end> - 1>.  Similarly, the dest is
572 C<to> up to C<to_end>.
573
574 The number of bytes copied is written to C<*retlen>.
575
576 Returns the position of C<delim> in the C<from> buffer, but if there is no
577 such occurrence before C<from_end>, then C<from_end> is returned, and the entire
578 buffer S<C<from> .. C<from_end> - 1> is copied.
579
580 If there is room in the destination available after the copy, an extra
581 terminating safety C<NUL> byte is appended (not included in the returned
582 length).
583
584 The error case is if the destination buffer is not large enough to accommodate
585 everything that should be copied.  In this situation, a value larger than
586 S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
587 fits will be written to the destination.  Not having room for the safety C<NUL>
588 is not considered an error.
589
590 =cut
591 */
592 char *
593 Perl_delimcpy_no_escape(char *to, const char *to_end,
594                         const char *from, const char *from_end,
595                         const int delim, I32 *retlen)
596 {
597     const char * delim_pos;
598     Ptrdiff_t from_len = from_end - from;
599     Ptrdiff_t to_len = to_end - to;
600     SSize_t copy_len;
601
602     PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
603
604     assert(from_len >= 0);
605     assert(to_len >= 0);
606
607     /* Look for the first delimiter in the source */
608     delim_pos = (const char *) memchr(from, delim, from_len);
609
610     /* Copy up to where the delimiter was found, or the entire buffer if not
611      * found */
612     copy_len = (delim_pos) ? delim_pos - from : from_len;
613
614     /* If not enough room, copy as much as can fit, and set error return */
615     if (copy_len > to_len) {
616         Copy(from, to, to_len, char);
617         *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
618     }
619     else {
620         Copy(from, to, copy_len, char);
621
622         /* If there is extra space available, add a trailing NUL */
623         if (copy_len < to_len) {
624             to[copy_len] = '\0';
625         }
626
627         *retlen = copy_len;
628     }
629
630     return (char *) from + copy_len;
631 }
632
633 /*
634 =for apidoc delimcpy
635
636 Copy a source buffer to a destination buffer, stopping at (but not including)
637 the first occurrence in the source of an unescaped (defined below) delimiter
638 byte, C<delim>.  The source is the bytes between S<C<from> and C<from_end> -
639 1>.  Similarly, the dest is C<to> up to C<to_end>.
640
641 The number of bytes copied is written to C<*retlen>.
642
643 Returns the position of the first uncopied C<delim> in the C<from> buffer, but
644 if there is no such occurrence before C<from_end>, then C<from_end> is returned,
645 and the entire buffer S<C<from> .. C<from_end> - 1> is copied.
646
647 If there is room in the destination available after the copy, an extra
648 terminating safety C<NUL> byte is appended (not included in the returned
649 length).
650
651 The error case is if the destination buffer is not large enough to accommodate
652 everything that should be copied.  In this situation, a value larger than
653 S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
654 fits will be written to the destination.  Not having room for the safety C<NUL>
655 is not considered an error.
656
657 In the following examples, let C<x> be the delimiter, and C<0> represent a C<NUL>
658 byte (B<NOT> the digit C<0>).  Then we would have
659
660   Source     Destination
661  abcxdef        abc0
662
663 provided the destination buffer is at least 4 bytes long.
664
665 An escaped delimiter is one which is immediately preceded by a single
666 backslash.  Escaped delimiters are copied, and the copy continues past the
667 delimiter; the backslash is not copied:
668
669   Source       Destination
670  abc\xdef       abcxdef0
671
672 (provided the destination buffer is at least 8 bytes long).
673
674 It's actually somewhat more complicated than that. A sequence of any odd number
675 of backslashes escapes the following delimiter, and the copy continues with
676 exactly one of the backslashes stripped.
677
678      Source         Destination
679      abc\xdef          abcxdef0
680    abc\\\xdef        abc\\xdef0
681  abc\\\\\xdef      abc\\\\xdef0
682
683 (as always, if the destination is large enough)
684
685 An even number of preceding backslashes does not escape the delimiter, so that
686 the copy stops just before it, and includes all the backslashes (no stripping;
687 zero is considered even):
688
689       Source         Destination
690       abcxdef          abc0
691     abc\\xdef          abc\\0
692   abc\\\\xdef          abc\\\\0
693
694 =cut
695 */
696
697 char *
698 Perl_delimcpy(char *to, const char *to_end,
699               const char *from, const char *from_end,
700               const int delim, I32 *retlen)
701 {
702     const char * const orig_to = to;
703     Ptrdiff_t copy_len = 0;
704     bool stopped_early = FALSE;     /* Ran out of room to copy to */
705
706     PERL_ARGS_ASSERT_DELIMCPY;
707     assert(from_end >= from);
708     assert(to_end >= to);
709
710     /* Don't use the loop for the trivial case of the first character being the
711      * delimiter; otherwise would have to worry inside the loop about backing
712      * up before the start of 'from' */
713     if (LIKELY(from_end > from && *from != delim)) {
714         while ((copy_len = from_end - from) > 0) {
715             const char * backslash_pos;
716             const char * delim_pos;
717
718             /* Look for the next delimiter in the remaining portion of the
719              * source. A loop invariant is that we already know that the copy
720              * should include *from; this comes from the conditional before the
721              * loop, and how we set things up at the end of each iteration */
722             delim_pos = (const char *) memchr(from + 1, delim, copy_len - 1);
723
724             /* If didn't find it, done looking; set up so copies all of the
725              * source */
726             if (! delim_pos) {
727                 copy_len = from_end - from;
728                 break;
729             }
730
731             /* Look for a backslash immediately before the delimiter */
732             backslash_pos = delim_pos - 1;
733
734             /* If the delimiter is not escaped, this ends the copy */
735             if (*backslash_pos != '\\') {
736                 copy_len = delim_pos - from;
737                 break;
738             }
739
740             /* Here there is a backslash just before the delimiter, but it
741              * could be the final backslash in a sequence of them.  Backup to
742              * find the first one in it. */
743             do {
744                 backslash_pos--;
745             }
746             while (backslash_pos >= from && *backslash_pos == '\\');
747
748             /* If the number of backslashes is even, they just escape one
749              * another, leaving the delimiter unescaped, and stopping the copy.
750              * */
751             if (! ((delim_pos - (backslash_pos + 1)) & 1)) {
752                 copy_len = delim_pos - from;  /* even, copy up to delimiter */
753                 break;
754             }
755
756             /* Here is odd, so the delimiter is escaped.  We will try to copy
757              * all but the final backslash in the sequence */
758             copy_len = delim_pos - 1 - from;
759
760             /* Do the copy, but not beyond the end of the destination */
761             if (copy_len >= to_end - to) {
762                 Copy(from, to, to_end - to, char);
763                 stopped_early = TRUE;
764                 to = (char *) to_end;
765             }
766             else {
767                 Copy(from, to, copy_len, char);
768                 to += copy_len;
769             }
770
771             /* Set up so next iteration will include the delimiter */
772             from = delim_pos;
773         }
774     }
775
776     /* Here, have found the final segment to copy.  Copy that, but not beyond
777      * the size of the destination.  If not enough room, copy as much as can
778      * fit, and set error return */
779     if (stopped_early || copy_len > to_end - to) {
780         Copy(from, to, to_end - to, char);
781         *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
782     }
783     else {
784         Copy(from, to, copy_len, char);
785
786         to += copy_len;
787
788         /* If there is extra space available, add a trailing NUL */
789         if (to < to_end) {
790             *to = '\0';
791         }
792
793         *retlen = to - orig_to;
794     }
795
796     return (char *) from + copy_len;
797 }
798
799 /*
800 =for apidoc ninstr
801
802 Find the first (leftmost) occurrence of a sequence of bytes within another
803 sequence.  This is the Perl version of C<strstr()>, extended to handle
804 arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
805 is what the initial C<n> in the function name stands for; some systems have an
806 equivalent, C<memmem()>, but with a somewhat different API).
807
808 Another way of thinking about this function is finding a needle in a haystack.
809 C<big> points to the first byte in the haystack.  C<big_end> points to one byte
810 beyond the final byte in the haystack.  C<little> points to the first byte in
811 the needle.  C<little_end> points to one byte beyond the final byte in the
812 needle.  All the parameters must be non-C<NULL>.
813
814 The function returns C<NULL> if there is no occurrence of C<little> within
815 C<big>.  If C<little> is the empty string, C<big> is returned.
816
817 Because this function operates at the byte level, and because of the inherent
818 characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
819 needle and the haystack are strings with the same UTF-8ness, but not if the
820 UTF-8ness differs.
821
822 =cut
823
824 */
825
826 char *
827 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
828 {
829     PERL_ARGS_ASSERT_NINSTR;
830
831 #ifdef HAS_MEMMEM
832     return ninstr(big, bigend, little, lend);
833 #else
834
835     if (little >= lend) {
836         return (char*) big;
837     }
838     else {
839         const U8 first = *little;
840         Size_t lsize;
841
842         /* No match can start closer to the end of the haystack than the length
843          * of the needle. */
844         bigend -= lend - little;
845         little++;       /* Look for 'first', then the remainder is in here */
846         lsize = lend - little;
847
848         while (big <= bigend) {
849             big = (char *) memchr((U8 *) big, first, bigend - big + 1);
850             if (big == NULL || big > bigend) {
851                 return NULL;
852             }
853
854             if (memEQ(big + 1, little, lsize)) {
855                 return (char*) big;
856             }
857             big++;
858         }
859     }
860
861     return NULL;
862
863 #endif
864
865 }
866
867 /*
868 =for apidoc rninstr
869
870 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
871 sequence of bytes within another sequence, returning C<NULL> if there is no
872 such occurrence.
873
874 =cut
875
876 */
877
878 char *
879 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
880 {
881     const Ptrdiff_t little_len = lend - little;
882     const Ptrdiff_t big_len = bigend - big;
883
884     PERL_ARGS_ASSERT_RNINSTR;
885
886     /* A non-existent needle trivially matches the rightmost possible position
887      * in the haystack */
888     if (UNLIKELY(little_len <= 0)) {
889         return (char*)bigend;
890     }
891
892     /* If the needle is larger than the haystack, the needle can't possibly fit
893      * inside the haystack. */
894     if (UNLIKELY(little_len > big_len)) {
895         return NULL;
896     }
897
898     /* Special case length 1 needles.  It's trivial if we have memrchr();
899      * and otherwise we just do a per-byte search backwards.
900      *
901      * XXX When we don't have memrchr, we could use something like
902      * S_find_next_masked( or S_find_span_end() to do per-word searches */
903     if (little_len == 1) {
904         const char final = *little;
905
906 #ifdef HAS_MEMRCHR
907
908         return (char *) memrchr(big, final, big_len);
909 #else
910         const char * cur = bigend - 1;
911
912         do {
913             if (*cur == final) {
914                 return (char *) cur;
915             }
916         } while (--cur >= big);
917
918         return NULL;
919 #endif
920
921     }
922     else {  /* Below, the needle is longer than a single byte */
923
924         /* We search backwards in the haystack for the final character of the
925          * needle.  Each time one is found, we see if the characters just
926          * before it in the haystack match the rest of the needle. */
927         const char final = *(lend - 1);
928
929         /* What matches consists of 'little_len'-1 characters, then the final
930          * one */
931         const Size_t prefix_len = little_len - 1;
932
933         /* If the final character in the needle is any closer than this to the
934          * left edge, there wouldn't be enough room for all of it to fit in the
935          * haystack */
936         const char * const left_fence = big + prefix_len;
937
938         /* Start at the right edge */
939         char * cur = (char *) bigend;
940
941         /* memrchr() makes the search easy (and fast); otherwise, look
942          * backwards byte-by-byte. */
943         do {
944
945 #ifdef HAS_MEMRCHR
946
947             cur = (char *) memrchr(left_fence, final, cur - left_fence);
948             if (cur == NULL) {
949                 return NULL;
950             }
951 #else
952             do {
953                 cur--;
954                 if (cur < left_fence) {
955                     return NULL;
956                 }
957             }
958             while (*cur != final);
959 #endif
960
961             /* Here, we know that *cur is 'final'; see if the preceding bytes
962              * of the needle also match the corresponding haystack bytes */
963             if memEQ(cur - prefix_len, little, prefix_len) {
964                 return cur - prefix_len;
965             }
966         } while (cur > left_fence);
967
968         return NULL;
969     }
970 }
971
972 /* As a space optimization, we do not compile tables for strings of length
973    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
974    special-cased in fbm_instr().
975
976    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
977
978 /*
979
980 =for apidoc fbm_compile
981
982 Analyzes the string in order to make fast searches on it using C<fbm_instr()>
983 -- the Boyer-Moore algorithm.
984
985 =cut
986 */
987
988 void
989 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
990 {
991     const U8 *s;
992     STRLEN i;
993     STRLEN len;
994     MAGIC *mg;
995
996     PERL_ARGS_ASSERT_FBM_COMPILE;
997
998     if (isGV_with_GP(sv) || SvROK(sv))
999         return;
1000
1001     if (SvVALID(sv))
1002         return;
1003
1004     if (flags & FBMcf_TAIL) {
1005         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
1006         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
1007         if (mg && mg->mg_len >= 0)
1008             mg->mg_len++;
1009     }
1010     if (!SvPOK(sv) || SvNIOKp(sv))
1011         s = (U8*)SvPV_force_mutable(sv, len);
1012     else s = (U8 *)SvPV_mutable(sv, len);
1013     if (len == 0)               /* TAIL might be on a zero-length string. */
1014         return;
1015     SvUPGRADE(sv, SVt_PVMG);
1016     SvIOK_off(sv);
1017     SvNOK_off(sv);
1018
1019     /* add PERL_MAGIC_bm magic holding the FBM lookup table */
1020
1021     assert(!mg_find(sv, PERL_MAGIC_bm));
1022     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
1023     assert(mg);
1024
1025     if (len > 2) {
1026         /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
1027            the BM table.  */
1028         const U8 mlen = (len>255) ? 255 : (U8)len;
1029         const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
1030         U8 *table;
1031
1032         Newx(table, 256, U8);
1033         memset((void*)table, mlen, 256);
1034         mg->mg_ptr = (char *)table;
1035         mg->mg_len = 256;
1036
1037         s += len - 1; /* last char */
1038         i = 0;
1039         while (s >= sb) {
1040             if (table[*s] == mlen)
1041                 table[*s] = (U8)i;
1042             s--, i++;
1043         }
1044     }
1045
1046     BmUSEFUL(sv) = 100;                 /* Initial value */
1047     ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
1048 }
1049
1050
1051 /*
1052 =for apidoc fbm_instr
1053
1054 Returns the location of the SV in the string delimited by C<big> and
1055 C<bigend> (C<bigend>) is the char following the last char).
1056 It returns C<NULL> if the string can't be found.  The C<sv>
1057 does not have to be C<fbm_compiled>, but the search will not be as fast
1058 then.
1059
1060 =cut
1061
1062 If SvTAIL(littlestr) is true, a fake "\n" was appended to the string
1063 during FBM compilation due to FBMcf_TAIL in flags. It indicates that
1064 the littlestr must be anchored to the end of bigstr (or to any \n if
1065 FBMrf_MULTILINE).
1066
1067 E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
1068 while /abc$/ compiles to "abc\n" with SvTAIL() true.
1069
1070 A littlestr of "abc", !SvTAIL matches as /abc/;
1071 a littlestr of "ab\n", SvTAIL matches as:
1072    without FBMrf_MULTILINE: /ab\n?\z/
1073    with    FBMrf_MULTILINE: /ab\n/ || /ab\z/;
1074
1075 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
1076   "If SvTAIL is actually due to \Z or \z, this gives false positives
1077   if multiline".
1078 */
1079
1080
1081 char *
1082 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
1083 {
1084     unsigned char *s;
1085     STRLEN l;
1086     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
1087     STRLEN littlelen = l;
1088     const I32 multiline = flags & FBMrf_MULTILINE;
1089     bool valid = SvVALID(littlestr);
1090     bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
1091
1092     PERL_ARGS_ASSERT_FBM_INSTR;
1093
1094     assert(bigend >= big);
1095
1096     if ((STRLEN)(bigend - big) < littlelen) {
1097         if (     tail
1098              && ((STRLEN)(bigend - big) == littlelen - 1)
1099              && (littlelen == 1
1100                  || (*big == *little &&
1101                      memEQ((char *)big, (char *)little, littlelen - 1))))
1102             return (char*)big;
1103         return NULL;
1104     }
1105
1106     switch (littlelen) { /* Special cases for 0, 1 and 2  */
1107     case 0:
1108         return (char*)big;              /* Cannot be SvTAIL! */
1109
1110     case 1:
1111             if (tail && !multiline) /* Anchor only! */
1112                 /* [-1] is safe because we know that bigend != big.  */
1113                 return (char *) (bigend - (bigend[-1] == '\n'));
1114
1115             s = (unsigned char *)memchr((void*)big, *little, bigend-big);
1116             if (s)
1117                 return (char *)s;
1118             if (tail)
1119                 return (char *) bigend;
1120             return NULL;
1121
1122     case 2:
1123         if (tail && !multiline) {
1124             /* a littlestr with SvTAIL must be of the form "X\n" (where X
1125              * is a single char). It is anchored, and can only match
1126              * "....X\n"  or  "....X" */
1127             if (bigend[-2] == *little && bigend[-1] == '\n')
1128                 return (char*)bigend - 2;
1129             if (bigend[-1] == *little)
1130                 return (char*)bigend - 1;
1131             return NULL;
1132         }
1133
1134         {
1135             /* memchr() is likely to be very fast, possibly using whatever
1136              * hardware support is available, such as checking a whole
1137              * cache line in one instruction.
1138              * So for a 2 char pattern, calling memchr() is likely to be
1139              * faster than running FBM, or rolling our own. The previous
1140              * version of this code was roll-your-own which typically
1141              * only needed to read every 2nd char, which was good back in
1142              * the day, but no longer.
1143              */
1144             unsigned char c1 = little[0];
1145             unsigned char c2 = little[1];
1146
1147             /* *** for all this case, bigend points to the last char,
1148              * not the trailing \0: this makes the conditions slightly
1149              * simpler */
1150             bigend--;
1151             s = big;
1152             if (c1 != c2) {
1153                 while (s < bigend) {
1154                     /* do a quick test for c1 before calling memchr();
1155                      * this avoids the expensive fn call overhead when
1156                      * there are lots of c1's */
1157                     if (LIKELY(*s != c1)) {
1158                         s++;
1159                         s = (unsigned char *)memchr((void*)s, c1, bigend - s);
1160                         if (!s)
1161                             break;
1162                     }
1163                     if (s[1] == c2)
1164                         return (char*)s;
1165
1166                     /* failed; try searching for c2 this time; that way
1167                      * we don't go pathologically slow when the string
1168                      * consists mostly of c1's or vice versa.
1169                      */
1170                     s += 2;
1171                     if (s > bigend)
1172                         break;
1173                     s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
1174                     if (!s)
1175                         break;
1176                     if (s[-1] == c1)
1177                         return (char*)s - 1;
1178                 }
1179             }
1180             else {
1181                 /* c1, c2 the same */
1182                 while (s < bigend) {
1183                     if (s[0] == c1) {
1184                       got_1char:
1185                         if (s[1] == c1)
1186                             return (char*)s;
1187                         s += 2;
1188                     }
1189                     else {
1190                         s++;
1191                         s = (unsigned char *)memchr((void*)s, c1, bigend - s);
1192                         if (!s || s >= bigend)
1193                             break;
1194                         goto got_1char;
1195                     }
1196                 }
1197             }
1198
1199             /* failed to find 2 chars; try anchored match at end without
1200              * the \n */
1201             if (tail && bigend[0] == little[0])
1202                 return (char *)bigend;
1203             return NULL;
1204         }
1205
1206     default:
1207         break; /* Only lengths 0 1 and 2 have special-case code.  */
1208     }
1209
1210     if (tail && !multiline) {   /* tail anchored? */
1211         s = bigend - littlelen;
1212         if (s >= big && bigend[-1] == '\n' && *s == *little
1213             /* Automatically of length > 2 */
1214             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1215         {
1216             return (char*)s;            /* how sweet it is */
1217         }
1218         if (s[1] == *little
1219             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
1220         {
1221             return (char*)s + 1;        /* how sweet it is */
1222         }
1223         return NULL;
1224     }
1225
1226     if (!valid) {
1227         /* not compiled; use Perl_ninstr() instead */
1228         char * const b = ninstr((char*)big,(char*)bigend,
1229                          (char*)little, (char*)little + littlelen);
1230
1231         assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
1232         return b;
1233     }
1234
1235     /* Do actual FBM.  */
1236     if (littlelen > (STRLEN)(bigend - big))
1237         return NULL;
1238
1239     {
1240         const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
1241         const unsigned char *oldlittle;
1242
1243         assert(mg);
1244
1245         --littlelen;                    /* Last char found by table lookup */
1246
1247         s = big + littlelen;
1248         little += littlelen;            /* last char */
1249         oldlittle = little;
1250         if (s < bigend) {
1251             const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
1252             const unsigned char lastc = *little;
1253             I32 tmp;
1254
1255           top2:
1256             if ((tmp = table[*s])) {
1257                 /* *s != lastc; earliest position it could match now is
1258                  * tmp slots further on */
1259                 if ((s += tmp) >= bigend)
1260                     goto check_end;
1261                 if (LIKELY(*s != lastc)) {
1262                     s++;
1263                     s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
1264                     if (!s) {
1265                         s = bigend;
1266                         goto check_end;
1267                     }
1268                     goto top2;
1269                 }
1270             }
1271
1272
1273             /* hand-rolled strncmp(): less expensive than calling the
1274              * real function (maybe???) */
1275             {
1276                 unsigned char * const olds = s;
1277
1278                 tmp = littlelen;
1279
1280                 while (tmp--) {
1281                     if (*--s == *--little)
1282                         continue;
1283                     s = olds + 1;       /* here we pay the price for failure */
1284                     little = oldlittle;
1285                     if (s < bigend)     /* fake up continue to outer loop */
1286                         goto top2;
1287                     goto check_end;
1288                 }
1289                 return (char *)s;
1290             }
1291         }
1292       check_end:
1293         if ( s == bigend
1294              && tail
1295              && memEQ((char *)(bigend - littlelen),
1296                       (char *)(oldlittle - littlelen), littlelen) )
1297             return (char*)bigend - littlelen;
1298         return NULL;
1299     }
1300 }
1301
1302 const char *
1303 Perl_cntrl_to_mnemonic(const U8 c)
1304 {
1305     /* Returns the mnemonic string that represents character 'c', if one
1306      * exists; NULL otherwise.  The only ones that exist for the purposes of
1307      * this routine are a few control characters */
1308
1309     switch (c) {
1310         case '\a':       return "\\a";
1311         case '\b':       return "\\b";
1312         case ESC_NATIVE: return "\\e";
1313         case '\f':       return "\\f";
1314         case '\n':       return "\\n";
1315         case '\r':       return "\\r";
1316         case '\t':       return "\\t";
1317     }
1318
1319     return NULL;
1320 }
1321
1322 /* copy a string to a safe spot */
1323
1324 /*
1325 =for apidoc_section $string
1326 =for apidoc savepv
1327
1328 Perl's version of C<strdup()>.  Returns a pointer to a newly allocated
1329 string which is a duplicate of C<pv>.  The size of the string is
1330 determined by C<strlen()>, which means it may not contain embedded C<NUL>
1331 characters and must have a trailing C<NUL>.  To prevent memory leaks, the
1332 memory allocated for the new string needs to be freed when no longer needed.
1333 This can be done with the C<L</Safefree>> function, or
1334 L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
1335
1336 On some platforms, Windows for example, all allocated memory owned by a thread
1337 is deallocated when that thread ends.  So if you need that not to happen, you
1338 need to use the shared memory functions, such as C<L</savesharedpv>>.
1339
1340 =cut
1341 */
1342
1343 char *
1344 Perl_savepv(pTHX_ const char *pv)
1345 {
1346     PERL_UNUSED_CONTEXT;
1347     if (!pv)
1348         return NULL;
1349     else {
1350         char *newaddr;
1351         const STRLEN pvlen = strlen(pv)+1;
1352         Newx(newaddr, pvlen, char);
1353         return (char*)memcpy(newaddr, pv, pvlen);
1354     }
1355 }
1356
1357 /* same thing but with a known length */
1358
1359 /*
1360 =for apidoc savepvn
1361
1362 Perl's version of what C<strndup()> would be if it existed.  Returns a
1363 pointer to a newly allocated string which is a duplicate of the first
1364 C<len> bytes from C<pv>, plus a trailing
1365 C<NUL> byte.  The memory allocated for
1366 the new string can be freed with the C<Safefree()> function.
1367
1368 On some platforms, Windows for example, all allocated memory owned by a thread
1369 is deallocated when that thread ends.  So if you need that not to happen, you
1370 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1371
1372 =cut
1373 */
1374
1375 char *
1376 Perl_savepvn(pTHX_ const char *pv, Size_t len)
1377 {
1378     char *newaddr;
1379     PERL_UNUSED_CONTEXT;
1380
1381     Newx(newaddr,len+1,char);
1382     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1383     if (pv) {
1384         /* might not be null terminated */
1385         newaddr[len] = '\0';
1386         return (char *) CopyD(pv,newaddr,len,char);
1387     }
1388     else {
1389         return (char *) ZeroD(newaddr,len+1,char);
1390     }
1391 }
1392
1393 /*
1394 =for apidoc savesharedpv
1395
1396 A version of C<savepv()> which allocates the duplicate string in memory
1397 which is shared between threads.
1398
1399 =cut
1400 */
1401 char *
1402 Perl_savesharedpv(pTHX_ const char *pv)
1403 {
1404     char *newaddr;
1405     STRLEN pvlen;
1406
1407     PERL_UNUSED_CONTEXT;
1408
1409     if (!pv)
1410         return NULL;
1411
1412     pvlen = strlen(pv)+1;
1413     newaddr = (char*)PerlMemShared_malloc(pvlen);
1414     if (!newaddr) {
1415         croak_no_mem();
1416     }
1417     return (char*)memcpy(newaddr, pv, pvlen);
1418 }
1419
1420 /*
1421 =for apidoc savesharedpvn
1422
1423 A version of C<savepvn()> which allocates the duplicate string in memory
1424 which is shared between threads.  (With the specific difference that a C<NULL>
1425 pointer is not acceptable)
1426
1427 =cut
1428 */
1429 char *
1430 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1431 {
1432     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1433
1434     PERL_UNUSED_CONTEXT;
1435     /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1436
1437     if (!newaddr) {
1438         croak_no_mem();
1439     }
1440     newaddr[len] = '\0';
1441     return (char*)memcpy(newaddr, pv, len);
1442 }
1443
1444 /*
1445 =for apidoc savesvpv
1446
1447 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1448 the passed in SV using C<SvPV()>
1449
1450 On some platforms, Windows for example, all allocated memory owned by a thread
1451 is deallocated when that thread ends.  So if you need that not to happen, you
1452 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1453
1454 =cut
1455 */
1456
1457 char *
1458 Perl_savesvpv(pTHX_ SV *sv)
1459 {
1460     STRLEN len;
1461     const char * const pv = SvPV_const(sv, len);
1462     char *newaddr;
1463
1464     PERL_ARGS_ASSERT_SAVESVPV;
1465
1466     ++len;
1467     Newx(newaddr,len,char);
1468     return (char *) CopyD(pv,newaddr,len,char);
1469 }
1470
1471 /*
1472 =for apidoc savesharedsvpv
1473
1474 A version of C<savesharedpv()> which allocates the duplicate string in
1475 memory which is shared between threads.
1476
1477 =cut
1478 */
1479
1480 char *
1481 Perl_savesharedsvpv(pTHX_ SV *sv)
1482 {
1483     STRLEN len;
1484     const char * const pv = SvPV_const(sv, len);
1485
1486     PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1487
1488     return savesharedpvn(pv, len);
1489 }
1490
1491 /* the SV for Perl_form() and mess() is not kept in an arena */
1492
1493 STATIC SV *
1494 S_mess_alloc(pTHX)
1495 {
1496     SV *sv;
1497     XPVMG *any;
1498
1499     if (PL_phase != PERL_PHASE_DESTRUCT)
1500         return newSVpvs_flags("", SVs_TEMP);
1501
1502     if (PL_mess_sv)
1503         return PL_mess_sv;
1504
1505     /* Create as PVMG now, to avoid any upgrading later */
1506     Newx(sv, 1, SV);
1507     Newxz(any, 1, XPVMG);
1508     SvFLAGS(sv) = SVt_PVMG;
1509     SvANY(sv) = (void*)any;
1510     SvPV_set(sv, NULL);
1511     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1512     PL_mess_sv = sv;
1513     return sv;
1514 }
1515
1516 #if defined(PERL_IMPLICIT_CONTEXT)
1517 char *
1518 Perl_form_nocontext(const char* pat, ...)
1519 {
1520     dTHX;
1521     char *retval;
1522     va_list args;
1523     PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1524     va_start(args, pat);
1525     retval = vform(pat, &args);
1526     va_end(args);
1527     return retval;
1528 }
1529 #endif /* PERL_IMPLICIT_CONTEXT */
1530
1531 /*
1532 =for apidoc_section $display
1533 =for apidoc form
1534 =for apidoc_item form_nocontext
1535
1536 These take a sprintf-style format pattern and conventional
1537 (non-SV) arguments and return the formatted string.
1538
1539     (char *) Perl_form(pTHX_ const char* pat, ...)
1540
1541 can be used any place a string (char *) is required:
1542
1543     char * s = Perl_form("%d.%d",major,minor);
1544
1545 They use a single private buffer so if you want to format several strings you
1546 must explicitly copy the earlier strings away (and free the copies when you
1547 are done).
1548
1549 The two forms differ only in that C<form_nocontext> does not take a thread
1550 context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1551 already have the thread context.
1552
1553 =for apidoc vform
1554 Like C<L</form>> but but the arguments are an encapsulated argument list.
1555
1556 =cut
1557 */
1558
1559 char *
1560 Perl_form(pTHX_ const char* pat, ...)
1561 {
1562     char *retval;
1563     va_list args;
1564     PERL_ARGS_ASSERT_FORM;
1565     va_start(args, pat);
1566     retval = vform(pat, &args);
1567     va_end(args);
1568     return retval;
1569 }
1570
1571 char *
1572 Perl_vform(pTHX_ const char *pat, va_list *args)
1573 {
1574     SV * const sv = mess_alloc();
1575     PERL_ARGS_ASSERT_VFORM;
1576     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1577     return SvPVX(sv);
1578 }
1579
1580 /*
1581 =for apidoc mess
1582 =for apidoc_item mess_nocontext
1583
1584 These take a sprintf-style format pattern and argument list, which are used to
1585 generate a string message.  If the message does not end with a newline, then it
1586 will be extended with some indication of the current location in the code, as
1587 described for C<L</mess_sv>>.
1588
1589 Normally, the resulting message is returned in a new mortal SV.
1590 But during global destruction a single SV may be shared between uses of
1591 this function.
1592
1593 The two forms differ only in that C<mess_nocontext> does not take a thread
1594 context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1595 already have the thread context.
1596
1597 =cut
1598 */
1599
1600 #if defined(PERL_IMPLICIT_CONTEXT)
1601 SV *
1602 Perl_mess_nocontext(const char *pat, ...)
1603 {
1604     dTHX;
1605     SV *retval;
1606     va_list args;
1607     PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1608     va_start(args, pat);
1609     retval = vmess(pat, &args);
1610     va_end(args);
1611     return retval;
1612 }
1613 #endif /* PERL_IMPLICIT_CONTEXT */
1614
1615 SV *
1616 Perl_mess(pTHX_ const char *pat, ...)
1617 {
1618     SV *retval;
1619     va_list args;
1620     PERL_ARGS_ASSERT_MESS;
1621     va_start(args, pat);
1622     retval = vmess(pat, &args);
1623     va_end(args);
1624     return retval;
1625 }
1626
1627 const COP*
1628 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1629                        bool opnext)
1630 {
1631     /* Look for curop starting from o.  cop is the last COP we've seen. */
1632     /* opnext means that curop is actually the ->op_next of the op we are
1633        seeking. */
1634
1635     PERL_ARGS_ASSERT_CLOSEST_COP;
1636
1637     if (!o || !curop || (
1638         opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1639     ))
1640         return cop;
1641
1642     if (o->op_flags & OPf_KIDS) {
1643         const OP *kid;
1644         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1645             const COP *new_cop;
1646
1647             /* If the OP_NEXTSTATE has been optimised away we can still use it
1648              * the get the file and line number. */
1649
1650             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1651                 cop = (const COP *)kid;
1652
1653             /* Keep searching, and return when we've found something. */
1654
1655             new_cop = closest_cop(cop, kid, curop, opnext);
1656             if (new_cop)
1657                 return new_cop;
1658         }
1659     }
1660
1661     /* Nothing found. */
1662
1663     return NULL;
1664 }
1665
1666 /*
1667 =for apidoc mess_sv
1668
1669 Expands a message, intended for the user, to include an indication of
1670 the current location in the code, if the message does not already appear
1671 to be complete.
1672
1673 C<basemsg> is the initial message or object.  If it is a reference, it
1674 will be used as-is and will be the result of this function.  Otherwise it
1675 is used as a string, and if it already ends with a newline, it is taken
1676 to be complete, and the result of this function will be the same string.
1677 If the message does not end with a newline, then a segment such as C<at
1678 foo.pl line 37> will be appended, and possibly other clauses indicating
1679 the current state of execution.  The resulting message will end with a
1680 dot and a newline.
1681
1682 Normally, the resulting message is returned in a new mortal SV.
1683 During global destruction a single SV may be shared between uses of this
1684 function.  If C<consume> is true, then the function is permitted (but not
1685 required) to modify and return C<basemsg> instead of allocating a new SV.
1686
1687 =cut
1688 */
1689
1690 SV *
1691 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1692 {
1693     SV *sv;
1694
1695 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1696     {
1697         char *ws;
1698         UV wi;
1699         /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1700         if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1701             && grok_atoUV(ws, &wi, NULL)
1702             && wi <= PERL_INT_MAX
1703         ) {
1704             Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1705         }
1706     }
1707 #endif
1708
1709     PERL_ARGS_ASSERT_MESS_SV;
1710
1711     if (SvROK(basemsg)) {
1712         if (consume) {
1713             sv = basemsg;
1714         }
1715         else {
1716             sv = mess_alloc();
1717             sv_setsv(sv, basemsg);
1718         }
1719         return sv;
1720     }
1721
1722     if (SvPOK(basemsg) && consume) {
1723         sv = basemsg;
1724     }
1725     else {
1726         sv = mess_alloc();
1727         sv_copypv(sv, basemsg);
1728     }
1729
1730     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1731         /*
1732          * Try and find the file and line for PL_op.  This will usually be
1733          * PL_curcop, but it might be a cop that has been optimised away.  We
1734          * can try to find such a cop by searching through the optree starting
1735          * from the sibling of PL_curcop.
1736          */
1737
1738         if (PL_curcop) {
1739             const COP *cop =
1740                 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1741             if (!cop)
1742                 cop = PL_curcop;
1743
1744             if (CopLINE(cop))
1745                 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1746                                 OutCopFILE(cop), (IV)CopLINE(cop));
1747         }
1748
1749         /* Seems that GvIO() can be untrustworthy during global destruction. */
1750         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1751                 && IoLINES(GvIOp(PL_last_in_gv)))
1752         {
1753             STRLEN l;
1754             const bool line_mode = (RsSIMPLE(PL_rs) &&
1755                                    *SvPV_const(PL_rs,l) == '\n' && l == 1);
1756             Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
1757                            SVfARG(PL_last_in_gv == PL_argvgv
1758                                  ? &PL_sv_no
1759                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1760                            line_mode ? "line" : "chunk",
1761                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1762         }
1763         if (PL_phase == PERL_PHASE_DESTRUCT)
1764             sv_catpvs(sv, " during global destruction");
1765         sv_catpvs(sv, ".\n");
1766     }
1767     return sv;
1768 }
1769
1770 /*
1771 =for apidoc vmess
1772
1773 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1774 argument list, respectively.  These are used to generate a string message.  If
1775 the
1776 message does not end with a newline, then it will be extended with
1777 some indication of the current location in the code, as described for
1778 L</mess_sv>.
1779
1780 Normally, the resulting message is returned in a new mortal SV.
1781 During global destruction a single SV may be shared between uses of
1782 this function.
1783
1784 =cut
1785 */
1786
1787 SV *
1788 Perl_vmess(pTHX_ const char *pat, va_list *args)
1789 {
1790     SV * const sv = mess_alloc();
1791
1792     PERL_ARGS_ASSERT_VMESS;
1793
1794     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1795     return mess_sv(sv, 1);
1796 }
1797
1798 void
1799 Perl_write_to_stderr(pTHX_ SV* msv)
1800 {
1801     IO *io;
1802     MAGIC *mg;
1803
1804     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1805
1806     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
1807         && (io = GvIO(PL_stderrgv))
1808         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
1809         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1810                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1811     else {
1812         PerlIO * const serr = Perl_error_log;
1813
1814         do_print(msv, serr);
1815         (void)PerlIO_flush(serr);
1816     }
1817 }
1818
1819 /*
1820 =for apidoc_section $warning
1821 */
1822
1823 /* Common code used in dieing and warning */
1824
1825 STATIC SV *
1826 S_with_queued_errors(pTHX_ SV *ex)
1827 {
1828     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1829     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1830         sv_catsv(PL_errors, ex);
1831         ex = sv_mortalcopy(PL_errors);
1832         SvCUR_set(PL_errors, 0);
1833     }
1834     return ex;
1835 }
1836
1837 STATIC bool
1838 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1839 {
1840     HV *stash;
1841     GV *gv;
1842     CV *cv;
1843     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1844     /* sv_2cv might call Perl_croak() or Perl_warner() */
1845     SV * const oldhook = *hook;
1846
1847     if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
1848         return FALSE;
1849
1850     ENTER;
1851     SAVESPTR(*hook);
1852     *hook = NULL;
1853     cv = sv_2cv(oldhook, &stash, &gv, 0);
1854     LEAVE;
1855     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1856         dSP;
1857         SV *exarg;
1858
1859         ENTER;
1860         save_re_context();
1861         if (warn) {
1862             SAVESPTR(*hook);
1863             *hook = NULL;
1864         }
1865         exarg = newSVsv(ex);
1866         SvREADONLY_on(exarg);
1867         SAVEFREESV(exarg);
1868
1869         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1870         PUSHMARK(SP);
1871         XPUSHs(exarg);
1872         PUTBACK;
1873         call_sv(MUTABLE_SV(cv), G_DISCARD);
1874         POPSTACK;
1875         LEAVE;
1876         return TRUE;
1877     }
1878     return FALSE;
1879 }
1880
1881 /*
1882 =for apidoc die_sv
1883 =for apidoc_item die_nocontext
1884
1885 These ehave the same as L</croak_sv>, except for the return type.
1886 It should be used only where the C<OP *> return type is required.
1887 The functions never actually return.
1888
1889 The two forms differ only in that C<die_nocontext> does not take a thread
1890 context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1891 already have the thread context.
1892
1893 =cut
1894 */
1895
1896 /* silence __declspec(noreturn) warnings */
1897 MSVC_DIAG_IGNORE(4646 4645)
1898 OP *
1899 Perl_die_sv(pTHX_ SV *baseex)
1900 {
1901     PERL_ARGS_ASSERT_DIE_SV;
1902     croak_sv(baseex);
1903     /* NOTREACHED */
1904     NORETURN_FUNCTION_END;
1905 }
1906 MSVC_DIAG_RESTORE
1907
1908 /*
1909 =for apidoc die
1910
1911 Behaves the same as L</croak>, except for the return type.
1912 It should be used only where the C<OP *> return type is required.
1913 The function never actually returns.
1914
1915 =cut
1916 */
1917
1918 #if defined(PERL_IMPLICIT_CONTEXT)
1919
1920 /* silence __declspec(noreturn) warnings */
1921 MSVC_DIAG_IGNORE(4646 4645)
1922 OP *
1923 Perl_die_nocontext(const char* pat, ...)
1924 {
1925     dTHX;
1926     va_list args;
1927     va_start(args, pat);
1928     vcroak(pat, &args);
1929     NOT_REACHED; /* NOTREACHED */
1930     va_end(args);
1931     NORETURN_FUNCTION_END;
1932 }
1933 MSVC_DIAG_RESTORE
1934
1935 #endif /* PERL_IMPLICIT_CONTEXT */
1936
1937 /* silence __declspec(noreturn) warnings */
1938 MSVC_DIAG_IGNORE(4646 4645)
1939 OP *
1940 Perl_die(pTHX_ const char* pat, ...)
1941 {
1942     va_list args;
1943     va_start(args, pat);
1944     vcroak(pat, &args);
1945     NOT_REACHED; /* NOTREACHED */
1946     va_end(args);
1947     NORETURN_FUNCTION_END;
1948 }
1949 MSVC_DIAG_RESTORE
1950
1951 /*
1952 =for apidoc croak_sv
1953
1954 This is an XS interface to Perl's C<die> function.
1955
1956 C<baseex> is the error message or object.  If it is a reference, it
1957 will be used as-is.  Otherwise it is used as a string, and if it does
1958 not end with a newline then it will be extended with some indication of
1959 the current location in the code, as described for L</mess_sv>.
1960
1961 The error message or object will be used as an exception, by default
1962 returning control to the nearest enclosing C<eval>, but subject to
1963 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1964 function never returns normally.
1965
1966 To die with a simple string message, the L</croak> function may be
1967 more convenient.
1968
1969 =cut
1970 */
1971
1972 void
1973 Perl_croak_sv(pTHX_ SV *baseex)
1974 {
1975     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1976     PERL_ARGS_ASSERT_CROAK_SV;
1977     invoke_exception_hook(ex, FALSE);
1978     die_unwind(ex);
1979 }
1980
1981 /*
1982 =for apidoc vcroak
1983
1984 This is an XS interface to Perl's C<die> function.
1985
1986 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1987 argument list.  These are used to generate a string message.  If the
1988 message does not end with a newline, then it will be extended with
1989 some indication of the current location in the code, as described for
1990 L</mess_sv>.
1991
1992 The error message will be used as an exception, by default
1993 returning control to the nearest enclosing C<eval>, but subject to
1994 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1995 function never returns normally.
1996
1997 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1998 (C<$@>) will be used as an error message or object instead of building an
1999 error message from arguments.  If you want to throw a non-string object,
2000 or build an error message in an SV yourself, it is preferable to use
2001 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
2002
2003 =cut
2004 */
2005
2006 void
2007 Perl_vcroak(pTHX_ const char* pat, va_list *args)
2008 {
2009     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
2010     invoke_exception_hook(ex, FALSE);
2011     die_unwind(ex);
2012 }
2013
2014 /*
2015 =for apidoc croak
2016 =for apidoc_item croak_nocontext
2017
2018 These are XS interfaces to Perl's C<die> function.
2019
2020 They take a sprintf-style format pattern and argument list, which are used to
2021 generate a string message.  If the message does not end with a newline, then it
2022 will be extended with some indication of the current location in the code, as
2023 described for C<L</mess_sv>>.
2024
2025 The error message will be used as an exception, by default
2026 returning control to the nearest enclosing C<eval>, but subject to
2027 modification by a C<$SIG{__DIE__}> handler.  In any case, these croak
2028 functions never return normally.
2029
2030 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
2031 (C<$@>) will be used as an error message or object instead of building an
2032 error message from arguments.  If you want to throw a non-string object,
2033 or build an error message in an SV yourself, it is preferable to use
2034 the C<L</croak_sv>> function, which does not involve clobbering C<ERRSV>.
2035
2036 The two forms differ only in that C<croak_nocontext> does not take a thread
2037 context (C<aTHX>) parameter.  It is usually preferred as it takes up fewer
2038 bytes of code than plain C<Perl_croak>, and time is rarely a critical resource
2039 when you are about to throw an exception.
2040
2041 =cut
2042 */
2043
2044 #if defined(PERL_IMPLICIT_CONTEXT)
2045 void
2046 Perl_croak_nocontext(const char *pat, ...)
2047 {
2048     dTHX;
2049     va_list args;
2050     va_start(args, pat);
2051     vcroak(pat, &args);
2052     NOT_REACHED; /* NOTREACHED */
2053     va_end(args);
2054 }
2055 #endif /* PERL_IMPLICIT_CONTEXT */
2056
2057 /* saves machine code for a common noreturn idiom typically used in Newx*() */
2058 GCC_DIAG_IGNORE_DECL(-Wunused-function);
2059 void
2060 Perl_croak_memory_wrap(void)
2061 {
2062     Perl_croak_nocontext("%s",PL_memory_wrap);
2063 }
2064 GCC_DIAG_RESTORE_DECL;
2065
2066 void
2067 Perl_croak(pTHX_ const char *pat, ...)
2068 {
2069     va_list args;
2070     va_start(args, pat);
2071     vcroak(pat, &args);
2072     NOT_REACHED; /* NOTREACHED */
2073     va_end(args);
2074 }
2075
2076 /*
2077 =for apidoc croak_no_modify
2078
2079 This encapsulates a common reason for dying, generating terser object code than
2080 using the generic C<Perl_croak>.  It is exactly equivalent to
2081 C<Perl_croak(aTHX_ "%s", PL_no_modify)> (which expands to something like
2082 "Modification of a read-only value attempted").
2083
2084 Less code used on exception code paths reduces CPU cache pressure.
2085
2086 =cut
2087 */
2088
2089 void
2090 Perl_croak_no_modify(void)
2091 {
2092     Perl_croak_nocontext( "%s", PL_no_modify);
2093 }
2094
2095 /* does not return, used in util.c perlio.c and win32.c
2096    This is typically called when malloc returns NULL.
2097 */
2098 void
2099 Perl_croak_no_mem(void)
2100 {
2101     dTHX;
2102
2103     int fd = PerlIO_fileno(Perl_error_log);
2104     if (fd < 0)
2105         SETERRNO(EBADF,RMS_IFI);
2106     else {
2107         /* Can't use PerlIO to write as it allocates memory */
2108         PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
2109     }
2110     my_exit(1);
2111 }
2112
2113 /* does not return, used only in POPSTACK */
2114 void
2115 Perl_croak_popstack(void)
2116 {
2117     dTHX;
2118     PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
2119     my_exit(1);
2120 }
2121
2122 /*
2123 =for apidoc warn_sv
2124
2125 This is an XS interface to Perl's C<warn> function.
2126
2127 C<baseex> is the error message or object.  If it is a reference, it
2128 will be used as-is.  Otherwise it is used as a string, and if it does
2129 not end with a newline then it will be extended with some indication of
2130 the current location in the code, as described for L</mess_sv>.
2131
2132 The error message or object will by default be written to standard error,
2133 but this is subject to modification by a C<$SIG{__WARN__}> handler.
2134
2135 To warn with a simple string message, the L</warn> function may be
2136 more convenient.
2137
2138 =cut
2139 */
2140
2141 void
2142 Perl_warn_sv(pTHX_ SV *baseex)
2143 {
2144     SV *ex = mess_sv(baseex, 0);
2145     PERL_ARGS_ASSERT_WARN_SV;
2146     if (!invoke_exception_hook(ex, TRUE))
2147         write_to_stderr(ex);
2148 }
2149
2150 /*
2151 =for apidoc vwarn
2152
2153 This is an XS interface to Perl's C<warn> function.
2154
2155 This is like C<L</warn>>, but C<args> are an encapsulated
2156 argument list.
2157
2158 Unlike with L</vcroak>, C<pat> is not permitted to be null.
2159
2160 =cut
2161 */
2162
2163 void
2164 Perl_vwarn(pTHX_ const char* pat, va_list *args)
2165 {
2166     SV *ex = vmess(pat, args);
2167     PERL_ARGS_ASSERT_VWARN;
2168     if (!invoke_exception_hook(ex, TRUE))
2169         write_to_stderr(ex);
2170 }
2171
2172 /*
2173 =for apidoc warn
2174 =for apidoc_item warn_nocontext
2175
2176 These are XS interfaces to Perl's C<warn> function.
2177
2178 They take a sprintf-style format pattern and argument list, which  are used to
2179 generate a string message.  If the message does not end with a newline, then it
2180 will be extended with some indication of the current location in the code, as
2181 described for C<L</mess_sv>>.
2182
2183 The error message or object will by default be written to standard error,
2184 but this is subject to modification by a C<$SIG{__WARN__}> handler.
2185
2186 Unlike with C<L</croak>>, C<pat> is not permitted to be null.
2187
2188 The two forms differ only in that C<warn_nocontext> does not take a thread
2189 context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2190 already have the thread context.
2191
2192 =cut
2193 */
2194
2195 #if defined(PERL_IMPLICIT_CONTEXT)
2196 void
2197 Perl_warn_nocontext(const char *pat, ...)
2198 {
2199     dTHX;
2200     va_list args;
2201     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
2202     va_start(args, pat);
2203     vwarn(pat, &args);
2204     va_end(args);
2205 }
2206 #endif /* PERL_IMPLICIT_CONTEXT */
2207
2208 void
2209 Perl_warn(pTHX_ const char *pat, ...)
2210 {
2211     va_list args;
2212     PERL_ARGS_ASSERT_WARN;
2213     va_start(args, pat);
2214     vwarn(pat, &args);
2215     va_end(args);
2216 }
2217
2218 /*
2219 =for apidoc warner
2220 =for apidoc_item warner_nocontext
2221
2222 These output a warning of the specified category (or categories) given by
2223 C<err>, using the sprintf-style format pattern C<pat>, and argument list.
2224
2225 C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2226 C<packWARN4> macros populated with the appropriate number of warning
2227 categories.  If any of the warning categories they specify is fatal, a fatal
2228 exception is thrown.
2229
2230 In any event a message is generated by the pattern and arguments.  If the
2231 message does not end with a newline, then it will be extended with some
2232 indication of the current location in the code, as described for L</mess_sv>.
2233
2234 The error message or object will by default be written to standard error,
2235 but this is subject to modification by a C<$SIG{__WARN__}> handler.
2236
2237 C<pat> is not permitted to be null.
2238
2239 The two forms differ only in that C<warner_nocontext> does not take a thread
2240 context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2241 already have the thread context.
2242
2243 These functions differ from the similarly named C<L</warn>> functions, in that
2244 the latter are for XS code to unconditionally display a warning, whereas these
2245 are for code that may be compiling a perl program, and does extra checking to
2246 see if the warning should be fatal.
2247
2248 =for apidoc ck_warner
2249 =for apidoc_item ck_warner_d
2250 If none of the warning categories given by C<err> are enabled, do nothing;
2251 otherwise call C<L</warner>>  or C<L</warner_nocontext>> with the passed-in
2252 parameters;.
2253
2254 C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2255 C<packWARN4> macros populated with the appropriate number of warning
2256 categories.
2257
2258 The two forms differ only in that C<ck_warner_d> should be used if warnings for
2259 any of the categories are by default enabled.
2260
2261 =for apidoc vwarner
2262 This is like C<L</warner>>, but C<args> are an encapsulated argument list.
2263
2264 =cut
2265 */
2266
2267 #if defined(PERL_IMPLICIT_CONTEXT)
2268 void
2269 Perl_warner_nocontext(U32 err, const char *pat, ...)
2270 {
2271     dTHX; 
2272     va_list args;
2273     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
2274     va_start(args, pat);
2275     vwarner(err, pat, &args);
2276     va_end(args);
2277 }
2278 #endif /* PERL_IMPLICIT_CONTEXT */
2279
2280 void
2281 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2282 {
2283     PERL_ARGS_ASSERT_CK_WARNER_D;
2284
2285     if (Perl_ckwarn_d(aTHX_ err)) {
2286         va_list args;
2287         va_start(args, pat);
2288         vwarner(err, pat, &args);
2289         va_end(args);
2290     }
2291 }
2292
2293 void
2294 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2295 {
2296     PERL_ARGS_ASSERT_CK_WARNER;
2297
2298     if (Perl_ckwarn(aTHX_ err)) {
2299         va_list args;
2300         va_start(args, pat);
2301         vwarner(err, pat, &args);
2302         va_end(args);
2303     }
2304 }
2305
2306 void
2307 Perl_warner(pTHX_ U32  err, const char* pat,...)
2308 {
2309     va_list args;
2310     PERL_ARGS_ASSERT_WARNER;
2311     va_start(args, pat);
2312     vwarner(err, pat, &args);
2313     va_end(args);
2314 }
2315
2316 void
2317 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
2318 {
2319     PERL_ARGS_ASSERT_VWARNER;
2320     if (
2321         (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2322         !(PL_in_eval & EVAL_KEEPERR)
2323     ) {
2324         SV * const msv = vmess(pat, args);
2325
2326         if (PL_parser && PL_parser->error_count) {
2327             qerror(msv);
2328         }
2329         else {
2330             invoke_exception_hook(msv, FALSE);
2331             die_unwind(msv);
2332         }
2333     }
2334     else {
2335         Perl_vwarn(aTHX_ pat, args);
2336     }
2337 }
2338
2339 /* implements the ckWARN? macros */
2340
2341 bool
2342 Perl_ckwarn(pTHX_ U32 w)
2343 {
2344     /* If lexical warnings have not been set, use $^W.  */
2345     if (isLEXWARN_off)
2346         return PL_dowarn & G_WARN_ON;
2347
2348     return ckwarn_common(w);
2349 }
2350
2351 /* implements the ckWARN?_d macro */
2352
2353 bool
2354 Perl_ckwarn_d(pTHX_ U32 w)
2355 {
2356     /* If lexical warnings have not been set then default classes warn.  */
2357     if (isLEXWARN_off)
2358         return TRUE;
2359
2360     return ckwarn_common(w);
2361 }
2362
2363 static bool
2364 S_ckwarn_common(pTHX_ U32 w)
2365 {
2366     if (PL_curcop->cop_warnings == pWARN_ALL)
2367         return TRUE;
2368
2369     if (PL_curcop->cop_warnings == pWARN_NONE)
2370         return FALSE;
2371
2372     /* Check the assumption that at least the first slot is non-zero.  */
2373     assert(unpackWARN1(w));
2374
2375     /* Check the assumption that it is valid to stop as soon as a zero slot is
2376        seen.  */
2377     if (!unpackWARN2(w)) {
2378         assert(!unpackWARN3(w));
2379         assert(!unpackWARN4(w));
2380     } else if (!unpackWARN3(w)) {
2381         assert(!unpackWARN4(w));
2382     }
2383         
2384     /* Right, dealt with all the special cases, which are implemented as non-
2385        pointers, so there is a pointer to a real warnings mask.  */
2386     do {
2387         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2388             return TRUE;
2389     } while (w >>= WARNshift);
2390
2391     return FALSE;
2392 }
2393
2394 /* Set buffer=NULL to get a new one.  */
2395 STRLEN *
2396 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2397                            STRLEN size) {
2398     const MEM_SIZE len_wanted =
2399         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2400     PERL_UNUSED_CONTEXT;
2401     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2402
2403     buffer = (STRLEN*)
2404         (specialWARN(buffer) ?
2405          PerlMemShared_malloc(len_wanted) :
2406          PerlMemShared_realloc(buffer, len_wanted));
2407     buffer[0] = size;
2408     Copy(bits, (buffer + 1), size, char);
2409     if (size < WARNsize)
2410         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2411     return buffer;
2412 }
2413
2414 /* since we've already done strlen() for both nam and val
2415  * we can use that info to make things faster than
2416  * sprintf(s, "%s=%s", nam, val)
2417  */
2418 #define my_setenv_format(s, nam, nlen, val, vlen) \
2419    Copy(nam, s, nlen, char); \
2420    *(s+nlen) = '='; \
2421    Copy(val, s+(nlen+1), vlen, char); \
2422    *(s+(nlen+1+vlen)) = '\0'
2423
2424
2425
2426 #ifdef USE_ENVIRON_ARRAY
2427 /* NB: VMS' my_setenv() is in vms.c */
2428
2429 /* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
2430  * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
2431  * testing for HAS UNSETENV is sufficient.
2432  */
2433 #  if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2434 #    define MY_HAS_SETENV
2435 #  endif
2436
2437 /* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
2438  * 'current' is non-null, with up to three sizes that are added together.
2439  * It handles integer overflow.
2440  */
2441 #  ifndef MY_HAS_SETENV
2442 static char *
2443 S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
2444 {
2445     void *p;
2446     Size_t sl, l = l1 + l2;
2447
2448     if (l < l2)
2449         goto panic;
2450     l += l3;
2451     if (l < l3)
2452         goto panic;
2453     sl = l * size;
2454     if (sl < l)
2455         goto panic;
2456
2457     p = current
2458             ? safesysrealloc(current, sl)
2459             : safesysmalloc(sl);
2460     if (p)
2461         return (char*)p;
2462
2463   panic:
2464     croak_memory_wrap();
2465 }
2466 #  endif
2467
2468
2469 #  if !defined(WIN32) && !defined(NETWARE)
2470
2471 /*
2472 =for apidoc_section $utility
2473 =for apidoc my_setenv
2474
2475 A wrapper for the C library L<setenv(3)>.  Don't use the latter, as the perl
2476 version has desirable safeguards
2477
2478 =cut
2479 */
2480
2481 void
2482 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2483 {
2484 #    ifdef __amigaos4__
2485   amigaos4_obtain_environ(__FUNCTION__);
2486 #    endif
2487
2488 #    ifdef USE_ITHREADS
2489   /* only parent thread can modify process environment, so no need to use a
2490    * mutex */
2491   if (PL_curinterp == aTHX)
2492 #    endif
2493   {
2494
2495 #    ifndef PERL_USE_SAFE_PUTENV
2496     if (!PL_use_safe_putenv) {
2497         /* most putenv()s leak, so we manipulate environ directly */
2498         UV i;
2499         Size_t vlen, nlen = strlen(nam);
2500
2501         /* where does it go? */
2502         for (i = 0; environ[i]; i++) {
2503             if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
2504                 break;
2505         }
2506
2507         if (environ == PL_origenviron) {   /* need we copy environment? */
2508             UV j, max;
2509             char **tmpenv;
2510
2511             max = i;
2512             while (environ[max])
2513                 max++;
2514
2515             /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
2516             tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
2517
2518             for (j=0; j<max; j++) {         /* copy environment */
2519                 const Size_t len = strlen(environ[j]);
2520                 tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
2521                 Copy(environ[j], tmpenv[j], len+1, char);
2522             }
2523
2524             tmpenv[max] = NULL;
2525             environ = tmpenv;               /* tell exec where it is now */
2526         }
2527
2528         if (!val) {
2529             safesysfree(environ[i]);
2530             while (environ[i]) {
2531                 environ[i] = environ[i+1];
2532                 i++;
2533             }
2534 #      ifdef __amigaos4__
2535             goto my_setenv_out;
2536 #      else
2537             return;
2538 #      endif
2539         }
2540
2541         if (!environ[i]) {                 /* does not exist yet */
2542             environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
2543             environ[i+1] = NULL;    /* make sure it's null terminated */
2544         }
2545         else
2546             safesysfree(environ[i]);
2547
2548         vlen = strlen(val);
2549
2550         environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
2551         /* all that work just for this */
2552         my_setenv_format(environ[i], nam, nlen, val, vlen);
2553     }
2554     else {
2555
2556 #    endif /* !PERL_USE_SAFE_PUTENV */
2557
2558 #    ifdef MY_HAS_SETENV
2559 #      if defined(HAS_UNSETENV)
2560         if (val == NULL) {
2561             (void)unsetenv(nam);
2562         } else {
2563             (void)setenv(nam, val, 1);
2564         }
2565 #      else /* ! HAS_UNSETENV */
2566         (void)setenv(nam, val, 1);
2567 #      endif /* HAS_UNSETENV */
2568
2569 #    elif defined(HAS_UNSETENV)
2570
2571         if (val == NULL) {
2572             if (environ) /* old glibc can crash with null environ */
2573                 (void)unsetenv(nam);
2574         } else {
2575             const Size_t nlen = strlen(nam);
2576             const Size_t vlen = strlen(val);
2577             char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
2578             my_setenv_format(new_env, nam, nlen, val, vlen);
2579             (void)putenv(new_env);
2580         }
2581
2582 #    else /* ! HAS_UNSETENV */
2583
2584         char *new_env;
2585         const Size_t nlen = strlen(nam);
2586         Size_t vlen;
2587         if (!val) {
2588            val = "";
2589         }
2590         vlen = strlen(val);
2591         new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
2592         /* all that work just for this */
2593         my_setenv_format(new_env, nam, nlen, val, vlen);
2594         (void)putenv(new_env);
2595
2596 #    endif /* MY_HAS_SETENV */
2597
2598 #    ifndef PERL_USE_SAFE_PUTENV
2599     }
2600 #    endif
2601   }
2602
2603 #    ifdef __amigaos4__
2604 my_setenv_out:
2605   amigaos4_release_environ(__FUNCTION__);
2606 #    endif
2607 }
2608
2609 #  else /* WIN32 || NETWARE */
2610
2611 void
2612 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2613 {
2614     char *envstr;
2615     const Size_t nlen = strlen(nam);
2616     Size_t vlen;
2617
2618     if (!val) {
2619        val = "";
2620     }
2621     vlen = strlen(val);
2622     envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
2623     my_setenv_format(envstr, nam, nlen, val, vlen);
2624     (void)PerlEnv_putenv(envstr);
2625     safesysfree(envstr);
2626 }
2627
2628 #  endif /* WIN32 || NETWARE */
2629
2630 #endif /* USE_ENVIRON_ARRAY */
2631
2632
2633
2634
2635 #ifdef UNLINK_ALL_VERSIONS
2636 I32
2637 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2638 {
2639     I32 retries = 0;
2640
2641     PERL_ARGS_ASSERT_UNLNK;
2642
2643     while (PerlLIO_unlink(f) >= 0)
2644         retries++;
2645     return retries ? 0 : -1;
2646 }
2647 #endif
2648
2649 PerlIO *
2650 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2651 {
2652 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2653     int p[2];
2654     I32 This, that;
2655     Pid_t pid;
2656     SV *sv;
2657     I32 did_pipes = 0;
2658     int pp[2];
2659
2660     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2661
2662     PERL_FLUSHALL_FOR_CHILD;
2663     This = (*mode == 'w');
2664     that = !This;
2665     if (TAINTING_get) {
2666         taint_env();
2667         taint_proper("Insecure %s%s", "EXEC");
2668     }
2669     if (PerlProc_pipe_cloexec(p) < 0)
2670         return NULL;
2671     /* Try for another pipe pair for error return */
2672     if (PerlProc_pipe_cloexec(pp) >= 0)
2673         did_pipes = 1;
2674     while ((pid = PerlProc_fork()) < 0) {
2675         if (errno != EAGAIN) {
2676             PerlLIO_close(p[This]);
2677             PerlLIO_close(p[that]);
2678             if (did_pipes) {
2679                 PerlLIO_close(pp[0]);
2680                 PerlLIO_close(pp[1]);
2681             }
2682             return NULL;
2683         }
2684         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2685         sleep(5);
2686     }
2687     if (pid == 0) {
2688         /* Child */
2689 #undef THIS
2690 #undef THAT
2691 #define THIS that
2692 #define THAT This
2693         /* Close parent's end of error status pipe (if any) */
2694         if (did_pipes)
2695             PerlLIO_close(pp[0]);
2696         /* Now dup our end of _the_ pipe to right position */
2697         if (p[THIS] != (*mode == 'r')) {
2698             PerlLIO_dup2(p[THIS], *mode == 'r');
2699             PerlLIO_close(p[THIS]);
2700             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2701                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2702         }
2703         else {
2704             setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
2705             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2706         }
2707 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2708         /* No automatic close - do it by hand */
2709 #  ifndef NOFILE
2710 #  define NOFILE 20
2711 #  endif
2712         {
2713             int fd;
2714
2715             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2716                 if (fd != pp[1])
2717                     PerlLIO_close(fd);
2718             }
2719         }
2720 #endif
2721         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2722         PerlProc__exit(1);
2723 #undef THIS
2724 #undef THAT
2725     }
2726     /* Parent */
2727     if (did_pipes)
2728         PerlLIO_close(pp[1]);
2729     /* Keep the lower of the two fd numbers */
2730     if (p[that] < p[This]) {
2731         PerlLIO_dup2_cloexec(p[This], p[that]);
2732         PerlLIO_close(p[This]);
2733         p[This] = p[that];
2734     }
2735     else
2736         PerlLIO_close(p[that]);         /* close child's end of pipe */
2737
2738     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2739     SvUPGRADE(sv,SVt_IV);
2740     SvIV_set(sv, pid);
2741     PL_forkprocess = pid;
2742     /* If we managed to get status pipe check for exec fail */
2743     if (did_pipes && pid > 0) {
2744         int errkid;
2745         unsigned read_total = 0;
2746
2747         while (read_total < sizeof(int)) {
2748             const SSize_t n1 = PerlLIO_read(pp[0],
2749                               (void*)(((char*)&errkid)+read_total),
2750                               (sizeof(int)) - read_total);
2751             if (n1 <= 0)
2752                 break;
2753             read_total += n1;
2754         }
2755         PerlLIO_close(pp[0]);
2756         did_pipes = 0;
2757         if (read_total) {                       /* Error */
2758             int pid2, status;
2759             PerlLIO_close(p[This]);
2760             if (read_total != sizeof(int))
2761                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
2762             do {
2763                 pid2 = wait4pid(pid, &status, 0);
2764             } while (pid2 == -1 && errno == EINTR);
2765             errno = errkid;             /* Propagate errno from kid */
2766             return NULL;
2767         }
2768     }
2769     if (did_pipes)
2770          PerlLIO_close(pp[0]);
2771     return PerlIO_fdopen(p[This], mode);
2772 #else
2773 #  if defined(OS2)      /* Same, without fork()ing and all extra overhead... */
2774     return my_syspopen4(aTHX_ NULL, mode, n, args);
2775 #  elif defined(WIN32)
2776     return win32_popenlist(mode, n, args);
2777 #  else
2778     Perl_croak(aTHX_ "List form of piped open not implemented");
2779     return (PerlIO *) NULL;
2780 #  endif
2781 #endif
2782 }
2783
2784     /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2785 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2786 PerlIO *
2787 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2788 {
2789     int p[2];
2790     I32 This, that;
2791     Pid_t pid;
2792     SV *sv;
2793     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2794     I32 did_pipes = 0;
2795     int pp[2];
2796
2797     PERL_ARGS_ASSERT_MY_POPEN;
2798
2799     PERL_FLUSHALL_FOR_CHILD;
2800 #ifdef OS2
2801     if (doexec) {
2802         return my_syspopen(aTHX_ cmd,mode);
2803     }
2804 #endif
2805     This = (*mode == 'w');
2806     that = !This;
2807     if (doexec && TAINTING_get) {
2808         taint_env();
2809         taint_proper("Insecure %s%s", "EXEC");
2810     }
2811     if (PerlProc_pipe_cloexec(p) < 0)
2812         return NULL;
2813     if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
2814         did_pipes = 1;
2815     while ((pid = PerlProc_fork()) < 0) {
2816         if (errno != EAGAIN) {
2817             PerlLIO_close(p[This]);
2818             PerlLIO_close(p[that]);
2819             if (did_pipes) {
2820                 PerlLIO_close(pp[0]);
2821                 PerlLIO_close(pp[1]);
2822             }
2823             if (!doexec)
2824                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2825             return NULL;
2826         }
2827         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2828         sleep(5);
2829     }
2830     if (pid == 0) {
2831
2832 #undef THIS
2833 #undef THAT
2834 #define THIS that
2835 #define THAT This
2836         if (did_pipes)
2837             PerlLIO_close(pp[0]);
2838         if (p[THIS] != (*mode == 'r')) {
2839             PerlLIO_dup2(p[THIS], *mode == 'r');
2840             PerlLIO_close(p[THIS]);
2841             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2842                 PerlLIO_close(p[THAT]);
2843         }
2844         else {
2845             setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
2846             PerlLIO_close(p[THAT]);
2847         }
2848 #ifndef OS2
2849         if (doexec) {
2850 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2851 #ifndef NOFILE
2852 #define NOFILE 20
2853 #endif
2854             {
2855                 int fd;
2856
2857                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2858                     if (fd != pp[1])
2859                         PerlLIO_close(fd);
2860             }
2861 #endif
2862             /* may or may not use the shell */
2863             do_exec3(cmd, pp[1], did_pipes);
2864             PerlProc__exit(1);
2865         }
2866 #endif  /* defined OS2 */
2867
2868 #ifdef PERLIO_USING_CRLF
2869    /* Since we circumvent IO layers when we manipulate low-level
2870       filedescriptors directly, need to manually switch to the
2871       default, binary, low-level mode; see PerlIOBuf_open(). */
2872    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2873 #endif 
2874         PL_forkprocess = 0;
2875 #ifdef PERL_USES_PL_PIDSTATUS
2876         hv_clear(PL_pidstatus); /* we have no children */
2877 #endif
2878         return NULL;
2879 #undef THIS
2880 #undef THAT
2881     }
2882     if (did_pipes)
2883         PerlLIO_close(pp[1]);
2884     if (p[that] < p[This]) {
2885         PerlLIO_dup2_cloexec(p[This], p[that]);
2886         PerlLIO_close(p[This]);
2887         p[This] = p[that];
2888     }
2889     else
2890         PerlLIO_close(p[that]);
2891
2892     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2893     SvUPGRADE(sv,SVt_IV);
2894     SvIV_set(sv, pid);
2895     PL_forkprocess = pid;
2896     if (did_pipes && pid > 0) {
2897         int errkid;
2898         unsigned n = 0;
2899
2900         while (n < sizeof(int)) {
2901             const SSize_t n1 = PerlLIO_read(pp[0],
2902                               (void*)(((char*)&errkid)+n),
2903                               (sizeof(int)) - n);
2904             if (n1 <= 0)
2905                 break;
2906             n += n1;
2907         }
2908         PerlLIO_close(pp[0]);
2909         did_pipes = 0;
2910         if (n) {                        /* Error */
2911             int pid2, status;
2912             PerlLIO_close(p[This]);
2913             if (n != sizeof(int))
2914                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2915             do {
2916                 pid2 = wait4pid(pid, &status, 0);
2917             } while (pid2 == -1 && errno == EINTR);
2918             errno = errkid;             /* Propagate errno from kid */
2919             return NULL;
2920         }
2921     }
2922     if (did_pipes)
2923          PerlLIO_close(pp[0]);
2924     return PerlIO_fdopen(p[This], mode);
2925 }
2926 #elif defined(DJGPP)
2927 FILE *djgpp_popen();
2928 PerlIO *
2929 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2930 {
2931     PERL_FLUSHALL_FOR_CHILD;
2932     /* Call system's popen() to get a FILE *, then import it.
2933        used 0 for 2nd parameter to PerlIO_importFILE;
2934        apparently not used
2935     */
2936     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2937 }
2938 #elif defined(__LIBCATAMOUNT__)
2939 PerlIO *
2940 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2941 {
2942     return NULL;
2943 }
2944
2945 #endif /* !DOSISH */
2946
2947 /* this is called in parent before the fork() */
2948 void
2949 Perl_atfork_lock(void)
2950 #if defined(USE_ITHREADS)
2951 #  ifdef USE_PERLIO
2952   PERL_TSA_ACQUIRE(PL_perlio_mutex)
2953 #  endif
2954 #  ifdef MYMALLOC
2955   PERL_TSA_ACQUIRE(PL_malloc_mutex)
2956 #  endif
2957   PERL_TSA_ACQUIRE(PL_op_mutex)
2958 #endif
2959 {
2960 #if defined(USE_ITHREADS)
2961     /* locks must be held in locking order (if any) */
2962 #  ifdef USE_PERLIO
2963     MUTEX_LOCK(&PL_perlio_mutex);
2964 #  endif
2965 #  ifdef MYMALLOC
2966     MUTEX_LOCK(&PL_malloc_mutex);
2967 #  endif
2968     OP_REFCNT_LOCK;
2969 #endif
2970 }
2971
2972 /* this is called in both parent and child after the fork() */
2973 void
2974 Perl_atfork_unlock(void)
2975 #if defined(USE_ITHREADS)
2976 #  ifdef USE_PERLIO
2977   PERL_TSA_RELEASE(PL_perlio_mutex)
2978 #  endif
2979 #  ifdef MYMALLOC
2980   PERL_TSA_RELEASE(PL_malloc_mutex)
2981 #  endif
2982   PERL_TSA_RELEASE(PL_op_mutex)
2983 #endif
2984 {
2985 #if defined(USE_ITHREADS)
2986     /* locks must be released in same order as in atfork_lock() */
2987 #  ifdef USE_PERLIO
2988     MUTEX_UNLOCK(&PL_perlio_mutex);
2989 #  endif
2990 #  ifdef MYMALLOC
2991     MUTEX_UNLOCK(&PL_malloc_mutex);
2992 #  endif
2993     OP_REFCNT_UNLOCK;
2994 #endif
2995 }
2996
2997 Pid_t
2998 Perl_my_fork(void)
2999 {
3000 #if defined(HAS_FORK)
3001     Pid_t pid;
3002 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
3003     atfork_lock();
3004     pid = fork();
3005     atfork_unlock();
3006 #else
3007     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
3008      * handlers elsewhere in the code */
3009     pid = fork();
3010 #endif
3011     return pid;
3012 #elif defined(__amigaos4__)
3013     return amigaos_fork();
3014 #else
3015     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
3016     Perl_croak_nocontext("fork() not available");
3017     return 0;
3018 #endif /* HAS_FORK */
3019 }
3020
3021 #ifndef HAS_DUP2
3022 int
3023 dup2(int oldfd, int newfd)
3024 {
3025 #if defined(HAS_FCNTL) && defined(F_DUPFD)
3026     if (oldfd == newfd)
3027         return oldfd;
3028     PerlLIO_close(newfd);
3029     return fcntl(oldfd, F_DUPFD, newfd);
3030 #else
3031 #define DUP2_MAX_FDS 256
3032     int fdtmp[DUP2_MAX_FDS];
3033     I32 fdx = 0;
3034     int fd;
3035
3036     if (oldfd == newfd)
3037         return oldfd;
3038     PerlLIO_close(newfd);
3039     /* good enough for low fd's... */
3040     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
3041         if (fdx >= DUP2_MAX_FDS) {
3042             PerlLIO_close(fd);
3043             fd = -1;
3044             break;
3045         }
3046         fdtmp[fdx++] = fd;
3047     }
3048     while (fdx > 0)
3049         PerlLIO_close(fdtmp[--fdx]);
3050     return fd;
3051 #endif
3052 }
3053 #endif
3054
3055 #ifndef PERL_MICRO
3056 #ifdef HAS_SIGACTION
3057
3058 /*
3059 =for apidoc_section $signals
3060 =for apidoc rsignal
3061
3062 A wrapper for the C library L<signal(2)>.  Don't use the latter, as the Perl
3063 version knows things that interact with the rest of the perl interpreter.
3064
3065 =cut
3066 */
3067
3068 Sighandler_t
3069 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3070 {
3071     struct sigaction act, oact;
3072
3073 #ifdef USE_ITHREADS
3074     /* only "parent" interpreter can diddle signals */
3075     if (PL_curinterp != aTHX)
3076         return (Sighandler_t) SIG_ERR;
3077 #endif
3078
3079     act.sa_handler = handler;
3080     sigemptyset(&act.sa_mask);
3081     act.sa_flags = 0;
3082 #ifdef SA_RESTART
3083     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3084         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
3085 #endif
3086 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3087     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3088         act.sa_flags |= SA_NOCLDWAIT;
3089 #endif
3090     if (sigaction(signo, &act, &oact) == -1)
3091         return (Sighandler_t) SIG_ERR;
3092     else
3093         return (Sighandler_t) oact.sa_handler;
3094 }
3095
3096 Sighandler_t
3097 Perl_rsignal_state(pTHX_ int signo)
3098 {
3099     struct sigaction oact;
3100     PERL_UNUSED_CONTEXT;
3101
3102     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3103         return (Sighandler_t) SIG_ERR;
3104     else
3105         return (Sighandler_t) oact.sa_handler;
3106 }
3107
3108 int
3109 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3110 {
3111     struct sigaction act;
3112
3113     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3114
3115 #ifdef USE_ITHREADS
3116     /* only "parent" interpreter can diddle signals */
3117     if (PL_curinterp != aTHX)
3118         return -1;
3119 #endif
3120
3121     act.sa_handler = handler;
3122     sigemptyset(&act.sa_mask);
3123     act.sa_flags = 0;
3124 #ifdef SA_RESTART
3125     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3126         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
3127 #endif
3128 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3129     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3130         act.sa_flags |= SA_NOCLDWAIT;
3131 #endif
3132     return sigaction(signo, &act, save);
3133 }
3134
3135 int
3136 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3137 {
3138     PERL_UNUSED_CONTEXT;
3139 #ifdef USE_ITHREADS
3140     /* only "parent" interpreter can diddle signals */
3141     if (PL_curinterp != aTHX)
3142         return -1;
3143 #endif
3144
3145     return sigaction(signo, save, (struct sigaction *)NULL);
3146 }
3147
3148 #else /* !HAS_SIGACTION */
3149
3150 Sighandler_t
3151 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3152 {
3153 #if defined(USE_ITHREADS) && !defined(WIN32)
3154     /* only "parent" interpreter can diddle signals */
3155     if (PL_curinterp != aTHX)
3156         return (Sighandler_t) SIG_ERR;
3157 #endif
3158
3159     return PerlProc_signal(signo, handler);
3160 }
3161
3162 static Signal_t
3163 sig_trap(int signo)
3164 {
3165     PL_sig_trapped++;
3166 }
3167
3168 Sighandler_t
3169 Perl_rsignal_state(pTHX_ int signo)
3170 {
3171     Sighandler_t oldsig;
3172
3173 #if defined(USE_ITHREADS) && !defined(WIN32)
3174     /* only "parent" interpreter can diddle signals */
3175     if (PL_curinterp != aTHX)
3176         return (Sighandler_t) SIG_ERR;
3177 #endif
3178
3179     PL_sig_trapped = 0;
3180     oldsig = PerlProc_signal(signo, sig_trap);
3181     PerlProc_signal(signo, oldsig);
3182     if (PL_sig_trapped)
3183         PerlProc_kill(PerlProc_getpid(), signo);
3184     return oldsig;
3185 }
3186
3187 int
3188 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3189 {
3190 #if defined(USE_ITHREADS) && !defined(WIN32)
3191     /* only "parent" interpreter can diddle signals */
3192     if (PL_curinterp != aTHX)
3193         return -1;
3194 #endif
3195     *save = PerlProc_signal(signo, handler);
3196     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3197 }
3198
3199 int
3200 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3201 {
3202 #if defined(USE_ITHREADS) && !defined(WIN32)
3203     /* only "parent" interpreter can diddle signals */
3204     if (PL_curinterp != aTHX)
3205         return -1;
3206 #endif
3207     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3208 }
3209
3210 #endif /* !HAS_SIGACTION */
3211 #endif /* !PERL_MICRO */
3212
3213     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3214 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3215 I32
3216 Perl_my_pclose(pTHX_ PerlIO *ptr)
3217 {
3218     int status;
3219     SV **svp;
3220     Pid_t pid;
3221     Pid_t pid2 = 0;
3222     bool close_failed;
3223     dSAVEDERRNO;
3224     const int fd = PerlIO_fileno(ptr);
3225     bool should_wait;
3226
3227     svp = av_fetch(PL_fdpid,fd,TRUE);
3228     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3229     SvREFCNT_dec(*svp);
3230     *svp = NULL;
3231
3232 #if defined(USE_PERLIO)
3233     /* Find out whether the refcount is low enough for us to wait for the
3234        child proc without blocking. */
3235     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3236 #else
3237     should_wait = pid > 0;
3238 #endif
3239
3240 #ifdef OS2
3241     if (pid == -1) {                    /* Opened by popen. */
3242         return my_syspclose(ptr);
3243     }
3244 #endif
3245     close_failed = (PerlIO_close(ptr) == EOF);
3246     SAVE_ERRNO;
3247     if (should_wait) do {
3248         pid2 = wait4pid(pid, &status, 0);
3249     } while (pid2 == -1 && errno == EINTR);
3250     if (close_failed) {
3251         RESTORE_ERRNO;
3252         return -1;
3253     }
3254     return(
3255       should_wait
3256        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3257        : 0
3258     );
3259 }
3260 #elif defined(__LIBCATAMOUNT__)
3261 I32
3262 Perl_my_pclose(pTHX_ PerlIO *ptr)
3263 {
3264     return -1;
3265 }
3266 #endif /* !DOSISH */
3267
3268 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3269 I32
3270 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3271 {
3272     I32 result = 0;
3273     PERL_ARGS_ASSERT_WAIT4PID;
3274 #ifdef PERL_USES_PL_PIDSTATUS
3275     if (!pid) {
3276         /* PERL_USES_PL_PIDSTATUS is only defined when neither
3277            waitpid() nor wait4() is available, or on OS/2, which
3278            doesn't appear to support waiting for a progress group
3279            member, so we can only treat a 0 pid as an unknown child.
3280         */
3281         errno = ECHILD;
3282         return -1;
3283     }
3284     {
3285         if (pid > 0) {
3286             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3287                pid, rather than a string form.  */
3288             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3289             if (svp && *svp != &PL_sv_undef) {
3290                 *statusp = SvIVX(*svp);
3291                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3292                                 G_DISCARD);
3293                 return pid;
3294             }
3295         }
3296         else {
3297             HE *entry;
3298
3299             hv_iterinit(PL_pidstatus);
3300             if ((entry = hv_iternext(PL_pidstatus))) {
3301                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3302                 I32 len;
3303                 const char * const spid = hv_iterkey(entry,&len);
3304
3305                 assert (len == sizeof(Pid_t));
3306                 memcpy((char *)&pid, spid, len);
3307                 *statusp = SvIVX(sv);
3308                 /* The hash iterator is currently on this entry, so simply
3309                    calling hv_delete would trigger the lazy delete, which on
3310                    aggregate does more work, because next call to hv_iterinit()
3311                    would spot the flag, and have to call the delete routine,
3312                    while in the meantime any new entries can't re-use that
3313                    memory.  */
3314                 hv_iterinit(PL_pidstatus);
3315                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3316                 return pid;
3317             }
3318         }
3319     }
3320 #endif
3321 #ifdef HAS_WAITPID
3322 #  ifdef HAS_WAITPID_RUNTIME
3323     if (!HAS_WAITPID_RUNTIME)
3324         goto hard_way;
3325 #  endif
3326     result = PerlProc_waitpid(pid,statusp,flags);
3327     goto finish;
3328 #endif
3329 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3330     result = wait4(pid,statusp,flags,NULL);
3331     goto finish;
3332 #endif
3333 #ifdef PERL_USES_PL_PIDSTATUS
3334 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3335   hard_way:
3336 #endif
3337     {
3338         if (flags)
3339             Perl_croak(aTHX_ "Can't do waitpid with flags");
3340         else {
3341             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3342                 pidgone(result,*statusp);
3343             if (result < 0)
3344                 *statusp = -1;
3345         }
3346     }
3347 #endif
3348 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3349   finish:
3350 #endif
3351     if (result < 0 && errno == EINTR) {
3352         PERL_ASYNC_CHECK();
3353         errno = EINTR; /* reset in case a signal handler changed $! */
3354     }
3355     return result;
3356 }
3357 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3358
3359 #ifdef PERL_USES_PL_PIDSTATUS
3360 void
3361 S_pidgone(pTHX_ Pid_t pid, int status)
3362 {
3363     SV *sv;
3364
3365     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3366     SvUPGRADE(sv,SVt_IV);
3367     SvIV_set(sv, status);
3368     return;
3369 }
3370 #endif
3371
3372 #if defined(OS2)
3373 int pclose();
3374 #ifdef HAS_FORK
3375 int                                     /* Cannot prototype with I32
3376                                            in os2ish.h. */
3377 my_syspclose(PerlIO *ptr)
3378 #else
3379 I32
3380 Perl_my_pclose(pTHX_ PerlIO *ptr)
3381 #endif
3382 {
3383     /* Needs work for PerlIO ! */
3384     FILE * const f = PerlIO_findFILE(ptr);
3385     const I32 result = pclose(f);
3386     PerlIO_releaseFILE(ptr,f);
3387     return result;
3388 }
3389 #endif
3390
3391 #if defined(DJGPP)
3392 int djgpp_pclose();
3393 I32
3394 Perl_my_pclose(pTHX_ PerlIO *ptr)
3395 {
3396     /* Needs work for PerlIO ! */
3397     FILE * const f = PerlIO_findFILE(ptr);
3398     I32 result = djgpp_pclose(f);
3399     result = (result << 8) & 0xff00;
3400     PerlIO_releaseFILE(ptr,f);
3401     return result;
3402 }
3403 #endif
3404
3405 #define PERL_REPEATCPY_LINEAR 4
3406 void
3407 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3408 {
3409     PERL_ARGS_ASSERT_REPEATCPY;
3410
3411     assert(len >= 0);
3412
3413     if (count < 0)
3414         croak_memory_wrap();
3415
3416     if (len == 1)
3417         memset(to, *from, count);
3418     else if (count) {
3419         char *p = to;
3420         IV items, linear, half;
3421
3422         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3423         for (items = 0; items < linear; ++items) {
3424             const char *q = from;
3425             IV todo;
3426             for (todo = len; todo > 0; todo--)
3427                 *p++ = *q++;
3428         }
3429
3430         half = count / 2;
3431         while (items <= half) {
3432             IV size = items * len;
3433             memcpy(p, to, size);
3434             p     += size;
3435             items *= 2;
3436         }
3437
3438         if (count > items)
3439             memcpy(p, to, (count - items) * len);
3440     }
3441 }
3442
3443 #ifndef HAS_RENAME
3444 I32
3445 Perl_same_dirent(pTHX_ const char *a, const char *b)
3446 {
3447     char *fa = strrchr(a,'/');
3448     char *fb = strrchr(b,'/');
3449     Stat_t tmpstatbuf1;
3450     Stat_t tmpstatbuf2;
3451     SV * const tmpsv = sv_newmortal();
3452
3453     PERL_ARGS_ASSERT_SAME_DIRENT;
3454
3455     if (fa)
3456         fa++;
3457     else
3458         fa = a;
3459     if (fb)
3460         fb++;
3461     else
3462         fb = b;
3463     if (strNE(a,b))
3464         return FALSE;
3465     if (fa == a)
3466         sv_setpvs(tmpsv, ".");
3467     else
3468         sv_setpvn(tmpsv, a, fa - a);
3469     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3470         return FALSE;
3471     if (fb == b)
3472         sv_setpvs(tmpsv, ".");
3473     else
3474         sv_setpvn(tmpsv, b, fb - b);
3475     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3476         return FALSE;
3477     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3478            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3479 }
3480 #endif /* !HAS_RENAME */
3481
3482 char*
3483 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3484                  const char *const *const search_ext, I32 flags)
3485 {
3486     const char *xfound = NULL;
3487     char *xfailed = NULL;
3488     char tmpbuf[MAXPATHLEN];
3489     char *s;
3490     I32 len = 0;
3491     int retval;
3492     char *bufend;
3493 #if defined(DOSISH) && !defined(OS2)
3494 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3495 #  define MAX_EXT_LEN 4
3496 #endif
3497 #ifdef OS2
3498 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3499 #  define MAX_EXT_LEN 4
3500 #endif
3501 #ifdef VMS
3502 #  define SEARCH_EXTS ".pl", ".com", NULL
3503 #  define MAX_EXT_LEN 4
3504 #endif
3505     /* additional extensions to try in each dir if scriptname not found */
3506 #ifdef SEARCH_EXTS
3507     static const char *const exts[] = { SEARCH_EXTS };
3508     const char *const *const ext = search_ext ? search_ext : exts;
3509     int extidx = 0, i = 0;
3510     const char *curext = NULL;
3511 #else
3512     PERL_UNUSED_ARG(search_ext);
3513 #  define MAX_EXT_LEN 0
3514 #endif
3515
3516     PERL_ARGS_ASSERT_FIND_SCRIPT;
3517
3518     /*
3519      * If dosearch is true and if scriptname does not contain path
3520      * delimiters, search the PATH for scriptname.
3521      *
3522      * If SEARCH_EXTS is also defined, will look for each
3523      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3524      * while searching the PATH.
3525      *
3526      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3527      * proceeds as follows:
3528      *   If DOSISH or VMSISH:
3529      *     + look for ./scriptname{,.foo,.bar}
3530      *     + search the PATH for scriptname{,.foo,.bar}
3531      *
3532      *   If !DOSISH:
3533      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3534      *       this will not look in '.' if it's not in the PATH)
3535      */
3536     tmpbuf[0] = '\0';
3537
3538 #ifdef VMS
3539 #  ifdef ALWAYS_DEFTYPES
3540     len = strlen(scriptname);
3541     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3542         int idx = 0, deftypes = 1;
3543         bool seen_dot = 1;
3544
3545         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3546 #  else
3547     if (dosearch) {
3548         int idx = 0, deftypes = 1;
3549         bool seen_dot = 1;
3550
3551         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3552 #  endif
3553         /* The first time through, just add SEARCH_EXTS to whatever we
3554          * already have, so we can check for default file types. */
3555         while (deftypes ||
3556                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3557         {
3558             Stat_t statbuf;
3559             if (deftypes) {
3560                 deftypes = 0;
3561                 *tmpbuf = '\0';
3562             }
3563             if ((strlen(tmpbuf) + strlen(scriptname)
3564                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3565                 continue;       /* don't search dir with too-long name */
3566             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3567 #else  /* !VMS */
3568
3569 #ifdef DOSISH
3570     if (strEQ(scriptname, "-"))
3571         dosearch = 0;
3572     if (dosearch) {             /* Look in '.' first. */
3573         const char *cur = scriptname;
3574 #ifdef SEARCH_EXTS
3575         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3576             while (ext[i])
3577                 if (strEQ(ext[i++],curext)) {
3578                     extidx = -1;                /* already has an ext */
3579                     break;
3580                 }
3581         do {
3582 #endif
3583             DEBUG_p(PerlIO_printf(Perl_debug_log,
3584                                   "Looking for %s\n",cur));
3585             {
3586                 Stat_t statbuf;
3587                 if (PerlLIO_stat(cur,&statbuf) >= 0
3588                     && !S_ISDIR(statbuf.st_mode)) {
3589                     dosearch = 0;
3590                     scriptname = cur;
3591 #ifdef SEARCH_EXTS
3592                     break;
3593 #endif
3594                 }
3595             }
3596 #ifdef SEARCH_EXTS
3597             if (cur == scriptname) {
3598                 len = strlen(scriptname);
3599                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3600                     break;
3601                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3602                 cur = tmpbuf;
3603             }
3604         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3605                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3606 #endif
3607     }
3608 #endif
3609
3610     if (dosearch && !strchr(scriptname, '/')
3611 #ifdef DOSISH
3612                  && !strchr(scriptname, '\\')
3613 #endif
3614                  && (s = PerlEnv_getenv("PATH")))
3615     {
3616         bool seen_dot = 0;
3617
3618         bufend = s + strlen(s);
3619         while (s < bufend) {
3620             Stat_t statbuf;
3621 #  ifdef DOSISH
3622             for (len = 0; *s
3623                     && *s != ';'; len++, s++) {
3624                 if (len < sizeof tmpbuf)
3625                     tmpbuf[len] = *s;
3626             }
3627             if (len < sizeof tmpbuf)
3628                 tmpbuf[len] = '\0';
3629 #  else
3630             s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3631                                    ':', &len);
3632 #  endif
3633             if (s < bufend)
3634                 s++;
3635             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3636                 continue;       /* don't search dir with too-long name */
3637             if (len
3638 #  ifdef DOSISH
3639                 && tmpbuf[len - 1] != '/'
3640                 && tmpbuf[len - 1] != '\\'
3641 #  endif
3642                )
3643                 tmpbuf[len++] = '/';
3644             if (len == 2 && tmpbuf[0] == '.')
3645                 seen_dot = 1;
3646             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3647 #endif  /* !VMS */
3648
3649 #ifdef SEARCH_EXTS
3650             len = strlen(tmpbuf);
3651             if (extidx > 0)     /* reset after previous loop */
3652                 extidx = 0;
3653             do {
3654 #endif
3655                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3656                 retval = PerlLIO_stat(tmpbuf,&statbuf);
3657                 if (S_ISDIR(statbuf.st_mode)) {
3658                     retval = -1;
3659                 }
3660 #ifdef SEARCH_EXTS
3661             } while (  retval < 0               /* not there */
3662                     && extidx>=0 && ext[extidx] /* try an extension? */
3663                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3664                 );
3665 #endif
3666             if (retval < 0)
3667                 continue;
3668             if (S_ISREG(statbuf.st_mode)
3669                 && cando(S_IRUSR,TRUE,&statbuf)
3670 #if !defined(DOSISH)
3671                 && cando(S_IXUSR,TRUE,&statbuf)
3672 #endif
3673                 )
3674             {
3675                 xfound = tmpbuf;                /* bingo! */
3676                 break;
3677             }
3678             if (!xfailed)
3679                 xfailed = savepv(tmpbuf);
3680         }
3681 #ifndef DOSISH
3682         {
3683             Stat_t statbuf;
3684             if (!xfound && !seen_dot && !xfailed &&
3685                 (PerlLIO_stat(scriptname,&statbuf) < 0
3686                  || S_ISDIR(statbuf.st_mode)))
3687 #endif
3688                 seen_dot = 1;                   /* Disable message. */
3689 #ifndef DOSISH
3690         }
3691 #endif
3692         if (!xfound) {
3693             if (flags & 1) {                    /* do or die? */
3694                 /* diag_listed_as: Can't execute %s */
3695                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3696                       (xfailed ? "execute" : "find"),
3697                       (xfailed ? xfailed : scriptname),
3698                       (xfailed ? "" : " on PATH"),
3699                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3700             }
3701             scriptname = NULL;
3702         }
3703         Safefree(xfailed);
3704         scriptname = xfound;
3705     }
3706     return (scriptname ? savepv(scriptname) : NULL);
3707 }
3708
3709 #ifndef PERL_GET_CONTEXT_DEFINED
3710
3711 void *
3712 Perl_get_context(void)
3713 {
3714 #if defined(USE_ITHREADS)
3715 #  ifdef OLD_PTHREADS_API
3716     pthread_addr_t t;
3717     int error = pthread_getspecific(PL_thr_key, &t);
3718     if (error)
3719         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3720     return (void*)t;
3721 #  elif defined(I_MACH_CTHREADS)
3722     return (void*)cthread_data(cthread_self());
3723 #  else
3724     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3725 #  endif
3726 #else
3727     return (void*)NULL;
3728 #endif
3729 }
3730
3731 void
3732 Perl_set_context(void *t)
3733 {
3734 #if defined(USE_ITHREADS)
3735 #endif
3736     PERL_ARGS_ASSERT_SET_CONTEXT;
3737 #if defined(USE_ITHREADS)
3738 #  ifdef I_MACH_CTHREADS
3739     cthread_set_data(cthread_self(), t);
3740 #  else
3741     {
3742         const int error = pthread_setspecific(PL_thr_key, t);
3743         if (error)
3744             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3745     }
3746 #  endif
3747 #else
3748     PERL_UNUSED_ARG(t);
3749 #endif
3750 }
3751
3752 #endif /* !PERL_GET_CONTEXT_DEFINED */
3753
3754 char **
3755 Perl_get_op_names(pTHX)
3756 {
3757     PERL_UNUSED_CONTEXT;
3758     return (char **)PL_op_name;
3759 }
3760
3761 char **
3762 Perl_get_op_descs(pTHX)
3763 {
3764     PERL_UNUSED_CONTEXT;
3765     return (char **)PL_op_desc;
3766 }
3767
3768 const char *
3769 Perl_get_no_modify(pTHX)
3770 {
3771     PERL_UNUSED_CONTEXT;
3772     return PL_no_modify;
3773 }
3774
3775 U32 *
3776 Perl_get_opargs(pTHX)
3777 {
3778     PERL_UNUSED_CONTEXT;
3779     return (U32 *)PL_opargs;
3780 }
3781
3782 PPADDR_t*
3783 Perl_get_ppaddr(pTHX)
3784 {
3785     PERL_UNUSED_CONTEXT;
3786     return (PPADDR_t*)PL_ppaddr;
3787 }
3788
3789 #ifndef HAS_GETENV_LEN
3790 char *
3791 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3792 {
3793     char * const env_trans = PerlEnv_getenv(env_elem);
3794     PERL_UNUSED_CONTEXT;
3795     PERL_ARGS_ASSERT_GETENV_LEN;
3796     if (env_trans)
3797         *len = strlen(env_trans);
3798     return env_trans;
3799 }
3800 #endif
3801
3802
3803 MGVTBL*
3804 Perl_get_vtbl(pTHX_ int vtbl_id)
3805 {
3806     PERL_UNUSED_CONTEXT;
3807
3808     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3809         ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3810 }
3811
3812 I32
3813 Perl_my_fflush_all(pTHX)
3814 {
3815 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3816     return PerlIO_flush(NULL);
3817 #else
3818 # if defined(HAS__FWALK)
3819     extern int fflush(FILE *);
3820     /* undocumented, unprototyped, but very useful BSDism */
3821     extern void _fwalk(int (*)(FILE *));
3822     _fwalk(&fflush);
3823     return 0;
3824 # else
3825 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3826     long open_max = -1;
3827 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3828     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3829 #   elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3830     open_max = sysconf(_SC_OPEN_MAX);
3831 #   elif defined(FOPEN_MAX)
3832     open_max = FOPEN_MAX;
3833 #   elif defined(OPEN_MAX)
3834     open_max = OPEN_MAX;
3835 #   elif defined(_NFILE)
3836     open_max = _NFILE;
3837 #   endif
3838     if (open_max > 0) {
3839       long i;
3840       for (i = 0; i < open_max; i++)
3841             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3842                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3843                 STDIO_STREAM_ARRAY[i]._flag)
3844                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3845       return 0;
3846     }
3847 #  endif
3848     SETERRNO(EBADF,RMS_IFI);
3849     return EOF;
3850 # endif
3851 #endif
3852 }
3853
3854 void
3855 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3856 {
3857     if (ckWARN(WARN_IO)) {
3858         HEK * const name
3859            = gv && (isGV_with_GP(gv))
3860                 ? GvENAME_HEK((gv))
3861                 : NULL;
3862         const char * const direction = have == '>' ? "out" : "in";
3863
3864         if (name && HEK_LEN(name))
3865             Perl_warner(aTHX_ packWARN(WARN_IO),
3866                         "Filehandle %" HEKf " opened only for %sput",
3867                         HEKfARG(name), direction);
3868         else
3869             Perl_warner(aTHX_ packWARN(WARN_IO),
3870                         "Filehandle opened only for %sput", direction);
3871     }
3872 }
3873
3874 void
3875 Perl_report_evil_fh(pTHX_ const GV *gv)
3876 {
3877     const IO *io = gv ? GvIO(gv) : NULL;
3878     const PERL_BITFIELD16 op = PL_op->op_type;
3879     const char *vile;
3880     I32 warn_type;
3881
3882     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3883         vile = "closed";
3884         warn_type = WARN_CLOSED;
3885     }
3886     else {
3887         vile = "unopened";
3888         warn_type = WARN_UNOPENED;
3889     }
3890
3891     if (ckWARN(warn_type)) {
3892         SV * const name
3893             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3894                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3895         const char * const pars =
3896             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3897         const char * const func =
3898             (const char *)
3899             (op == OP_READLINE || op == OP_RCATLINE
3900                                  ? "readline"  :        /* "<HANDLE>" not nice */
3901              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3902              PL_op_desc[op]);
3903         const char * const type =
3904             (const char *)
3905             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3906              ? "socket" : "filehandle");
3907         const bool have_name = name && SvCUR(name);
3908         Perl_warner(aTHX_ packWARN(warn_type),
3909                    "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3910                     have_name ? " " : "",
3911                     SVfARG(have_name ? name : &PL_sv_no));
3912         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3913                 Perl_warner(
3914                             aTHX_ packWARN(warn_type),
3915                         "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3916                         func, pars, have_name ? " " : "",
3917                         SVfARG(have_name ? name : &PL_sv_no)
3918                             );
3919     }
3920 }
3921
3922 /* To workaround core dumps from the uninitialised tm_zone we get the
3923  * system to give us a reasonable struct to copy.  This fix means that
3924  * strftime uses the tm_zone and tm_gmtoff values returned by
3925  * localtime(time()). That should give the desired result most of the
3926  * time. But probably not always!
3927  *
3928  * This does not address tzname aspects of NETaa14816.
3929  *
3930  */
3931
3932 #ifdef __GLIBC__
3933 # ifndef STRUCT_TM_HASZONE
3934 #    define STRUCT_TM_HASZONE
3935 # endif
3936 #endif
3937
3938 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3939 # ifndef HAS_TM_TM_ZONE
3940 #    define HAS_TM_TM_ZONE
3941 # endif
3942 #endif
3943
3944 void
3945 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3946 {
3947 #ifdef HAS_TM_TM_ZONE
3948     Time_t now;
3949     const struct tm* my_tm;
3950     PERL_UNUSED_CONTEXT;
3951     PERL_ARGS_ASSERT_INIT_TM;
3952     (void)time(&now);
3953     ENV_LOCALE_READ_LOCK;
3954     my_tm = localtime(&now);
3955     if (my_tm)
3956         Copy(my_tm, ptm, 1, struct tm);
3957     ENV_LOCALE_READ_UNLOCK;
3958 #else
3959     PERL_UNUSED_CONTEXT;
3960     PERL_ARGS_ASSERT_INIT_TM;
3961     PERL_UNUSED_ARG(ptm);
3962 #endif
3963 }
3964
3965 /*
3966 =for apidoc_section $time
3967 =for apidoc mini_mktime
3968 normalise S<C<struct tm>> values without the localtime() semantics (and
3969 overhead) of mktime().
3970
3971 =cut
3972  */
3973 void
3974 Perl_mini_mktime(struct tm *ptm)
3975 {
3976     int yearday;
3977     int secs;
3978     int month, mday, year, jday;
3979     int odd_cent, odd_year;
3980
3981     PERL_ARGS_ASSERT_MINI_MKTIME;
3982
3983 #define DAYS_PER_YEAR   365
3984 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3985 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3986 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3987 #define SECS_PER_HOUR   (60*60)
3988 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3989 /* parentheses deliberately absent on these two, otherwise they don't work */
3990 #define MONTH_TO_DAYS   153/5
3991 #define DAYS_TO_MONTH   5/153
3992 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3993 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3994 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3995 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3996
3997 /*
3998  * Year/day algorithm notes:
3999  *
4000  * With a suitable offset for numeric value of the month, one can find
4001  * an offset into the year by considering months to have 30.6 (153/5) days,
4002  * using integer arithmetic (i.e., with truncation).  To avoid too much
4003  * messing about with leap days, we consider January and February to be
4004  * the 13th and 14th month of the previous year.  After that transformation,
4005  * we need the month index we use to be high by 1 from 'normal human' usage,
4006  * so the month index values we use run from 4 through 15.
4007  *
4008  * Given that, and the rules for the Gregorian calendar (leap years are those
4009  * divisible by 4 unless also divisible by 100, when they must be divisible
4010  * by 400 instead), we can simply calculate the number of days since some
4011  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4012  * the days we derive from our month index, and adding in the day of the
4013  * month.  The value used here is not adjusted for the actual origin which
4014  * it normally would use (1 January A.D. 1), since we're not exposing it.
4015  * We're only building the value so we can turn around and get the
4016  * normalised values for the year, month, day-of-month, and day-of-year.
4017  *
4018  * For going backward, we need to bias the value we're using so that we find
4019  * the right year value.  (Basically, we don't want the contribution of
4020  * March 1st to the number to apply while deriving the year).  Having done
4021  * that, we 'count up' the contribution to the year number by accounting for
4022  * full quadracenturies (400-year periods) with their extra leap days, plus
4023  * the contribution from full centuries (to avoid counting in the lost leap
4024  * days), plus the contribution from full quad-years (to count in the normal
4025  * leap days), plus the leftover contribution from any non-leap years.
4026  * At this point, if we were working with an actual leap day, we'll have 0
4027  * days left over.  This is also true for March 1st, however.  So, we have
4028  * to special-case that result, and (earlier) keep track of the 'odd'
4029  * century and year contributions.  If we got 4 extra centuries in a qcent,
4030  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4031  * Otherwise, we add back in the earlier bias we removed (the 123 from
4032  * figuring in March 1st), find the month index (integer division by 30.6),
4033  * and the remainder is the day-of-month.  We then have to convert back to
4034  * 'real' months (including fixing January and February from being 14/15 in
4035  * the previous year to being in the proper year).  After that, to get
4036  * tm_yday, we work with the normalised year and get a new yearday value for
4037  * January 1st, which we subtract from the yearday value we had earlier,
4038  * representing the date we've re-built.  This is done from January 1
4039  * because tm_yday is 0-origin.
4040  *
4041  * Since POSIX time routines are only guaranteed to work for times since the
4042  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4043  * applies Gregorian calendar rules even to dates before the 16th century
4044  * doesn't bother me.  Besides, you'd need cultural context for a given
4045  * date to know whether it was Julian or Gregorian calendar, and that's
4046  * outside the scope for this routine.  Since we convert back based on the
4047  * same rules we used to build the yearday, you'll only get strange results
4048  * for input which needed normalising, or for the 'odd' century years which
4049  * were leap years in the Julian calendar but not in the Gregorian one.
4050  * I can live with that.
4051  *
4052  * This algorithm also fails to handle years before A.D. 1 gracefully, but
4053  * that's still outside the scope for POSIX time manipulation, so I don't
4054  * care.
4055  *
4056  * - lwall
4057  */
4058
4059     year = 1900 + ptm->tm_year;
4060     month = ptm->tm_mon;
4061     mday = ptm->tm_mday;
4062     jday = 0;
4063     if (month >= 2)
4064         month+=2;
4065     else
4066         month+=14, year--;
4067     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4068     yearday += month*MONTH_TO_DAYS + mday + jday;
4069     /*
4070      * Note that we don't know when leap-seconds were or will be,
4071      * so we have to trust the user if we get something which looks
4072      * like a sensible leap-second.  Wild values for seconds will
4073      * be rationalised, however.
4074      */
4075     if ((unsigned) ptm->tm_sec <= 60) {
4076         secs = 0;
4077     }
4078     else {
4079         secs = ptm->tm_sec;
4080         ptm->tm_sec = 0;
4081     }
4082     secs += 60 * ptm->tm_min;
4083     secs += SECS_PER_HOUR * ptm->tm_hour;
4084     if (secs < 0) {
4085         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4086             /* got negative remainder, but need positive time */
4087             /* back off an extra day to compensate */
4088             yearday += (secs/SECS_PER_DAY)-1;
4089             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4090         }
4091         else {
4092             yearday += (secs/SECS_PER_DAY);
4093             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4094         }
4095     }
4096     else if (secs >= SECS_PER_DAY) {
4097         yearday += (secs/SECS_PER_DAY);
4098         secs %= SECS_PER_DAY;
4099     }
4100     ptm->tm_hour = secs/SECS_PER_HOUR;
4101     secs %= SECS_PER_HOUR;
4102     ptm->tm_min = secs/60;
4103     secs %= 60;
4104     ptm->tm_sec += secs;
4105     /* done with time of day effects */
4106     /*
4107      * The algorithm for yearday has (so far) left it high by 428.
4108      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4109      * bias it by 123 while trying to figure out what year it
4110      * really represents.  Even with this tweak, the reverse
4111      * translation fails for years before A.D. 0001.
4112      * It would still fail for Feb 29, but we catch that one below.
4113      */
4114     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
4115     yearday -= YEAR_ADJUST;
4116     year = (yearday / DAYS_PER_QCENT) * 400;
4117     yearday %= DAYS_PER_QCENT;
4118     odd_cent = yearday / DAYS_PER_CENT;
4119     year += odd_cent * 100;
4120     yearday %= DAYS_PER_CENT;
4121     year += (yearday / DAYS_PER_QYEAR) * 4;
4122     yearday %= DAYS_PER_QYEAR;
4123     odd_year = yearday / DAYS_PER_YEAR;
4124     year += odd_year;
4125     yearday %= DAYS_PER_YEAR;
4126     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4127         month = 1;
4128         yearday = 29;
4129     }
4130     else {
4131         yearday += YEAR_ADJUST; /* recover March 1st crock */
4132         month = yearday*DAYS_TO_MONTH;
4133         yearday -= month*MONTH_TO_DAYS;
4134         /* recover other leap-year adjustment */
4135         if (month > 13) {
4136             month-=14;
4137             year++;
4138         }
4139         else {
4140             month-=2;
4141         }
4142     }
4143     ptm->tm_year = year - 1900;
4144     if (yearday) {
4145       ptm->tm_mday = yearday;
4146       ptm->tm_mon = month;
4147     }
4148     else {
4149       ptm->tm_mday = 31;
4150       ptm->tm_mon = month - 1;
4151     }
4152     /* re-build yearday based on Jan 1 to get tm_yday */
4153     year--;
4154     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4155     yearday += 14*MONTH_TO_DAYS + 1;
4156     ptm->tm_yday = jday - yearday;
4157     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4158 }
4159
4160 char *
4161 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)
4162 {
4163 #ifdef HAS_STRFTIME
4164
4165 /*
4166 =for apidoc_section $time
4167 =for apidoc my_strftime
4168 strftime(), but with a different API so that the return value is a pointer
4169 to the formatted result (which MUST be arranged to be FREED BY THE
4170 CALLER).  This allows this function to increase the buffer size as needed,
4171 so that the caller doesn't have to worry about that.
4172
4173 Note that yday and wday effectively are ignored by this function, as
4174 mini_mktime() overwrites them
4175
4176 Also note that this is always executed in the underlying locale of the program,
4177 giving localized results.
4178
4179 =cut
4180  */
4181
4182   char *buf;
4183   int buflen;
4184   struct tm mytm;
4185   int len;
4186
4187   PERL_ARGS_ASSERT_MY_STRFTIME;
4188
4189   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4190   mytm.tm_sec = sec;
4191   mytm.tm_min = min;
4192   mytm.tm_hour = hour;
4193   mytm.tm_mday = mday;
4194   mytm.tm_mon = mon;
4195   mytm.tm_year = year;
4196   mytm.tm_wday = wday;
4197   mytm.tm_yday = yday;
4198   mytm.tm_isdst = isdst;
4199   mini_mktime(&mytm);
4200   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4201 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4202   STMT_START {
4203     struct tm mytm2;
4204     mytm2 = mytm;
4205     mktime(&mytm2);
4206 #ifdef HAS_TM_TM_GMTOFF
4207     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4208 #endif
4209 #ifdef HAS_TM_TM_ZONE
4210     mytm.tm_zone = mytm2.tm_zone;
4211 #endif
4212   } STMT_END;
4213 #endif
4214   buflen = 64;
4215   Newx(buf, buflen, char);
4216
4217   GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
4218   len = strftime(buf, buflen, fmt, &mytm);
4219   GCC_DIAG_RESTORE_STMT;
4220
4221   /*
4222   ** The following is needed to handle to the situation where
4223   ** tmpbuf overflows.  Basically we want to allocate a buffer
4224   ** and try repeatedly.  The reason why it is so complicated
4225   ** is that getting a return value of 0 from strftime can indicate
4226   ** one of the following:
4227   ** 1. buffer overflowed,
4228   ** 2. illegal conversion specifier, or
4229   ** 3. the format string specifies nothing to be returned(not
4230   **      an error).  This could be because format is an empty string
4231   **    or it specifies %p that yields an empty string in some locale.
4232   ** If there is a better way to make it portable, go ahead by
4233   ** all means.
4234   */
4235   if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
4236     return buf;
4237   else {
4238     /* Possibly buf overflowed - try again with a bigger buf */
4239     const int fmtlen = strlen(fmt);
4240     int bufsize = fmtlen + buflen;
4241
4242     Renew(buf, bufsize, char);
4243     while (buf) {
4244
4245       GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
4246       buflen = strftime(buf, bufsize, fmt, &mytm);
4247       GCC_DIAG_RESTORE_STMT;
4248
4249       if (inRANGE(buflen, 1, bufsize - 1))
4250         break;
4251       /* heuristic to prevent out-of-memory errors */
4252       if (bufsize > 100*fmtlen) {
4253         Safefree(buf);
4254         buf = NULL;
4255         break;
4256       }
4257       bufsize *= 2;
4258       Renew(buf, bufsize, char);
4259     }
4260     return buf;
4261   }
4262 #else
4263   Perl_croak(aTHX_ "panic: no strftime");
4264   return NULL;
4265 #endif
4266 }
4267
4268
4269 #define SV_CWD_RETURN_UNDEF \
4270     sv_set_undef(sv); \
4271     return FALSE
4272
4273 #define SV_CWD_ISDOT(dp) \
4274     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4275         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4276
4277 /*
4278 =for apidoc_section $utility
4279
4280 =for apidoc getcwd_sv
4281
4282 Fill C<sv> with current working directory
4283
4284 =cut
4285 */
4286
4287 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4288  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4289  * getcwd(3) if available
4290  * Comments from the original:
4291  *     This is a faster version of getcwd.  It's also more dangerous
4292  *     because you might chdir out of a directory that you can't chdir
4293  *     back into. */
4294
4295 int
4296 Perl_getcwd_sv(pTHX_ SV *sv)
4297 {
4298 #ifndef PERL_MICRO
4299     SvTAINTED_on(sv);
4300
4301     PERL_ARGS_ASSERT_GETCWD_SV;
4302
4303 #ifdef HAS_GETCWD
4304     {
4305         char buf[MAXPATHLEN];
4306
4307         /* Some getcwd()s automatically allocate a buffer of the given
4308          * size from the heap if they are given a NULL buffer pointer.
4309          * The problem is that this behaviour is not portable. */
4310         if (getcwd(buf, sizeof(buf) - 1)) {
4311             sv_setpv(sv, buf);
4312             return TRUE;
4313         }
4314         else {
4315             SV_CWD_RETURN_UNDEF;
4316         }
4317     }
4318
4319 #else
4320
4321     Stat_t statbuf;
4322     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4323     int pathlen=0;
4324     Direntry_t *dp;
4325
4326     SvUPGRADE(sv, SVt_PV);
4327
4328     if (PerlLIO_lstat(".", &statbuf) < 0) {
4329         SV_CWD_RETURN_UNDEF;
4330     }
4331
4332     orig_cdev = statbuf.st_dev;
4333     orig_cino = statbuf.st_ino;
4334     cdev = orig_cdev;
4335     cino = orig_cino;
4336
4337     for (;;) {
4338         DIR *dir;
4339         int namelen;
4340         odev = cdev;
4341         oino = cino;
4342
4343         if (PerlDir_chdir("..") < 0) {
4344             SV_CWD_RETURN_UNDEF;
4345         }
4346         if (PerlLIO_stat(".", &statbuf) < 0) {
4347             SV_CWD_RETURN_UNDEF;
4348         }
4349
4350         cdev = statbuf.st_dev;
4351         cino = statbuf.st_ino;
4352
4353         if (odev == cdev && oino == cino) {
4354             break;
4355         }
4356         if (!(dir = PerlDir_open("."))) {
4357             SV_CWD_RETURN_UNDEF;
4358         }
4359
4360         while ((dp = PerlDir_read(dir)) != NULL) {
4361 #ifdef DIRNAMLEN
4362             namelen = dp->d_namlen;
4363 #else
4364             namelen = strlen(dp->d_name);
4365 #endif
4366             /* skip . and .. */
4367             if (SV_CWD_ISDOT(dp)) {
4368                 continue;
4369             }
4370
4371             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4372                 SV_CWD_RETURN_UNDEF;
4373             }
4374
4375             tdev = statbuf.st_dev;
4376             tino = statbuf.st_ino;
4377             if (tino == oino && tdev == odev) {
4378                 break;
4379             }
4380         }
4381
4382         if (!dp) {
4383             SV_CWD_RETURN_UNDEF;
4384         }
4385
4386         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4387             SV_CWD_RETURN_UNDEF;
4388         }
4389
4390         SvGROW(sv, pathlen + namelen + 1);
4391
4392         if (pathlen) {
4393             /* shift down */
4394             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4395         }
4396
4397         /* prepend current directory to the front */
4398         *SvPVX(sv) = '/';
4399         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4400         pathlen += (namelen + 1);
4401
4402 #ifdef VOID_CLOSEDIR
4403         PerlDir_close(dir);
4404 #else
4405         if (PerlDir_close(dir) < 0) {
4406             SV_CWD_RETURN_UNDEF;
4407         }
4408 #endif
4409     }
4410
4411     if (pathlen) {
4412         SvCUR_set(sv, pathlen);
4413         *SvEND(sv) = '\0';
4414         SvPOK_only(sv);
4415
4416         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4417             SV_CWD_RETURN_UNDEF;
4418         }
4419     }
4420     if (PerlLIO_stat(".", &statbuf) < 0) {
4421         SV_CWD_RETURN_UNDEF;
4422     }
4423
4424     cdev = statbuf.st_dev;
4425     cino = statbuf.st_ino;
4426
4427     if (cdev != orig_cdev || cino != orig_cino) {
4428         Perl_croak(aTHX_ "Unstable directory path, "
4429                    "current directory changed unexpectedly");
4430     }
4431
4432     return TRUE;
4433 #endif
4434
4435 #else
4436     return FALSE;
4437 #endif
4438 }
4439
4440 #include "vutil.c"
4441
4442 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4443 #   define EMULATE_SOCKETPAIR_UDP
4444 #endif
4445
4446 #ifdef EMULATE_SOCKETPAIR_UDP
4447 static int
4448 S_socketpair_udp (int fd[2]) {
4449     dTHX;
4450     /* Fake a datagram socketpair using UDP to localhost.  */
4451     int sockets[2] = {-1, -1};
4452     struct sockaddr_in addresses[2];
4453     int i;
4454     Sock_size_t size = sizeof(struct sockaddr_in);
4455     unsigned short port;
4456     int got;
4457
4458     memset(&addresses, 0, sizeof(addresses));
4459     i = 1;
4460     do {
4461         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4462         if (sockets[i] == -1)
4463             goto tidy_up_and_fail;
4464
4465         addresses[i].sin_family = AF_INET;
4466         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4467         addresses[i].sin_port = 0;      /* kernel choses port.  */
4468         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4469                 sizeof(struct sockaddr_in)) == -1)
4470             goto tidy_up_and_fail;
4471     } while (i--);
4472
4473     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4474        for each connect the other socket to it.  */
4475     i = 1;
4476     do {
4477         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4478                 &size) == -1)
4479             goto tidy_up_and_fail;
4480         if (size != sizeof(struct sockaddr_in))
4481             goto abort_tidy_up_and_fail;
4482         /* !1 is 0, !0 is 1 */
4483         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4484                 sizeof(struct sockaddr_in)) == -1)
4485             goto tidy_up_and_fail;
4486     } while (i--);
4487
4488     /* Now we have 2 sockets connected to each other. I don't trust some other
4489        process not to have already sent a packet to us (by random) so send
4490        a packet from each to the other.  */
4491     i = 1;
4492     do {
4493         /* I'm going to send my own port number.  As a short.
4494            (Who knows if someone somewhere has sin_port as a bitfield and needs
4495            this routine. (I'm assuming crays have socketpair)) */
4496         port = addresses[i].sin_port;
4497         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4498         if (got != sizeof(port)) {
4499             if (got == -1)
4500                 goto tidy_up_and_fail;
4501             goto abort_tidy_up_and_fail;
4502         }
4503     } while (i--);
4504
4505     /* Packets sent. I don't trust them to have arrived though.
4506        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4507        connect to localhost will use a second kernel thread. In 2.6 the
4508        first thread running the connect() returns before the second completes,
4509        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4510        returns 0. Poor programs have tripped up. One poor program's authors'
4511        had a 50-1 reverse stock split. Not sure how connected these were.)
4512        So I don't trust someone not to have an unpredictable UDP stack.
4513     */
4514
4515     {
4516         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4517         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4518         fd_set rset;
4519
4520         FD_ZERO(&rset);
4521         FD_SET((unsigned int)sockets[0], &rset);
4522         FD_SET((unsigned int)sockets[1], &rset);
4523
4524         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4525         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4526                 || !FD_ISSET(sockets[1], &rset)) {
4527             /* I hope this is portable and appropriate.  */
4528             if (got == -1)
4529                 goto tidy_up_and_fail;
4530             goto abort_tidy_up_and_fail;
4531         }
4532     }
4533
4534     /* And the paranoia department even now doesn't trust it to have arrive
4535        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4536     {
4537         struct sockaddr_in readfrom;
4538         unsigned short buffer[2];
4539
4540         i = 1;
4541         do {
4542 #ifdef MSG_DONTWAIT
4543             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4544                     sizeof(buffer), MSG_DONTWAIT,
4545                     (struct sockaddr *) &readfrom, &size);
4546 #else
4547             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4548                     sizeof(buffer), 0,
4549                     (struct sockaddr *) &readfrom, &size);
4550 #endif
4551
4552             if (got == -1)
4553                 goto tidy_up_and_fail;
4554             if (got != sizeof(port)
4555                     || size != sizeof(struct sockaddr_in)
4556                     /* Check other socket sent us its port.  */
4557                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4558                     /* Check kernel says we got the datagram from that socket */
4559                     || readfrom.sin_family != addresses[!i].sin_family
4560                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4561                     || readfrom.sin_port != addresses[!i].sin_port)
4562                 goto abort_tidy_up_and_fail;
4563         } while (i--);
4564     }
4565     /* My caller (my_socketpair) has validated that this is non-NULL  */
4566     fd[0] = sockets[0];
4567     fd[1] = sockets[1];
4568     /* I hereby declare this connection open.  May God bless all who cross
4569        her.  */
4570     return 0;
4571
4572   abort_tidy_up_and_fail:
4573     errno = ECONNABORTED;
4574   tidy_up_and_fail:
4575     {
4576         dSAVE_ERRNO;
4577         if (sockets[0] != -1)
4578             PerlLIO_close(sockets[0]);
4579         if (sockets[1] != -1)
4580             PerlLIO_close(sockets[1]);
4581         RESTORE_ERRNO;
4582         return -1;
4583     }
4584 }
4585 #endif /*  EMULATE_SOCKETPAIR_UDP */
4586
4587 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4588 int
4589 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4590     /* Stevens says that family must be AF_LOCAL, protocol 0.
4591        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4592     dTHXa(NULL);
4593     int listener = -1;
4594     int connector = -1;
4595     int acceptor = -1;
4596     struct sockaddr_in listen_addr;
4597     struct sockaddr_in connect_addr;
4598     Sock_size_t size;
4599
4600     if (protocol
4601 #ifdef AF_UNIX
4602         || family != AF_UNIX
4603 #endif
4604     ) {
4605         errno = EAFNOSUPPORT;
4606         return -1;
4607     }
4608     if (!fd) {
4609         errno = EINVAL;
4610         return -1;
4611     }
4612
4613 #ifdef SOCK_CLOEXEC
4614     type &= ~SOCK_CLOEXEC;
4615 #endif
4616
4617 #ifdef EMULATE_SOCKETPAIR_UDP
4618     if (type == SOCK_DGRAM)
4619         return S_socketpair_udp(fd);
4620 #endif
4621
4622     aTHXa(PERL_GET_THX);
4623     listener = PerlSock_socket(AF_INET, type, 0);
4624     if (listener == -1)
4625         return -1;
4626     memset(&listen_addr, 0, sizeof(listen_addr));
4627     listen_addr.sin_family = AF_INET;
4628     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4629     listen_addr.sin_port = 0;   /* kernel choses port.  */
4630     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4631             sizeof(listen_addr)) == -1)
4632         goto tidy_up_and_fail;
4633     if (PerlSock_listen(listener, 1) == -1)
4634         goto tidy_up_and_fail;
4635
4636     connector = PerlSock_socket(AF_INET, type, 0);
4637     if (connector == -1)
4638         goto tidy_up_and_fail;
4639     /* We want to find out the port number to connect to.  */
4640     size = sizeof(connect_addr);
4641     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4642             &size) == -1)
4643         goto tidy_up_and_fail;
4644     if (size != sizeof(connect_addr))
4645         goto abort_tidy_up_and_fail;
4646     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4647             sizeof(connect_addr)) == -1)
4648         goto tidy_up_and_fail;
4649
4650     size = sizeof(listen_addr);
4651     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4652             &size);
4653     if (acceptor == -1)
4654         goto tidy_up_and_fail;
4655     if (size != sizeof(listen_addr))
4656         goto abort_tidy_up_and_fail;
4657     PerlLIO_close(listener);
4658     /* Now check we are talking to ourself by matching port and host on the
4659        two sockets.  */
4660     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4661             &size) == -1)
4662         goto tidy_up_and_fail;
4663     if (size != sizeof(connect_addr)
4664             || listen_addr.sin_family != connect_addr.sin_family
4665             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4666             || listen_addr.sin_port != connect_addr.sin_port) {
4667         goto abort_tidy_up_and_fail;
4668     }
4669     fd[0] = connector;
4670     fd[1] = acceptor;
4671     return 0;
4672
4673   abort_tidy_up_and_fail:
4674 #ifdef ECONNABORTED
4675   errno = ECONNABORTED; /* This would be the standard thing to do. */
4676 #elif defined(ECONNREFUSED)
4677   errno = ECONNREFUSED; /* some OSes might not have ECONNABORTED. */
4678 #else
4679   errno = ETIMEDOUT;    /* Desperation time. */
4680 #endif
4681   tidy_up_and_fail:
4682     {
4683         dSAVE_ERRNO;
4684         if (listener != -1)
4685             PerlLIO_close(listener);
4686         if (connector != -1)
4687             PerlLIO_close(connector);
4688         if (acceptor != -1)
4689             PerlLIO_close(acceptor);
4690         RESTORE_ERRNO;
4691         return -1;
4692     }
4693 }
4694 #else
4695 /* In any case have a stub so that there's code corresponding
4696  * to the my_socketpair in embed.fnc. */
4697 int
4698 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4699 #ifdef HAS_SOCKETPAIR
4700     return socketpair(family, type, protocol, fd);
4701 #else
4702     return -1;
4703 #endif
4704 }
4705 #endif
4706
4707 /*
4708
4709 =for apidoc sv_nosharing
4710
4711 Dummy routine which "shares" an SV when there is no sharing module present.
4712 Or "locks" it.  Or "unlocks" it.  In other
4713 words, ignores its single SV argument.
4714 Exists to avoid test for a C<NULL> function pointer and because it could
4715 potentially warn under some level of strict-ness.
4716
4717 =cut
4718 */
4719
4720 void
4721 Perl_sv_nosharing(pTHX_ SV *sv)
4722 {
4723     PERL_UNUSED_CONTEXT;
4724     PERL_UNUSED_ARG(sv);
4725 }
4726
4727 /*
4728
4729 =for apidoc sv_destroyable
4730
4731 Dummy routine which reports that object can be destroyed when there is no
4732 sharing module present.  It ignores its single SV argument, and returns
4733 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4734 could potentially warn under some level of strict-ness.
4735
4736 =cut
4737 */
4738
4739 bool
4740 Perl_sv_destroyable(pTHX_ SV *sv)
4741 {
4742     PERL_UNUSED_CONTEXT;
4743     PERL_UNUSED_ARG(sv);
4744     return TRUE;
4745 }
4746
4747 U32
4748 Perl_parse_unicode_opts(pTHX_ const char **popt)
4749 {
4750   const char *p = *popt;
4751   U32 opt = 0;
4752
4753   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4754
4755   if (*p) {
4756        if (isDIGIT(*p)) {
4757             const char* endptr = p + strlen(p);
4758             UV uv;
4759             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4760                 opt = (U32)uv;
4761                 p = endptr;
4762                 if (p && *p && *p != '\n' && *p != '\r') {
4763                     if (isSPACE(*p))
4764                         goto the_end_of_the_opts_parser;
4765                     else
4766                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4767                 }
4768             }
4769             else {
4770                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4771             }
4772         }
4773         else {
4774             for (; *p; p++) {
4775                  switch (*p) {
4776                  case PERL_UNICODE_STDIN:
4777                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4778                  case PERL_UNICODE_STDOUT:
4779                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4780                  case PERL_UNICODE_STDERR:
4781                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4782                  case PERL_UNICODE_STD:
4783                       opt |= PERL_UNICODE_STD_FLAG;     break;
4784                  case PERL_UNICODE_IN:
4785                       opt |= PERL_UNICODE_IN_FLAG;      break;
4786                  case PERL_UNICODE_OUT:
4787                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4788                  case PERL_UNICODE_INOUT:
4789                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4790                  case PERL_UNICODE_LOCALE:
4791                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4792                  case PERL_UNICODE_ARGV:
4793                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4794                  case PERL_UNICODE_UTF8CACHEASSERT:
4795                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4796                  default:
4797                       if (*p != '\n' && *p != '\r') {
4798                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4799                         else
4800                           Perl_croak(aTHX_
4801                                      "Unknown Unicode option letter '%c'", *p);
4802                       }
4803                  }
4804             }
4805        }
4806   }
4807   else
4808        opt = PERL_UNICODE_DEFAULT_FLAGS;
4809
4810   the_end_of_the_opts_parser:
4811
4812   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4813        Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4814                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4815
4816   *popt = p;
4817
4818   return opt;
4819 }
4820
4821 #ifdef VMS
4822 #  include <starlet.h>
4823 #endif
4824
4825 U32
4826 Perl_seed(pTHX)
4827 {
4828     /*
4829      * This is really just a quick hack which grabs various garbage
4830      * values.  It really should be a real hash algorithm which
4831      * spreads the effect of every input bit onto every output bit,
4832      * if someone who knows about such things would bother to write it.
4833      * Might be a good idea to add that function to CORE as well.
4834      * No numbers below come from careful analysis or anything here,
4835      * except they are primes and SEED_C1 > 1E6 to get a full-width
4836      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4837      * probably be bigger too.
4838      */
4839 #if RANDBITS > 16
4840 #  define SEED_C1       1000003
4841 #define   SEED_C4       73819
4842 #else
4843 #  define SEED_C1       25747
4844 #define   SEED_C4       20639
4845 #endif
4846 #define   SEED_C2       3
4847 #define   SEED_C3       269
4848 #define   SEED_C5       26107
4849
4850 #ifndef PERL_NO_DEV_RANDOM
4851     int fd;
4852 #endif
4853     U32 u;
4854 #ifdef HAS_GETTIMEOFDAY
4855     struct timeval when;
4856 #else
4857     Time_t when;
4858 #endif
4859
4860 /* This test is an escape hatch, this symbol isn't set by Configure. */
4861 #ifndef PERL_NO_DEV_RANDOM
4862 #ifndef PERL_RANDOM_DEVICE
4863    /* /dev/random isn't used by default because reads from it will block
4864     * if there isn't enough entropy available.  You can compile with
4865     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4866     * is enough real entropy to fill the seed. */
4867 #  ifdef __amigaos4__
4868 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4869 #  else
4870 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4871 #  endif
4872 #endif
4873     fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
4874     if (fd != -1) {
4875         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4876             u = 0;
4877         PerlLIO_close(fd);
4878         if (u)
4879             return u;
4880     }
4881 #endif
4882
4883 #ifdef HAS_GETTIMEOFDAY
4884     PerlProc_gettimeofday(&when,NULL);
4885     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4886 #else
4887     (void)time(&when);
4888     u = (U32)SEED_C1 * when;
4889 #endif
4890     u += SEED_C3 * (U32)PerlProc_getpid();
4891     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4892 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4893     u += SEED_C5 * (U32)PTR2UV(&when);
4894 #endif
4895     return u;
4896 }
4897
4898 void
4899 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4900 {
4901 #ifndef NO_PERL_HASH_ENV
4902     const char *env_pv;
4903 #endif
4904     unsigned long i;
4905
4906     PERL_ARGS_ASSERT_GET_HASH_SEED;
4907
4908 #ifndef NO_PERL_HASH_ENV
4909     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4910
4911     if ( env_pv )
4912     {
4913         /* ignore leading spaces */
4914         while (isSPACE(*env_pv))
4915             env_pv++;
4916 #    ifdef USE_PERL_PERTURB_KEYS
4917         /* if they set it to "0" we disable key traversal randomization completely */
4918         if (strEQ(env_pv,"0")) {
4919             PL_hash_rand_bits_enabled= 0;
4920         } else {
4921             /* otherwise switch to deterministic mode */
4922             PL_hash_rand_bits_enabled= 2;
4923         }
4924 #    endif
4925         /* ignore a leading 0x... if it is there */
4926         if (env_pv[0] == '0' && env_pv[1] == 'x')
4927             env_pv += 2;
4928
4929         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4930             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4931             if ( isXDIGIT(*env_pv)) {
4932                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4933             }
4934         }
4935         while (isSPACE(*env_pv))
4936             env_pv++;
4937
4938         if (*env_pv && !isXDIGIT(*env_pv)) {
4939             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4940         }
4941         /* should we check for unparsed crap? */
4942         /* should we warn about unused hex? */
4943         /* should we warn about insufficient hex? */
4944     }
4945     else
4946 #endif /* NO_PERL_HASH_ENV */
4947     {
4948         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4949             seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
4950         }
4951     }
4952 #ifdef USE_PERL_PERTURB_KEYS
4953     {   /* initialize PL_hash_rand_bits from the hash seed.
4954          * This value is highly volatile, it is updated every
4955          * hash insert, and is used as part of hash bucket chain
4956          * randomization and hash iterator randomization. */
4957         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4958         for( i = 0; i < sizeof(UV) ; i++ ) {
4959             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4960             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4961         }
4962     }
4963 #  ifndef NO_PERL_HASH_ENV
4964     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4965     if (env_pv) {
4966         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4967             PL_hash_rand_bits_enabled= 0;
4968         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4969             PL_hash_rand_bits_enabled= 1;
4970         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4971             PL_hash_rand_bits_enabled= 2;
4972         } else {
4973             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4974         }
4975     }
4976 #  endif
4977 #endif
4978 }
4979
4980 #ifdef PERL_MEM_LOG
4981
4982 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4983  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4984  * given, and you supply your own implementation.
4985  *
4986  * The default implementation reads a single env var, PERL_MEM_LOG,
4987  * expecting one or more of the following:
4988  *
4989  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4990  *    'm' - memlog      was PERL_MEM_LOG=1
4991  *    's' - svlog       was PERL_SV_LOG=1
4992  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4993  *
4994  * This makes the logger controllable enough that it can reasonably be
4995  * added to the system perl.
4996  */
4997
4998 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4999  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5000  */
5001 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5002
5003 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5004  * writes to.  In the default logger, this is settable at runtime.
5005  */
5006 #ifndef PERL_MEM_LOG_FD
5007 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5008 #endif
5009
5010 #ifndef PERL_MEM_LOG_NOIMPL
5011
5012 # ifdef DEBUG_LEAKING_SCALARS
5013 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5014 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5015 # else
5016 #   define SV_LOG_SERIAL_FMT
5017 #   define _SV_LOG_SERIAL_ARG(sv)
5018 # endif
5019
5020 static void
5021 S_mem_log_common(enum mem_log_type mlt, const UV n, 
5022                  const UV typesize, const char *type_name, const SV *sv,
5023                  Malloc_t oldalloc, Malloc_t newalloc,
5024                  const char *filename, const int linenumber,
5025                  const char *funcname)
5026 {
5027     const char *pmlenv;
5028     dTHX;
5029
5030     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5031
5032     PL_mem_log[0] |= 0x2;   /* Flag that the call is from this code */
5033     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5034     PL_mem_log[0] &= ~0x2;
5035     if (!pmlenv)
5036         return;
5037     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5038     {
5039         /* We can't use SVs or PerlIO for obvious reasons,
5040          * so we'll use stdio and low-level IO instead. */
5041         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5042
5043 #   ifdef HAS_GETTIMEOFDAY
5044 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5045 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5046         struct timeval tv;
5047         gettimeofday(&tv, 0);
5048 #   else
5049 #     define MEM_LOG_TIME_FMT   "%10d: "
5050 #     define MEM_LOG_TIME_ARG   (int)when
5051         Time_t when;
5052         (void)time(&when);
5053 #   endif
5054         /* If there are other OS specific ways of hires time than
5055          * gettimeofday() (see dist/Time-HiRes), the easiest way is
5056          * probably that they would be used to fill in the struct
5057          * timeval. */
5058         {
5059             STRLEN len;
5060             const char* endptr = pmlenv + strlen(pmlenv);
5061             int fd;
5062             UV uv;
5063             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
5064                 && uv && uv <= PERL_INT_MAX
5065             ) {
5066                 fd = (int)uv;
5067             } else {
5068                 fd = PERL_MEM_LOG_FD;
5069             }
5070
5071             if (strchr(pmlenv, 't')) {
5072                 len = my_snprintf(buf, sizeof(buf),
5073                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5074                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5075             }
5076             switch (mlt) {
5077             case MLT_ALLOC:
5078                 len = my_snprintf(buf, sizeof(buf),
5079                         "alloc: %s:%d:%s: %" IVdf " %" UVuf
5080                         " %s = %" IVdf ": %" UVxf "\n",
5081                         filename, linenumber, funcname, n, typesize,
5082                         type_name, n * typesize, PTR2UV(newalloc));
5083                 break;
5084             case MLT_REALLOC:
5085                 len = my_snprintf(buf, sizeof(buf),
5086                         "realloc: %s:%d:%s: %" IVdf " %" UVuf
5087                         " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
5088                         filename, linenumber, funcname, n, typesize,
5089                         type_name, n * typesize, PTR2UV(oldalloc),
5090                         PTR2UV(newalloc));
5091                 break;
5092             case MLT_FREE:
5093                 len = my_snprintf(buf, sizeof(buf),
5094                         "free: %s:%d:%s: %" UVxf "\n",
5095                         filename, linenumber, funcname,
5096                         PTR2UV(oldalloc));
5097                 break;
5098             case MLT_NEW_SV:
5099             case MLT_DEL_SV:
5100                 len = my_snprintf(buf, sizeof(buf),
5101                         "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
5102                         mlt == MLT_NEW_SV ? "new" : "del",
5103                         filename, linenumber, funcname,
5104                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5105                 break;
5106             default:
5107                 len = 0;
5108             }
5109             PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5110         }
5111     }
5112 }
5113 #endif /* !PERL_MEM_LOG_NOIMPL */
5114
5115 #ifndef PERL_MEM_LOG_NOIMPL
5116 # define \
5117     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5118     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5119 #else
5120 /* this is suboptimal, but bug compatible.  User is providing their
5121    own implementation, but is getting these functions anyway, and they
5122    do nothing. But _NOIMPL users should be able to cope or fix */
5123 # define \
5124     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5125     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5126 #endif
5127
5128 Malloc_t
5129 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5130                    Malloc_t newalloc, 
5131                    const char *filename, const int linenumber,
5132                    const char *funcname)
5133 {
5134     PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5135
5136     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5137                       NULL, NULL, newalloc,
5138                       filename, linenumber, funcname);
5139     return newalloc;
5140 }
5141
5142 Malloc_t
5143 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5144                      Malloc_t oldalloc, Malloc_t newalloc, 
5145                      const char *filename, const int linenumber, 
5146                      const char *funcname)
5147 {
5148     PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5149
5150     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5151                       NULL, oldalloc, newalloc, 
5152                       filename, linenumber, funcname);
5153     return newalloc;
5154 }
5155
5156 Malloc_t
5157 Perl_mem_log_free(Malloc_t oldalloc, 
5158                   const char *filename, const int linenumber, 
5159                   const char *funcname)
5160 {
5161     PERL_ARGS_ASSERT_MEM_LOG_FREE;
5162
5163     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
5164                       filename, linenumber, funcname);
5165     return oldalloc;
5166 }
5167
5168 void
5169 Perl_mem_log_new_sv(const SV *sv, 
5170                     const char *filename, const int linenumber,
5171                     const char *funcname)
5172 {
5173     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5174                       filename, linenumber, funcname);
5175 }
5176
5177 void
5178 Perl_mem_log_del_sv(const SV *sv,
5179                     const char *filename, const int linenumber, 
5180                     const char *funcname)
5181 {
5182     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
5183                       filename, linenumber, funcname);
5184 }
5185
5186 #endif /* PERL_MEM_LOG */
5187
5188 /*
5189 =for apidoc_section $string
5190 =for apidoc quadmath_format_valid
5191
5192 C<quadmath_snprintf()> is very strict about its C<format> string and will
5193 fail, returning -1, if the format is invalid.  It accepts exactly
5194 one format spec.
5195
5196 C<quadmath_format_valid()> checks that the intended single spec looks
5197 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
5198 and has C<Q> before it.  This is not a full "printf syntax check",
5199 just the basics.
5200
5201 Returns true if it is valid, false if not.
5202
5203 See also L</quadmath_format_needed>.
5204
5205 =cut
5206 */
5207 #ifdef USE_QUADMATH
5208 bool
5209 Perl_quadmath_format_valid(const char* format)
5210 {
5211     STRLEN len;
5212
5213     PERL_ARGS_ASSERT_QUADMATH_FORMAT_VALID;
5214
5215     if (format[0] != '%' || strchr(format + 1, '%'))
5216         return FALSE;
5217     len = strlen(format);
5218     /* minimum length three: %Qg */
5219     if (len < 3 || memCHRs("efgaEFGA", format[len - 1]) == NULL)
5220         return FALSE;
5221     if (format[len - 2] != 'Q')
5222         return FALSE;
5223     return TRUE;
5224 }
5225 #endif
5226
5227 /*
5228 =for apidoc quadmath_format_needed
5229
5230 C<quadmath_format_needed()> returns true if the C<format> string seems to
5231 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
5232 or returns false otherwise.
5233
5234 The format specifier detection is not complete printf-syntax detection,
5235 but it should catch most common cases.
5236
5237 If true is returned, those arguments B<should> in theory be processed
5238 with C<quadmath_snprintf()>, but in case there is more than one such
5239 format specifier (see L</quadmath_format_valid>), and if there is
5240 anything else beyond that one (even just a single byte), they
5241 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
5242 accepting only one format spec, and nothing else.
5243 In this case, the code should probably fail.
5244
5245 =cut
5246 */
5247 #ifdef USE_QUADMATH
5248 bool
5249 Perl_quadmath_format_needed(const char* format)
5250 {
5251   const char *p = format;
5252   const char *q;
5253
5254   PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5255
5256   while ((q = strchr(p, '%'))) {
5257     q++;
5258     if (*q == '+') /* plus */
5259       q++;
5260     if (*q == '#') /* alt */
5261       q++;
5262     if (*q == '*') /* width */
5263       q++;
5264     else {
5265       if (isDIGIT(*q)) {
5266         while (isDIGIT(*q)) q++;
5267       }
5268     }
5269     if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5270       q++;
5271       if (*q == '*')
5272         q++;
5273       else
5274         while (isDIGIT(*q)) q++;
5275     }
5276     if (memCHRs("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5277       return TRUE;
5278     p = q + 1;
5279   }
5280   return FALSE;
5281 }
5282 #endif
5283
5284 /*
5285 =for apidoc my_snprintf
5286
5287 The C library C<snprintf> functionality, if available and
5288 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5289 C<vsnprintf> is not available, will unfortunately use the unsafe
5290 C<vsprintf> which can overrun the buffer (there is an overrun check,
5291 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5292 getting C<vsnprintf>.
5293
5294 =cut
5295 */
5296 int
5297 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5298 {
5299     int retval = -1;
5300     va_list ap;
5301     PERL_ARGS_ASSERT_MY_SNPRINTF;
5302 #ifndef HAS_VSNPRINTF
5303     PERL_UNUSED_VAR(len);
5304 #endif
5305     va_start(ap, format);
5306 #ifdef USE_QUADMATH
5307     {
5308         bool quadmath_valid = FALSE;
5309         if (quadmath_format_valid(format)) {
5310             /* If the format looked promising, use it as quadmath. */
5311             retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
5312             if (retval == -1) {
5313                 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5314             }
5315             quadmath_valid = TRUE;
5316         }
5317         /* quadmath_format_single() will return false for example for
5318          * "foo = %g", or simply "%g".  We could handle the %g by
5319          * using quadmath for the NV args.  More complex cases of
5320          * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
5321          * quadmath-valid but has stuff in front).
5322          *
5323          * Handling the "Q-less" cases right would require walking
5324          * through the va_list and rewriting the format, calling
5325          * quadmath for the NVs, building a new va_list, and then
5326          * letting vsnprintf/vsprintf to take care of the other
5327          * arguments.  This may be doable.
5328          *
5329          * We do not attempt that now.  But for paranoia, we here try
5330          * to detect some common (but not all) cases where the
5331          * "Q-less" %[efgaEFGA] formats are present, and die if
5332          * detected.  This doesn't fix the problem, but it stops the
5333          * vsnprintf/vsprintf pulling doubles off the va_list when
5334          * __float128 NVs should be pulled off instead.
5335          *
5336          * If quadmath_format_needed() returns false, we are reasonably
5337          * certain that we can call vnsprintf() or vsprintf() safely. */
5338         if (!quadmath_valid && quadmath_format_needed(format))
5339           Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5340
5341     }
5342 #endif
5343     if (retval == -1)
5344 #ifdef HAS_VSNPRINTF
5345         retval = vsnprintf(buffer, len, format, ap);
5346 #else
5347         retval = vsprintf(buffer, format, ap);
5348 #endif
5349     va_end(ap);
5350     /* vsprintf() shows failure with < 0 */
5351     if (retval < 0
5352 #ifdef HAS_VSNPRINTF
5353     /* vsnprintf() shows failure with >= len */
5354         ||
5355         (len > 0 && (Size_t)retval >= len)
5356 #endif
5357     )
5358         Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5359     return retval;
5360 }
5361
5362 /*
5363 =for apidoc my_vsnprintf
5364
5365 The C library C<vsnprintf> if available and standards-compliant.
5366 However, if the C<vsnprintf> is not available, will unfortunately
5367 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5368 overrun check, but that may be too late).  Consider using
5369 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5370
5371 =cut
5372 */
5373 int
5374 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5375 {
5376 #ifdef USE_QUADMATH
5377     PERL_UNUSED_ARG(buffer);
5378     PERL_UNUSED_ARG(len);
5379     PERL_UNUSED_ARG(format);
5380     /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
5381     PERL_UNUSED_ARG((void*)ap);
5382     Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5383     return 0;
5384 #else
5385     int retval;
5386 #ifdef NEED_VA_COPY
5387     va_list apc;
5388
5389     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5390     Perl_va_copy(ap, apc);
5391 # ifdef HAS_VSNPRINTF
5392     retval = vsnprintf(buffer, len, format, apc);
5393 # else
5394     PERL_UNUSED_ARG(len);
5395     retval = vsprintf(buffer, format, apc);
5396 # endif
5397     va_end(apc);
5398 #else
5399 # ifdef HAS_VSNPRINTF
5400     retval = vsnprintf(buffer, len, format, ap);
5401 # else
5402     PERL_UNUSED_ARG(len);
5403     retval = vsprintf(buffer, format, ap);
5404 # endif
5405 #endif /* #ifdef NEED_VA_COPY */
5406     /* vsprintf() shows failure with < 0 */
5407     if (retval < 0
5408 #ifdef HAS_VSNPRINTF
5409     /* vsnprintf() shows failure with >= len */
5410         ||
5411         (len > 0 && (Size_t)retval >= len)
5412 #endif
5413     )
5414         Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5415     return retval;
5416 #endif
5417 }
5418
5419 void
5420 Perl_my_clearenv(pTHX)
5421 {
5422 #if ! defined(PERL_MICRO)
5423 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5424     PerlEnv_clearenv();
5425 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5426 #    if defined(USE_ENVIRON_ARRAY)
5427 #      if defined(USE_ITHREADS)
5428     /* only the parent thread can clobber the process environment, so no need
5429      * to use a mutex */
5430     if (PL_curinterp == aTHX)
5431 #      endif /* USE_ITHREADS */
5432     {
5433 #      if ! defined(PERL_USE_SAFE_PUTENV)
5434     if ( !PL_use_safe_putenv) {
5435       I32 i;
5436       if (environ == PL_origenviron)
5437         environ = (char**)safesysmalloc(sizeof(char*));
5438       else
5439         for (i = 0; environ[i]; i++)
5440           (void)safesysfree(environ[i]);
5441     }
5442     environ[0] = NULL;
5443 #      else /* PERL_USE_SAFE_PUTENV */
5444 #        if defined(HAS_CLEARENV)
5445     (void)clearenv();
5446 #        elif defined(HAS_UNSETENV)
5447     int bsiz = 80; /* Most envvar names will be shorter than this. */
5448     char *buf = (char*)safesysmalloc(bsiz);
5449     while (*environ != NULL) {
5450       char *e = strchr(*environ, '=');
5451       int l = e ? e - *environ : (int)strlen(*environ);
5452       if (bsiz < l + 1) {
5453         (void)safesysfree(buf);
5454         bsiz = l + 1; /* + 1 for the \0. */
5455         buf = (char*)safesysmalloc(bsiz);
5456       } 
5457       memcpy(buf, *environ, l);
5458       buf[l] = '\0';
5459       (void)unsetenv(buf);
5460     }
5461     (void)safesysfree(buf);
5462 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5463     /* Just null environ and accept the leakage. */
5464     *environ = NULL;
5465 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5466 #      endif /* ! PERL_USE_SAFE_PUTENV */
5467     }
5468 #    endif /* USE_ENVIRON_ARRAY */
5469 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5470 #endif /* PERL_MICRO */
5471 }
5472
5473 #ifdef PERL_IMPLICIT_CONTEXT
5474
5475
5476 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5477 the global PL_my_cxt_index is incremented, and that value is assigned to
5478 that module's static my_cxt_index (who's address is passed as an arg).
5479 Then, for each interpreter this function is called for, it makes sure a
5480 void* slot is available to hang the static data off, by allocating or
5481 extending the interpreter's PL_my_cxt_list array */
5482
5483 void *
5484 Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
5485 {
5486     void *p;
5487     int index;
5488
5489     PERL_ARGS_ASSERT_MY_CXT_INIT;
5490
5491     index = *indexp;
5492     /* do initial check without locking.
5493      * -1:    not allocated or another thread currently allocating
5494      *  other: already allocated by another thread
5495      */
5496     if (index == -1) {
5497         MUTEX_LOCK(&PL_my_ctx_mutex);
5498         /*now a stricter check with locking */
5499         index = *indexp;
5500         if (index == -1)
5501             /* this module hasn't been allocated an index yet */
5502             *indexp = PL_my_cxt_index++;
5503         index = *indexp;
5504         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5505     }
5506
5507     /* make sure the array is big enough */
5508     if (PL_my_cxt_size <= index) {
5509         if (PL_my_cxt_size) {
5510             IV new_size = PL_my_cxt_size;
5511             while (new_size <= index)
5512                 new_size *= 2;
5513             Renew(PL_my_cxt_list, new_size, void *);
5514             PL_my_cxt_size = new_size;
5515         }
5516         else {
5517             PL_my_cxt_size = 16;
5518             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5519         }
5520     }
5521     /* newSV() allocates one more than needed */
5522     p = (void*)SvPVX(newSV(size-1));
5523     PL_my_cxt_list[index] = p;
5524     Zero(p, size, char);
5525     return p;
5526 }
5527
5528 #endif /* PERL_IMPLICIT_CONTEXT */
5529
5530
5531 /* Perl_xs_handshake():
5532    implement the various XS_*_BOOTCHECK macros, which are added to .c
5533    files by ExtUtils::ParseXS, to check that the perl the module was built
5534    with is binary compatible with the running perl.
5535
5536    usage:
5537        Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5538             [U32 items, U32 ax], [char * api_version], [char * xs_version])
5539
5540    The meaning of the varargs is determined the U32 key arg (which is not
5541    a format string). The fields of key are assembled by using HS_KEY().
5542
5543    Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5544    "PerlInterpreter *" and represents the callers context; otherwise it is
5545    of type "CV *", and is the boot xsub's CV.
5546
5547    v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5548    for example, and IO.dll was linked with threaded perl524.dll, and both
5549    perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5550    successfully can load IO.dll into the process but simultaneously it
5551    loaded an interpreter of a different version into the process, and XS
5552    code will naturally pass SV*s created by perl524.dll for perl526.dll to
5553    use through perl526.dll's my_perl->Istack_base.
5554
5555    v_my_perl cannot be the first arg, since then 'key' will be out of
5556    place in a threaded vs non-threaded mixup; and analyzing the key
5557    number's bitfields won't reveal the problem, since it will be a valid
5558    key (unthreaded perl) on interp side, but croak will report the XS mod's
5559    key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5560    it's a threaded perl and an unthreaded XS module, threaded perl will
5561    look at an uninit C stack or an uninit register to get 'key'
5562    (remember that it assumes that the 1st arg is the interp cxt).
5563
5564    'file' is the source filename of the caller.
5565 */
5566
5567 I32
5568 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
5569 {
5570     va_list args;
5571     U32 items, ax;
5572     void * got;
5573     void * need;
5574 #ifdef PERL_IMPLICIT_CONTEXT
5575     dTHX;
5576     tTHX xs_interp;
5577 #else
5578     CV* cv;
5579     SV *** xs_spp;
5580 #endif
5581     PERL_ARGS_ASSERT_XS_HANDSHAKE;
5582     va_start(args, file);
5583
5584     got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
5585     need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
5586     if (UNLIKELY(got != need))
5587         goto bad_handshake;
5588 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5589    by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5590    2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5591    dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5592    passed to the XS DLL */
5593 #ifdef PERL_IMPLICIT_CONTEXT
5594     xs_interp = (tTHX)v_my_perl;
5595     got = xs_interp;
5596     need = my_perl;
5597 #else
5598 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5599    loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5600    but the DynaLoder/Perl that started the process and loaded the XS DLL is
5601    unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5602    through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5603    location in the unthreaded perl binary) stored in CV * to figure out if this
5604    Perl_xs_handshake was called by the same pp_entersub */
5605     cv = (CV*)v_my_perl;
5606     xs_spp = (SV***)CvHSCXT(cv);
5607     got = xs_spp;
5608     need = &PL_stack_sp;
5609 #endif
5610     if(UNLIKELY(got != need)) {
5611         bad_handshake:/* recycle branch and string from above */
5612         if(got != (void *)HSf_NOCHK)
5613             noperl_die("%s: loadable library and perl binaries are mismatched"
5614                        " (got handshake key %p, needed %p)\n",
5615                 file, got, need);
5616     }
5617
5618     if(key & HSf_SETXSUBFN) {     /* this might be called from a module bootstrap */
5619         SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5620         PL_xsubfilename = file;   /* so the old name must be restored for
5621                                      additional XSUBs to register themselves */
5622         /* XSUBs can't be perl lang/perl5db.pl debugged
5623         if (PERLDB_LINE_OR_SAVESRC)
5624             (void)gv_fetchfile(file); */
5625     }
5626
5627     if(key & HSf_POPMARK) {
5628         ax = POPMARK;
5629         {   SV **mark = PL_stack_base + ax++;
5630             {   dSP;
5631                 items = (I32)(SP - MARK);
5632             }
5633         }
5634     } else {
5635         items = va_arg(args, U32);
5636         ax = va_arg(args, U32);
5637     }
5638     {
5639         U32 apiverlen;
5640         assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
5641         if((apiverlen = HS_GETAPIVERLEN(key))) {
5642             char * api_p = va_arg(args, char*);
5643             if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5644                 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5645                          sizeof("v" PERL_API_VERSION_STRING)-1))
5646                 Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
5647                                     api_p, SVfARG(PL_stack_base[ax + 0]),
5648                                     "v" PERL_API_VERSION_STRING);
5649         }
5650     }
5651     {
5652         U32 xsverlen;
5653         assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
5654         if((xsverlen = HS_GETXSVERLEN(key)))
5655             S_xs_version_bootcheck(aTHX_
5656                 items, ax, va_arg(args, char*), xsverlen);
5657     }
5658     va_end(args);
5659     return ax;
5660 }
5661
5662
5663 STATIC void
5664 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5665                           STRLEN xs_len)
5666 {
5667     SV *sv;
5668     const char *vn = NULL;
5669     SV *const module = PL_stack_base[ax];
5670
5671     PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5672
5673     if (items >= 2)      /* version supplied as bootstrap arg */
5674         sv = PL_stack_base[ax + 1];
5675     else {
5676         /* XXX GV_ADDWARN */
5677         vn = "XS_VERSION";
5678         sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
5679         if (!sv || !SvOK(sv)) {
5680             vn = "VERSION";
5681             sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
5682         }
5683     }
5684     if (sv) {
5685         SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5686         SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5687             ? sv : sv_2mortal(new_version(sv));
5688         xssv = upg_version(xssv, 0);
5689         if ( vcmp(pmsv,xssv) ) {
5690             SV *string = vstringify(xssv);
5691             SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf
5692                                     " does not match ", SVfARG(module), SVfARG(string));
5693
5694             SvREFCNT_dec(string);
5695             string = vstringify(pmsv);
5696
5697             if (vn) {
5698                 Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
5699                                SVfARG(string));
5700             } else {
5701                 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
5702             }
5703             SvREFCNT_dec(string);
5704
5705             Perl_sv_2mortal(aTHX_ xpt);
5706             Perl_croak_sv(aTHX_ xpt);
5707         }
5708     }
5709 }
5710
5711 /*
5712 =for apidoc my_strlcat
5713
5714 The C library C<strlcat> if available, or a Perl implementation of it.
5715 This operates on C C<NUL>-terminated strings.
5716
5717 C<my_strlcat()> appends string C<src> to the end of C<dst>.  It will append at
5718 most S<C<size - strlen(dst) - 1>> characters.  It will then C<NUL>-terminate,
5719 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5720 practice this should not happen as it means that either C<size> is incorrect or
5721 that C<dst> is not a proper C<NUL>-terminated string).
5722
5723 Note that C<size> is the full size of the destination buffer and
5724 the result is guaranteed to be C<NUL>-terminated if there is room.  Note that
5725 room for the C<NUL> should be included in C<size>.
5726
5727 The return value is the total length that C<dst> would have if C<size> is
5728 sufficiently large.  Thus it is the initial length of C<dst> plus the length of
5729 C<src>.  If C<size> is smaller than the return, the excess was not appended.
5730
5731 =cut
5732
5733 Description stolen from http://man.openbsd.org/strlcat.3
5734 */
5735 #ifndef HAS_STRLCAT
5736 Size_t
5737 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5738 {
5739     Size_t used, length, copy;
5740
5741     used = strlen(dst);
5742     length = strlen(src);
5743     if (size > 0 && used < size - 1) {
5744         copy = (length >= size - used) ? size - used - 1 : length;
5745         memcpy(dst + used, src, copy);
5746         dst[used + copy] = '\0';
5747     }
5748     return used + length;
5749 }
5750 #endif
5751
5752
5753 /*
5754 =for apidoc my_strlcpy
5755
5756 The C library C<strlcpy> if available, or a Perl implementation of it.
5757 This operates on C C<NUL>-terminated strings.
5758
5759 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5760 to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
5761
5762 The return value is the total length C<src> would be if the copy completely
5763 succeeded.  If it is larger than C<size>, the excess was not copied.
5764
5765 =cut
5766
5767 Description stolen from http://man.openbsd.org/strlcpy.3
5768 */
5769 #ifndef HAS_STRLCPY
5770 Size_t
5771 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5772 {
5773     Size_t length, copy;
5774
5775     length = strlen(src);
5776     if (size > 0) {
5777         copy = (length >= size) ? size - 1 : length;
5778         memcpy(dst, src, copy);
5779         dst[copy] = '\0';
5780     }
5781     return length;
5782 }
5783 #endif
5784
5785 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5786 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5787 long _ftol( double ); /* Defined by VC6 C libs. */
5788 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5789 #endif
5790
5791 PERL_STATIC_INLINE bool
5792 S_gv_has_usable_name(pTHX_ GV *gv)
5793 {
5794     GV **gvp;
5795     return GvSTASH(gv)
5796         && HvENAME(GvSTASH(gv))
5797         && (gvp = (GV **)hv_fetchhek(
5798                         GvSTASH(gv), GvNAME_HEK(gv), 0
5799            ))
5800         && *gvp == gv;
5801 }
5802
5803 void
5804 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5805 {
5806     SV * const dbsv = GvSVn(PL_DBsub);
5807     const bool save_taint = TAINT_get;
5808
5809     /* When we are called from pp_goto (svp is null),
5810      * we do not care about using dbsv to call CV;
5811      * it's for informational purposes only.
5812      */
5813
5814     PERL_ARGS_ASSERT_GET_DB_SUB;
5815
5816     TAINT_set(FALSE);
5817     save_item(dbsv);
5818     if (!PERLDB_SUB_NN) {
5819         GV *gv = CvGV(cv);
5820
5821         if (!svp && !CvLEXICAL(cv)) {
5822             gv_efullname3(dbsv, gv, NULL);
5823         }
5824         else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
5825              || strEQ(GvNAME(gv), "END")
5826              || ( /* Could be imported, and old sub redefined. */
5827                  (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5828                  &&
5829                  !( (SvTYPE(*svp) == SVt_PVGV)
5830                     && (GvCV((const GV *)*svp) == cv)
5831                     /* Use GV from the stack as a fallback. */
5832                     && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 
5833                   )
5834                 )
5835         ) {
5836             /* GV is potentially non-unique, or contain different CV. */
5837             SV * const tmp = newRV(MUTABLE_SV(cv));
5838             sv_setsv(dbsv, tmp);
5839             SvREFCNT_dec(tmp);
5840         }
5841         else {
5842             sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5843             sv_catpvs(dbsv, "::");
5844             sv_cathek(dbsv, GvNAME_HEK(gv));
5845         }
5846     }
5847     else {
5848         const int type = SvTYPE(dbsv);
5849         if (type < SVt_PVIV && type != SVt_IV)
5850             sv_upgrade(dbsv, SVt_PVIV);
5851         (void)SvIOK_on(dbsv);
5852         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
5853     }
5854     SvSETMAGIC(dbsv);
5855     TAINT_IF(save_taint);
5856 #ifdef NO_TAINT_SUPPORT
5857     PERL_UNUSED_VAR(save_taint);
5858 #endif
5859 }
5860
5861 int
5862 Perl_my_dirfd(DIR * dir) {
5863
5864     /* Most dirfd implementations have problems when passed NULL. */
5865     if(!dir)
5866         return -1;
5867 #ifdef HAS_DIRFD
5868     return dirfd(dir);
5869 #elif defined(HAS_DIR_DD_FD)
5870     return dir->dd_fd;
5871 #else
5872     Perl_croak_nocontext(PL_no_func, "dirfd");
5873     NOT_REACHED; /* NOTREACHED */
5874     return 0;
5875 #endif 
5876 }
5877
5878 #if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP)
5879
5880 #define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789"
5881 #define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1)
5882
5883 static int
5884 S_my_mkostemp(char *templte, int flags) {
5885     dTHX;
5886     STRLEN len = strlen(templte);
5887     int fd;
5888     int attempts = 0;
5889 #ifdef VMS
5890     int delete_on_close = flags & O_VMS_DELETEONCLOSE;
5891
5892     flags &= ~O_VMS_DELETEONCLOSE;
5893 #endif
5894
5895     if (len < 6 ||
5896         templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
5897         templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') {
5898         SETERRNO(EINVAL, LIB_INVARG);
5899         return -1;
5900     }
5901
5902     do {
5903         int i;
5904         for (i = 1; i <= 6; ++i) {
5905             templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
5906         }
5907 #ifdef VMS
5908         if (delete_on_close) {
5909             fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
5910         }
5911         else
5912 #endif
5913         {
5914             fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
5915         }
5916     } while (fd == -1 && errno == EEXIST && ++attempts <= 100);
5917
5918     return fd;
5919 }
5920
5921 #endif
5922
5923 #ifndef HAS_MKOSTEMP
5924 int
5925 Perl_my_mkostemp(char *templte, int flags)
5926 {
5927     PERL_ARGS_ASSERT_MY_MKOSTEMP;
5928     return S_my_mkostemp(templte, flags);
5929 }
5930 #endif
5931
5932 #ifndef HAS_MKSTEMP
5933 int
5934 Perl_my_mkstemp(char *templte)
5935 {
5936     PERL_ARGS_ASSERT_MY_MKSTEMP;
5937     return S_my_mkostemp(templte, 0);
5938 }
5939 #endif
5940
5941 REGEXP *
5942 Perl_get_re_arg(pTHX_ SV *sv) {
5943
5944     if (sv) {
5945         if (SvMAGICAL(sv))
5946             mg_get(sv);
5947         if (SvROK(sv))
5948             sv = MUTABLE_SV(SvRV(sv));
5949         if (SvTYPE(sv) == SVt_REGEXP)
5950             return (REGEXP*) sv;
5951     }
5952  
5953     return NULL;
5954 }
5955
5956 /*
5957  * This code is derived from drand48() implementation from FreeBSD,
5958  * found in lib/libc/gen/_rand48.c.
5959  *
5960  * The U64 implementation is original, based on the POSIX
5961  * specification for drand48().
5962  */
5963
5964 /*
5965 * Copyright (c) 1993 Martin Birgmeier
5966 * All rights reserved.
5967 *
5968 * You may redistribute unmodified or modified versions of this source
5969 * code provided that the above copyright notice and this and the
5970 * following conditions are retained.
5971 *
5972 * This software is provided ``as is'', and comes with no warranties
5973 * of any kind. I shall in no event be liable for anything that happens
5974 * to anyone/anything when using this software.
5975 */
5976
5977 #define FREEBSD_DRAND48_SEED_0   (0x330e)
5978
5979 #ifdef PERL_DRAND48_QUAD
5980
5981 #define DRAND48_MULT UINT64_C(0x5deece66d)
5982 #define DRAND48_ADD  0xb
5983 #define DRAND48_MASK UINT64_C(0xffffffffffff)
5984
5985 #else
5986
5987 #define FREEBSD_DRAND48_SEED_1   (0xabcd)
5988 #define FREEBSD_DRAND48_SEED_2   (0x1234)
5989 #define FREEBSD_DRAND48_MULT_0   (0xe66d)
5990 #define FREEBSD_DRAND48_MULT_1   (0xdeec)
5991 #define FREEBSD_DRAND48_MULT_2   (0x0005)
5992 #define FREEBSD_DRAND48_ADD      (0x000b)
5993
5994 const unsigned short _rand48_mult[3] = {
5995                 FREEBSD_DRAND48_MULT_0,
5996                 FREEBSD_DRAND48_MULT_1,
5997                 FREEBSD_DRAND48_MULT_2
5998 };
5999 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
6000
6001 #endif
6002
6003 void
6004 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
6005 {
6006     PERL_ARGS_ASSERT_DRAND48_INIT_R;
6007
6008 #ifdef PERL_DRAND48_QUAD
6009     *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
6010 #else
6011     random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
6012     random_state->seed[1] = (U16) seed;
6013     random_state->seed[2] = (U16) (seed >> 16);
6014 #endif
6015 }
6016
6017 double
6018 Perl_drand48_r(perl_drand48_t *random_state)
6019 {
6020     PERL_ARGS_ASSERT_DRAND48_R;
6021
6022 #ifdef PERL_DRAND48_QUAD
6023     *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
6024         & DRAND48_MASK;
6025
6026     return ldexp((double)*random_state, -48);
6027 #else
6028     {
6029     U32 accu;
6030     U16 temp[2];
6031
6032     accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
6033          + (U32) _rand48_add;
6034     temp[0] = (U16) accu;        /* lower 16 bits */
6035     accu >>= sizeof(U16) * 8;
6036     accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
6037           + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
6038     temp[1] = (U16) accu;        /* middle 16 bits */
6039     accu >>= sizeof(U16) * 8;
6040     accu += _rand48_mult[0] * random_state->seed[2]
6041           + _rand48_mult[1] * random_state->seed[1]
6042           + _rand48_mult[2] * random_state->seed[0];
6043     random_state->seed[0] = temp[0];
6044     random_state->seed[1] = temp[1];
6045     random_state->seed[2] = (U16) accu;
6046
6047     return ldexp((double) random_state->seed[0], -48) +
6048            ldexp((double) random_state->seed[1], -32) +
6049            ldexp((double) random_state->seed[2], -16);
6050     }
6051 #endif
6052 }
6053
6054 #ifdef USE_C_BACKTRACE
6055
6056 /* Possibly move all this USE_C_BACKTRACE code into a new file. */
6057
6058 #ifdef USE_BFD
6059
6060 typedef struct {
6061     /* abfd is the BFD handle. */
6062     bfd* abfd;
6063     /* bfd_syms is the BFD symbol table. */
6064     asymbol** bfd_syms;
6065     /* bfd_text is handle to the the ".text" section of the object file. */
6066     asection* bfd_text;
6067     /* Since opening the executable and scanning its symbols is quite
6068      * heavy operation, we remember the filename we used the last time,
6069      * and do the opening and scanning only if the filename changes.
6070      * This removes most (but not all) open+scan cycles. */
6071     const char* fname_prev;
6072 } bfd_context;
6073
6074 /* Given a dl_info, update the BFD context if necessary. */
6075 static void bfd_update(bfd_context* ctx, Dl_info* dl_info)
6076 {
6077     /* BFD open and scan only if the filename changed. */
6078     if (ctx->fname_prev == NULL ||
6079         strNE(dl_info->dli_fname, ctx->fname_prev)) {
6080         if (ctx->abfd) {
6081             bfd_close(ctx->abfd);
6082         }
6083         ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
6084         if (ctx->abfd) {
6085             if (bfd_check_format(ctx->abfd, bfd_object)) {
6086                 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd);
6087                 if (symbol_size > 0) {
6088                     Safefree(ctx->bfd_syms);
6089                     Newx(ctx->bfd_syms, symbol_size, asymbol*);
6090                     ctx->bfd_text =
6091                         bfd_get_section_by_name(ctx->abfd, ".text");
6092                 }
6093                 else
6094                     ctx->abfd = NULL;
6095             }
6096             else
6097                 ctx->abfd = NULL;
6098         }
6099         ctx->fname_prev = dl_info->dli_fname;
6100     }
6101 }
6102
6103 /* Given a raw frame, try to symbolize it and store
6104  * symbol information (source file, line number) away. */
6105 static void bfd_symbolize(bfd_context* ctx,
6106                           void* raw_frame,
6107                           char** symbol_name,
6108                           STRLEN* symbol_name_size,
6109                           char** source_name,