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