This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Various updates and fixes to some of the SysV IPC ops and their tests
[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 #ifdef USE_ITHREADS
3091 #endif
3092     struct sigaction act;
3093
3094     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3095
3096 #ifdef USE_ITHREADS
3097     /* only "parent" interpreter can diddle signals */
3098     if (PL_curinterp != aTHX)
3099         return -1;
3100 #endif
3101
3102     act.sa_handler = handler;
3103     sigemptyset(&act.sa_mask);
3104     act.sa_flags = 0;
3105 #ifdef SA_RESTART
3106     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3107         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
3108 #endif
3109 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3110     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3111         act.sa_flags |= SA_NOCLDWAIT;
3112 #endif
3113     return sigaction(signo, &act, save);
3114 }
3115
3116 int
3117 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3118 {
3119 #ifdef USE_ITHREADS
3120 #endif
3121     PERL_UNUSED_CONTEXT;
3122 #ifdef USE_ITHREADS
3123     /* only "parent" interpreter can diddle signals */
3124     if (PL_curinterp != aTHX)
3125         return -1;
3126 #endif
3127
3128     return sigaction(signo, save, (struct sigaction *)NULL);
3129 }
3130
3131 #else /* !HAS_SIGACTION */
3132
3133 Sighandler_t
3134 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3135 {
3136 #if defined(USE_ITHREADS) && !defined(WIN32)
3137     /* only "parent" interpreter can diddle signals */
3138     if (PL_curinterp != aTHX)
3139         return (Sighandler_t) SIG_ERR;
3140 #endif
3141
3142     return PerlProc_signal(signo, handler);
3143 }
3144
3145 static Signal_t
3146 sig_trap(int signo)
3147 {
3148     PL_sig_trapped++;
3149 }
3150
3151 Sighandler_t
3152 Perl_rsignal_state(pTHX_ int signo)
3153 {
3154     Sighandler_t oldsig;
3155
3156 #if defined(USE_ITHREADS) && !defined(WIN32)
3157     /* only "parent" interpreter can diddle signals */
3158     if (PL_curinterp != aTHX)
3159         return (Sighandler_t) SIG_ERR;
3160 #endif
3161
3162     PL_sig_trapped = 0;
3163     oldsig = PerlProc_signal(signo, sig_trap);
3164     PerlProc_signal(signo, oldsig);
3165     if (PL_sig_trapped)
3166         PerlProc_kill(PerlProc_getpid(), signo);
3167     return oldsig;
3168 }
3169
3170 int
3171 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3172 {
3173 #if defined(USE_ITHREADS) && !defined(WIN32)
3174     /* only "parent" interpreter can diddle signals */
3175     if (PL_curinterp != aTHX)
3176         return -1;
3177 #endif
3178     *save = PerlProc_signal(signo, handler);
3179     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3180 }
3181
3182 int
3183 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3184 {
3185 #if defined(USE_ITHREADS) && !defined(WIN32)
3186     /* only "parent" interpreter can diddle signals */
3187     if (PL_curinterp != aTHX)
3188         return -1;
3189 #endif
3190     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3191 }
3192
3193 #endif /* !HAS_SIGACTION */
3194 #endif /* !PERL_MICRO */
3195
3196     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3197 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3198 I32
3199 Perl_my_pclose(pTHX_ PerlIO *ptr)
3200 {
3201     int status;
3202     SV **svp;
3203     Pid_t pid;
3204     Pid_t pid2 = 0;
3205     bool close_failed;
3206     dSAVEDERRNO;
3207     const int fd = PerlIO_fileno(ptr);
3208     bool should_wait;
3209
3210     svp = av_fetch(PL_fdpid,fd,TRUE);
3211     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3212     SvREFCNT_dec(*svp);
3213     *svp = NULL;
3214
3215 #if defined(USE_PERLIO)
3216     /* Find out whether the refcount is low enough for us to wait for the
3217        child proc without blocking. */
3218     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3219 #else
3220     should_wait = pid > 0;
3221 #endif
3222
3223 #ifdef OS2
3224     if (pid == -1) {                    /* Opened by popen. */
3225         return my_syspclose(ptr);
3226     }
3227 #endif
3228     close_failed = (PerlIO_close(ptr) == EOF);
3229     SAVE_ERRNO;
3230     if (should_wait) do {
3231         pid2 = wait4pid(pid, &status, 0);
3232     } while (pid2 == -1 && errno == EINTR);
3233     if (close_failed) {
3234         RESTORE_ERRNO;
3235         return -1;
3236     }
3237     return(
3238       should_wait
3239        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3240        : 0
3241     );
3242 }
3243 #elif defined(__LIBCATAMOUNT__)
3244 I32
3245 Perl_my_pclose(pTHX_ PerlIO *ptr)
3246 {
3247     return -1;
3248 }
3249 #endif /* !DOSISH */
3250
3251 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3252 I32
3253 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3254 {
3255     I32 result = 0;
3256     PERL_ARGS_ASSERT_WAIT4PID;
3257 #ifdef PERL_USES_PL_PIDSTATUS
3258     if (!pid) {
3259         /* PERL_USES_PL_PIDSTATUS is only defined when neither
3260            waitpid() nor wait4() is available, or on OS/2, which
3261            doesn't appear to support waiting for a progress group
3262            member, so we can only treat a 0 pid as an unknown child.
3263         */
3264         errno = ECHILD;
3265         return -1;
3266     }
3267     {
3268         if (pid > 0) {
3269             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3270                pid, rather than a string form.  */
3271             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3272             if (svp && *svp != &PL_sv_undef) {
3273                 *statusp = SvIVX(*svp);
3274                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3275                                 G_DISCARD);
3276                 return pid;
3277             }
3278         }
3279         else {
3280             HE *entry;
3281
3282             hv_iterinit(PL_pidstatus);
3283             if ((entry = hv_iternext(PL_pidstatus))) {
3284                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3285                 I32 len;
3286                 const char * const spid = hv_iterkey(entry,&len);
3287
3288                 assert (len == sizeof(Pid_t));
3289                 memcpy((char *)&pid, spid, len);
3290                 *statusp = SvIVX(sv);
3291                 /* The hash iterator is currently on this entry, so simply
3292                    calling hv_delete would trigger the lazy delete, which on
3293                    aggregate does more work, because next call to hv_iterinit()
3294                    would spot the flag, and have to call the delete routine,
3295                    while in the meantime any new entries can't re-use that
3296                    memory.  */
3297                 hv_iterinit(PL_pidstatus);
3298                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3299                 return pid;
3300             }
3301         }
3302     }
3303 #endif
3304 #ifdef HAS_WAITPID
3305 #  ifdef HAS_WAITPID_RUNTIME
3306     if (!HAS_WAITPID_RUNTIME)
3307         goto hard_way;
3308 #  endif
3309     result = PerlProc_waitpid(pid,statusp,flags);
3310     goto finish;
3311 #endif
3312 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3313     result = wait4(pid,statusp,flags,NULL);
3314     goto finish;
3315 #endif
3316 #ifdef PERL_USES_PL_PIDSTATUS
3317 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3318   hard_way:
3319 #endif
3320     {
3321         if (flags)
3322             Perl_croak(aTHX_ "Can't do waitpid with flags");
3323         else {
3324             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3325                 pidgone(result,*statusp);
3326             if (result < 0)
3327                 *statusp = -1;
3328         }
3329     }
3330 #endif
3331 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3332   finish:
3333 #endif
3334     if (result < 0 && errno == EINTR) {
3335         PERL_ASYNC_CHECK();
3336         errno = EINTR; /* reset in case a signal handler changed $! */
3337     }
3338     return result;
3339 }
3340 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3341
3342 #ifdef PERL_USES_PL_PIDSTATUS
3343 void
3344 S_pidgone(pTHX_ Pid_t pid, int status)
3345 {
3346     SV *sv;
3347
3348     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3349     SvUPGRADE(sv,SVt_IV);
3350     SvIV_set(sv, status);
3351     return;
3352 }
3353 #endif
3354
3355 #if defined(OS2)
3356 int pclose();
3357 #ifdef HAS_FORK
3358 int                                     /* Cannot prototype with I32
3359                                            in os2ish.h. */
3360 my_syspclose(PerlIO *ptr)
3361 #else
3362 I32
3363 Perl_my_pclose(pTHX_ PerlIO *ptr)
3364 #endif
3365 {
3366     /* Needs work for PerlIO ! */
3367     FILE * const f = PerlIO_findFILE(ptr);
3368     const I32 result = pclose(f);
3369     PerlIO_releaseFILE(ptr,f);
3370     return result;
3371 }
3372 #endif
3373
3374 #if defined(DJGPP)
3375 int djgpp_pclose();
3376 I32
3377 Perl_my_pclose(pTHX_ PerlIO *ptr)
3378 {
3379     /* Needs work for PerlIO ! */
3380     FILE * const f = PerlIO_findFILE(ptr);
3381     I32 result = djgpp_pclose(f);
3382     result = (result << 8) & 0xff00;
3383     PerlIO_releaseFILE(ptr,f);
3384     return result;
3385 }
3386 #endif
3387
3388 #define PERL_REPEATCPY_LINEAR 4
3389 void
3390 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3391 {
3392     PERL_ARGS_ASSERT_REPEATCPY;
3393
3394     assert(len >= 0);
3395
3396     if (count < 0)
3397         croak_memory_wrap();
3398
3399     if (len == 1)
3400         memset(to, *from, count);
3401     else if (count) {
3402         char *p = to;
3403         IV items, linear, half;
3404
3405         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3406         for (items = 0; items < linear; ++items) {
3407             const char *q = from;
3408             IV todo;
3409             for (todo = len; todo > 0; todo--)
3410                 *p++ = *q++;
3411         }
3412
3413         half = count / 2;
3414         while (items <= half) {
3415             IV size = items * len;
3416             memcpy(p, to, size);
3417             p     += size;
3418             items *= 2;
3419         }
3420
3421         if (count > items)
3422             memcpy(p, to, (count - items) * len);
3423     }
3424 }
3425
3426 #ifndef HAS_RENAME
3427 I32
3428 Perl_same_dirent(pTHX_ const char *a, const char *b)
3429 {
3430     char *fa = strrchr(a,'/');
3431     char *fb = strrchr(b,'/');
3432     Stat_t tmpstatbuf1;
3433     Stat_t tmpstatbuf2;
3434     SV * const tmpsv = sv_newmortal();
3435
3436     PERL_ARGS_ASSERT_SAME_DIRENT;
3437
3438     if (fa)
3439         fa++;
3440     else
3441         fa = a;
3442     if (fb)
3443         fb++;
3444     else
3445         fb = b;
3446     if (strNE(a,b))
3447         return FALSE;
3448     if (fa == a)
3449         sv_setpvs(tmpsv, ".");
3450     else
3451         sv_setpvn(tmpsv, a, fa - a);
3452     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3453         return FALSE;
3454     if (fb == b)
3455         sv_setpvs(tmpsv, ".");
3456     else
3457         sv_setpvn(tmpsv, b, fb - b);
3458     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3459         return FALSE;
3460     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3461            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3462 }
3463 #endif /* !HAS_RENAME */
3464
3465 char*
3466 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3467                  const char *const *const search_ext, I32 flags)
3468 {
3469     const char *xfound = NULL;
3470     char *xfailed = NULL;
3471     char tmpbuf[MAXPATHLEN];
3472     char *s;
3473     I32 len = 0;
3474     int retval;
3475     char *bufend;
3476 #if defined(DOSISH) && !defined(OS2)
3477 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3478 #  define MAX_EXT_LEN 4
3479 #endif
3480 #ifdef OS2
3481 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3482 #  define MAX_EXT_LEN 4
3483 #endif
3484 #ifdef VMS
3485 #  define SEARCH_EXTS ".pl", ".com", NULL
3486 #  define MAX_EXT_LEN 4
3487 #endif
3488     /* additional extensions to try in each dir if scriptname not found */
3489 #ifdef SEARCH_EXTS
3490     static const char *const exts[] = { SEARCH_EXTS };
3491     const char *const *const ext = search_ext ? search_ext : exts;
3492     int extidx = 0, i = 0;
3493     const char *curext = NULL;
3494 #else
3495     PERL_UNUSED_ARG(search_ext);
3496 #  define MAX_EXT_LEN 0
3497 #endif
3498
3499     PERL_ARGS_ASSERT_FIND_SCRIPT;
3500
3501     /*
3502      * If dosearch is true and if scriptname does not contain path
3503      * delimiters, search the PATH for scriptname.
3504      *
3505      * If SEARCH_EXTS is also defined, will look for each
3506      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3507      * while searching the PATH.
3508      *
3509      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3510      * proceeds as follows:
3511      *   If DOSISH or VMSISH:
3512      *     + look for ./scriptname{,.foo,.bar}
3513      *     + search the PATH for scriptname{,.foo,.bar}
3514      *
3515      *   If !DOSISH:
3516      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3517      *       this will not look in '.' if it's not in the PATH)
3518      */
3519     tmpbuf[0] = '\0';
3520
3521 #ifdef VMS
3522 #  ifdef ALWAYS_DEFTYPES
3523     len = strlen(scriptname);
3524     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3525         int idx = 0, deftypes = 1;
3526         bool seen_dot = 1;
3527
3528         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3529 #  else
3530     if (dosearch) {
3531         int idx = 0, deftypes = 1;
3532         bool seen_dot = 1;
3533
3534         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3535 #  endif
3536         /* The first time through, just add SEARCH_EXTS to whatever we
3537          * already have, so we can check for default file types. */
3538         while (deftypes ||
3539                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3540         {
3541             Stat_t statbuf;
3542             if (deftypes) {
3543                 deftypes = 0;
3544                 *tmpbuf = '\0';
3545             }
3546             if ((strlen(tmpbuf) + strlen(scriptname)
3547                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3548                 continue;       /* don't search dir with too-long name */
3549             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3550 #else  /* !VMS */
3551
3552 #ifdef DOSISH
3553     if (strEQ(scriptname, "-"))
3554         dosearch = 0;
3555     if (dosearch) {             /* Look in '.' first. */
3556         const char *cur = scriptname;
3557 #ifdef SEARCH_EXTS
3558         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3559             while (ext[i])
3560                 if (strEQ(ext[i++],curext)) {
3561                     extidx = -1;                /* already has an ext */
3562                     break;
3563                 }
3564         do {
3565 #endif
3566             DEBUG_p(PerlIO_printf(Perl_debug_log,
3567                                   "Looking for %s\n",cur));
3568             {
3569                 Stat_t statbuf;
3570                 if (PerlLIO_stat(cur,&statbuf) >= 0
3571                     && !S_ISDIR(statbuf.st_mode)) {
3572                     dosearch = 0;
3573                     scriptname = cur;
3574 #ifdef SEARCH_EXTS
3575                     break;
3576 #endif
3577                 }
3578             }
3579 #ifdef SEARCH_EXTS
3580             if (cur == scriptname) {
3581                 len = strlen(scriptname);
3582                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3583                     break;
3584                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3585                 cur = tmpbuf;
3586             }
3587         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3588                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3589 #endif
3590     }
3591 #endif
3592
3593     if (dosearch && !strchr(scriptname, '/')
3594 #ifdef DOSISH
3595                  && !strchr(scriptname, '\\')
3596 #endif
3597                  && (s = PerlEnv_getenv("PATH")))
3598     {
3599         bool seen_dot = 0;
3600
3601         bufend = s + strlen(s);
3602         while (s < bufend) {
3603             Stat_t statbuf;
3604 #  ifdef DOSISH
3605             for (len = 0; *s
3606                     && *s != ';'; len++, s++) {
3607                 if (len < sizeof tmpbuf)
3608                     tmpbuf[len] = *s;
3609             }
3610             if (len < sizeof tmpbuf)
3611                 tmpbuf[len] = '\0';
3612 #  else
3613             s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3614                                    ':', &len);
3615 #  endif
3616             if (s < bufend)
3617                 s++;
3618             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3619                 continue;       /* don't search dir with too-long name */
3620             if (len
3621 #  ifdef DOSISH
3622                 && tmpbuf[len - 1] != '/'
3623                 && tmpbuf[len - 1] != '\\'
3624 #  endif
3625                )
3626                 tmpbuf[len++] = '/';
3627             if (len == 2 && tmpbuf[0] == '.')
3628                 seen_dot = 1;
3629             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3630 #endif  /* !VMS */
3631
3632 #ifdef SEARCH_EXTS
3633             len = strlen(tmpbuf);
3634             if (extidx > 0)     /* reset after previous loop */
3635                 extidx = 0;
3636             do {
3637 #endif
3638                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3639                 retval = PerlLIO_stat(tmpbuf,&statbuf);
3640                 if (S_ISDIR(statbuf.st_mode)) {
3641                     retval = -1;
3642                 }
3643 #ifdef SEARCH_EXTS
3644             } while (  retval < 0               /* not there */
3645                     && extidx>=0 && ext[extidx] /* try an extension? */
3646                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3647                 );
3648 #endif
3649             if (retval < 0)
3650                 continue;
3651             if (S_ISREG(statbuf.st_mode)
3652                 && cando(S_IRUSR,TRUE,&statbuf)
3653 #if !defined(DOSISH)
3654                 && cando(S_IXUSR,TRUE,&statbuf)
3655 #endif
3656                 )
3657             {
3658                 xfound = tmpbuf;                /* bingo! */
3659                 break;
3660             }
3661             if (!xfailed)
3662                 xfailed = savepv(tmpbuf);
3663         }
3664 #ifndef DOSISH
3665         {
3666             Stat_t statbuf;
3667             if (!xfound && !seen_dot && !xfailed &&
3668                 (PerlLIO_stat(scriptname,&statbuf) < 0
3669                  || S_ISDIR(statbuf.st_mode)))
3670 #endif
3671                 seen_dot = 1;                   /* Disable message. */
3672 #ifndef DOSISH
3673         }
3674 #endif
3675         if (!xfound) {
3676             if (flags & 1) {                    /* do or die? */
3677                 /* diag_listed_as: Can't execute %s */
3678                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3679                       (xfailed ? "execute" : "find"),
3680                       (xfailed ? xfailed : scriptname),
3681                       (xfailed ? "" : " on PATH"),
3682                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3683             }
3684             scriptname = NULL;
3685         }
3686         Safefree(xfailed);
3687         scriptname = xfound;
3688     }
3689     return (scriptname ? savepv(scriptname) : NULL);
3690 }
3691
3692 #ifndef PERL_GET_CONTEXT_DEFINED
3693
3694 void *
3695 Perl_get_context(void)
3696 {
3697 #if defined(USE_ITHREADS)
3698 #  ifdef OLD_PTHREADS_API
3699     pthread_addr_t t;
3700     int error = pthread_getspecific(PL_thr_key, &t);
3701     if (error)
3702         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3703     return (void*)t;
3704 #  elif defined(I_MACH_CTHREADS)
3705     return (void*)cthread_data(cthread_self());
3706 #  else
3707     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3708 #  endif
3709 #else
3710     return (void*)NULL;
3711 #endif
3712 }
3713
3714 void
3715 Perl_set_context(void *t)
3716 {
3717 #if defined(USE_ITHREADS)
3718 #endif
3719     PERL_ARGS_ASSERT_SET_CONTEXT;
3720 #if defined(USE_ITHREADS)
3721 #  ifdef I_MACH_CTHREADS
3722     cthread_set_data(cthread_self(), t);
3723 #  else
3724     {
3725         const int error = pthread_setspecific(PL_thr_key, t);
3726         if (error)
3727             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3728     }
3729 #  endif
3730 #else
3731     PERL_UNUSED_ARG(t);
3732 #endif
3733 }
3734
3735 #endif /* !PERL_GET_CONTEXT_DEFINED */
3736
3737 char **
3738 Perl_get_op_names(pTHX)
3739 {
3740     PERL_UNUSED_CONTEXT;
3741     return (char **)PL_op_name;
3742 }
3743
3744 char **
3745 Perl_get_op_descs(pTHX)
3746 {
3747     PERL_UNUSED_CONTEXT;
3748     return (char **)PL_op_desc;
3749 }
3750
3751 const char *
3752 Perl_get_no_modify(pTHX)
3753 {
3754     PERL_UNUSED_CONTEXT;
3755     return PL_no_modify;
3756 }
3757
3758 U32 *
3759 Perl_get_opargs(pTHX)
3760 {
3761     PERL_UNUSED_CONTEXT;
3762     return (U32 *)PL_opargs;
3763 }
3764
3765 PPADDR_t*
3766 Perl_get_ppaddr(pTHX)
3767 {
3768     PERL_UNUSED_CONTEXT;
3769     return (PPADDR_t*)PL_ppaddr;
3770 }
3771
3772 #ifndef HAS_GETENV_LEN
3773 char *
3774 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3775 {
3776     char * const env_trans = PerlEnv_getenv(env_elem);
3777     PERL_UNUSED_CONTEXT;
3778     PERL_ARGS_ASSERT_GETENV_LEN;
3779     if (env_trans)
3780         *len = strlen(env_trans);
3781     return env_trans;
3782 }
3783 #endif
3784
3785
3786 MGVTBL*
3787 Perl_get_vtbl(pTHX_ int vtbl_id)
3788 {
3789     PERL_UNUSED_CONTEXT;
3790
3791     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3792         ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3793 }
3794
3795 I32
3796 Perl_my_fflush_all(pTHX)
3797 {
3798 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3799     return PerlIO_flush(NULL);
3800 #else
3801 # if defined(HAS__FWALK)
3802     extern int fflush(FILE *);
3803     /* undocumented, unprototyped, but very useful BSDism */
3804     extern void _fwalk(int (*)(FILE *));
3805     _fwalk(&fflush);
3806     return 0;
3807 # else
3808 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3809     long open_max = -1;
3810 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3811     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3812 #   elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3813     open_max = sysconf(_SC_OPEN_MAX);
3814 #   elif defined(FOPEN_MAX)
3815     open_max = FOPEN_MAX;
3816 #   elif defined(OPEN_MAX)
3817     open_max = OPEN_MAX;
3818 #   elif defined(_NFILE)
3819     open_max = _NFILE;
3820 #   endif
3821     if (open_max > 0) {
3822       long i;
3823       for (i = 0; i < open_max; i++)
3824             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3825                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3826                 STDIO_STREAM_ARRAY[i]._flag)
3827                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3828       return 0;
3829     }
3830 #  endif
3831     SETERRNO(EBADF,RMS_IFI);
3832     return EOF;
3833 # endif
3834 #endif
3835 }
3836
3837 void
3838 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3839 {
3840     if (ckWARN(WARN_IO)) {
3841         HEK * const name
3842            = gv && (isGV_with_GP(gv))
3843                 ? GvENAME_HEK((gv))
3844                 : NULL;
3845         const char * const direction = have == '>' ? "out" : "in";
3846
3847         if (name && HEK_LEN(name))
3848             Perl_warner(aTHX_ packWARN(WARN_IO),
3849                         "Filehandle %" HEKf " opened only for %sput",
3850                         HEKfARG(name), direction);
3851         else
3852             Perl_warner(aTHX_ packWARN(WARN_IO),
3853                         "Filehandle opened only for %sput", direction);
3854     }
3855 }
3856
3857 void
3858 Perl_report_evil_fh(pTHX_ const GV *gv)
3859 {
3860     const IO *io = gv ? GvIO(gv) : NULL;
3861     const PERL_BITFIELD16 op = PL_op->op_type;
3862     const char *vile;
3863     I32 warn_type;
3864
3865     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3866         vile = "closed";
3867         warn_type = WARN_CLOSED;
3868     }
3869     else {
3870         vile = "unopened";
3871         warn_type = WARN_UNOPENED;
3872     }
3873
3874     if (ckWARN(warn_type)) {
3875         SV * const name
3876             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3877                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3878         const char * const pars =
3879             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3880         const char * const func =
3881             (const char *)
3882             (op == OP_READLINE || op == OP_RCATLINE
3883                                  ? "readline"  :        /* "<HANDLE>" not nice */
3884              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3885              PL_op_desc[op]);
3886         const char * const type =
3887             (const char *)
3888             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3889              ? "socket" : "filehandle");
3890         const bool have_name = name && SvCUR(name);
3891         Perl_warner(aTHX_ packWARN(warn_type),
3892                    "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3893                     have_name ? " " : "",
3894                     SVfARG(have_name ? name : &PL_sv_no));
3895         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3896                 Perl_warner(
3897                             aTHX_ packWARN(warn_type),
3898                         "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3899                         func, pars, have_name ? " " : "",
3900                         SVfARG(have_name ? name : &PL_sv_no)
3901                             );
3902     }
3903 }
3904
3905 /* To workaround core dumps from the uninitialised tm_zone we get the
3906  * system to give us a reasonable struct to copy.  This fix means that
3907  * strftime uses the tm_zone and tm_gmtoff values returned by
3908  * localtime(time()). That should give the desired result most of the
3909  * time. But probably not always!
3910  *
3911  * This does not address tzname aspects of NETaa14816.
3912  *
3913  */
3914
3915 #ifdef __GLIBC__
3916 # ifndef STRUCT_TM_HASZONE
3917 #    define STRUCT_TM_HASZONE
3918 # endif
3919 #endif
3920
3921 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3922 # ifndef HAS_TM_TM_ZONE
3923 #    define HAS_TM_TM_ZONE
3924 # endif
3925 #endif
3926
3927 void
3928 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3929 {
3930 #ifdef HAS_TM_TM_ZONE
3931     Time_t now;
3932     const struct tm* my_tm;
3933     PERL_UNUSED_CONTEXT;
3934     PERL_ARGS_ASSERT_INIT_TM;
3935     (void)time(&now);
3936     ENV_LOCALE_READ_LOCK;
3937     my_tm = localtime(&now);
3938     if (my_tm)
3939         Copy(my_tm, ptm, 1, struct tm);
3940     ENV_LOCALE_READ_UNLOCK;
3941 #else
3942     PERL_UNUSED_CONTEXT;
3943     PERL_ARGS_ASSERT_INIT_TM;
3944     PERL_UNUSED_ARG(ptm);
3945 #endif
3946 }
3947
3948 /*
3949 =for apidoc_section $time
3950 =for apidoc mini_mktime
3951 normalise S<C<struct tm>> values without the localtime() semantics (and
3952 overhead) of mktime().
3953
3954 =cut
3955  */
3956 void
3957 Perl_mini_mktime(struct tm *ptm)
3958 {
3959     int yearday;
3960     int secs;
3961     int month, mday, year, jday;
3962     int odd_cent, odd_year;
3963
3964     PERL_ARGS_ASSERT_MINI_MKTIME;
3965
3966 #define DAYS_PER_YEAR   365
3967 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3968 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3969 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3970 #define SECS_PER_HOUR   (60*60)
3971 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3972 /* parentheses deliberately absent on these two, otherwise they don't work */
3973 #define MONTH_TO_DAYS   153/5
3974 #define DAYS_TO_MONTH   5/153
3975 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3976 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3977 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3978 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3979
3980 /*
3981  * Year/day algorithm notes:
3982  *
3983  * With a suitable offset for numeric value of the month, one can find
3984  * an offset into the year by considering months to have 30.6 (153/5) days,
3985  * using integer arithmetic (i.e., with truncation).  To avoid too much
3986  * messing about with leap days, we consider January and February to be
3987  * the 13th and 14th month of the previous year.  After that transformation,
3988  * we need the month index we use to be high by 1 from 'normal human' usage,
3989  * so the month index values we use run from 4 through 15.
3990  *
3991  * Given that, and the rules for the Gregorian calendar (leap years are those
3992  * divisible by 4 unless also divisible by 100, when they must be divisible
3993  * by 400 instead), we can simply calculate the number of days since some
3994  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3995  * the days we derive from our month index, and adding in the day of the
3996  * month.  The value used here is not adjusted for the actual origin which
3997  * it normally would use (1 January A.D. 1), since we're not exposing it.
3998  * We're only building the value so we can turn around and get the
3999  * normalised values for the year, month, day-of-month, and day-of-year.
4000  *
4001  * For going backward, we need to bias the value we're using so that we find
4002  * the right year value.  (Basically, we don't want the contribution of
4003  * March 1st to the number to apply while deriving the year).  Having done
4004  * that, we 'count up' the contribution to the year number by accounting for
4005  * full quadracenturies (400-year periods) with their extra leap days, plus
4006  * the contribution from full centuries (to avoid counting in the lost leap
4007  * days), plus the contribution from full quad-years (to count in the normal
4008  * leap days), plus the leftover contribution from any non-leap years.
4009  * At this point, if we were working with an actual leap day, we'll have 0
4010  * days left over.  This is also true for March 1st, however.  So, we have
4011  * to special-case that result, and (earlier) keep track of the 'odd'
4012  * century and year contributions.  If we got 4 extra centuries in a qcent,
4013  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4014  * Otherwise, we add back in the earlier bias we removed (the 123 from
4015  * figuring in March 1st), find the month index (integer division by 30.6),
4016  * and the remainder is the day-of-month.  We then have to convert back to
4017  * 'real' months (including fixing January and February from being 14/15 in
4018  * the previous year to being in the proper year).  After that, to get
4019  * tm_yday, we work with the normalised year and get a new yearday value for
4020  * January 1st, which we subtract from the yearday value we had earlier,
4021  * representing the date we've re-built.  This is done from January 1
4022  * because tm_yday is 0-origin.
4023  *
4024  * Since POSIX time routines are only guaranteed to work for times since the
4025  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4026  * applies Gregorian calendar rules even to dates before the 16th century
4027  * doesn't bother me.  Besides, you'd need cultural context for a given
4028  * date to know whether it was Julian or Gregorian calendar, and that's
4029  * outside the scope for this routine.  Since we convert back based on the
4030  * same rules we used to build the yearday, you'll only get strange results
4031  * for input which needed normalising, or for the 'odd' century years which
4032  * were leap years in the Julian calendar but not in the Gregorian one.
4033  * I can live with that.
4034  *
4035  * This algorithm also fails to handle years before A.D. 1 gracefully, but
4036  * that's still outside the scope for POSIX time manipulation, so I don't
4037  * care.
4038  *
4039  * - lwall
4040  */
4041
4042     year = 1900 + ptm->tm_year;
4043     month = ptm->tm_mon;
4044     mday = ptm->tm_mday;
4045     jday = 0;
4046     if (month >= 2)
4047         month+=2;
4048     else
4049         month+=14, year--;
4050     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4051     yearday += month*MONTH_TO_DAYS + mday + jday;
4052     /*
4053      * Note that we don't know when leap-seconds were or will be,
4054      * so we have to trust the user if we get something which looks
4055      * like a sensible leap-second.  Wild values for seconds will
4056      * be rationalised, however.
4057      */
4058     if ((unsigned) ptm->tm_sec <= 60) {
4059         secs = 0;
4060     }
4061     else {
4062         secs = ptm->tm_sec;
4063         ptm->tm_sec = 0;
4064     }
4065     secs += 60 * ptm->tm_min;
4066     secs += SECS_PER_HOUR * ptm->tm_hour;
4067     if (secs < 0) {
4068         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4069             /* got negative remainder, but need positive time */
4070             /* back off an extra day to compensate */
4071             yearday += (secs/SECS_PER_DAY)-1;
4072             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4073         }
4074         else {
4075             yearday += (secs/SECS_PER_DAY);
4076             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4077         }
4078     }
4079     else if (secs >= SECS_PER_DAY) {
4080         yearday += (secs/SECS_PER_DAY);
4081         secs %= SECS_PER_DAY;
4082     }
4083     ptm->tm_hour = secs/SECS_PER_HOUR;
4084     secs %= SECS_PER_HOUR;
4085     ptm->tm_min = secs/60;
4086     secs %= 60;
4087     ptm->tm_sec += secs;
4088     /* done with time of day effects */
4089     /*
4090      * The algorithm for yearday has (so far) left it high by 428.
4091      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4092      * bias it by 123 while trying to figure out what year it
4093      * really represents.  Even with this tweak, the reverse
4094      * translation fails for years before A.D. 0001.
4095      * It would still fail for Feb 29, but we catch that one below.
4096      */
4097     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
4098     yearday -= YEAR_ADJUST;
4099     year = (yearday / DAYS_PER_QCENT) * 400;
4100     yearday %= DAYS_PER_QCENT;
4101     odd_cent = yearday / DAYS_PER_CENT;
4102     year += odd_cent * 100;
4103     yearday %= DAYS_PER_CENT;
4104     year += (yearday / DAYS_PER_QYEAR) * 4;
4105     yearday %= DAYS_PER_QYEAR;
4106     odd_year = yearday / DAYS_PER_YEAR;
4107     year += odd_year;
4108     yearday %= DAYS_PER_YEAR;
4109     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4110         month = 1;
4111         yearday = 29;
4112     }
4113     else {
4114         yearday += YEAR_ADJUST; /* recover March 1st crock */
4115         month = yearday*DAYS_TO_MONTH;
4116         yearday -= month*MONTH_TO_DAYS;
4117         /* recover other leap-year adjustment */
4118         if (month > 13) {
4119             month-=14;
4120             year++;
4121         }
4122         else {
4123             month-=2;
4124         }
4125     }
4126     ptm->tm_year = year - 1900;
4127     if (yearday) {
4128       ptm->tm_mday = yearday;
4129       ptm->tm_mon = month;
4130     }
4131     else {
4132       ptm->tm_mday = 31;
4133       ptm->tm_mon = month - 1;
4134     }
4135     /* re-build yearday based on Jan 1 to get tm_yday */
4136     year--;
4137     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4138     yearday += 14*MONTH_TO_DAYS + 1;
4139     ptm->tm_yday = jday - yearday;
4140     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4141 }
4142
4143 char *
4144 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)
4145 {
4146 #ifdef HAS_STRFTIME
4147
4148 /*
4149 =for apidoc_section $time
4150 =for apidoc my_strftime
4151 strftime(), but with a different API so that the return value is a pointer
4152 to the formatted result (which MUST be arranged to be FREED BY THE
4153 CALLER).  This allows this function to increase the buffer size as needed,
4154 so that the caller doesn't have to worry about that.
4155
4156 Note that yday and wday effectively are ignored by this function, as
4157 mini_mktime() overwrites them
4158
4159 =cut
4160  */
4161
4162   char *buf;
4163   int buflen;
4164   struct tm mytm;
4165   int len;
4166
4167   PERL_ARGS_ASSERT_MY_STRFTIME;
4168
4169   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4170   mytm.tm_sec = sec;
4171   mytm.tm_min = min;
4172   mytm.tm_hour = hour;
4173   mytm.tm_mday = mday;
4174   mytm.tm_mon = mon;
4175   mytm.tm_year = year;
4176   mytm.tm_wday = wday;
4177   mytm.tm_yday = yday;
4178   mytm.tm_isdst = isdst;
4179   mini_mktime(&mytm);
4180   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4181 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4182   STMT_START {
4183     struct tm mytm2;
4184     mytm2 = mytm;
4185     mktime(&mytm2);
4186 #ifdef HAS_TM_TM_GMTOFF
4187     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4188 #endif
4189 #ifdef HAS_TM_TM_ZONE
4190     mytm.tm_zone = mytm2.tm_zone;
4191 #endif
4192   } STMT_END;
4193 #endif
4194   buflen = 64;
4195   Newx(buf, buflen, char);
4196
4197   GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
4198   len = strftime(buf, buflen, fmt, &mytm);
4199   GCC_DIAG_RESTORE_STMT;
4200
4201   /*
4202   ** The following is needed to handle to the situation where
4203   ** tmpbuf overflows.  Basically we want to allocate a buffer
4204   ** and try repeatedly.  The reason why it is so complicated
4205   ** is that getting a return value of 0 from strftime can indicate
4206   ** one of the following:
4207   ** 1. buffer overflowed,
4208   ** 2. illegal conversion specifier, or
4209   ** 3. the format string specifies nothing to be returned(not
4210   **      an error).  This could be because format is an empty string
4211   **    or it specifies %p that yields an empty string in some locale.
4212   ** If there is a better way to make it portable, go ahead by
4213   ** all means.
4214   */
4215   if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
4216     return buf;
4217   else {
4218     /* Possibly buf overflowed - try again with a bigger buf */
4219     const int fmtlen = strlen(fmt);
4220     int bufsize = fmtlen + buflen;
4221
4222     Renew(buf, bufsize, char);
4223     while (buf) {
4224
4225       GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
4226       buflen = strftime(buf, bufsize, fmt, &mytm);
4227       GCC_DIAG_RESTORE_STMT;
4228
4229       if (inRANGE(buflen, 1, bufsize - 1))
4230         break;
4231       /* heuristic to prevent out-of-memory errors */
4232       if (bufsize > 100*fmtlen) {
4233         Safefree(buf);
4234         buf = NULL;
4235         break;
4236       }
4237       bufsize *= 2;
4238       Renew(buf, bufsize, char);
4239     }
4240     return buf;
4241   }
4242 #else
4243   Perl_croak(aTHX_ "panic: no strftime");
4244   return NULL;
4245 #endif
4246 }
4247
4248
4249 #define SV_CWD_RETURN_UNDEF \
4250     sv_set_undef(sv); \
4251     return FALSE
4252
4253 #define SV_CWD_ISDOT(dp) \
4254     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4255         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4256
4257 /*
4258 =for apidoc_section $utility
4259
4260 =for apidoc getcwd_sv
4261
4262 Fill C<sv> with current working directory
4263
4264 =cut
4265 */
4266
4267 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4268  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4269  * getcwd(3) if available
4270  * Comments from the original:
4271  *     This is a faster version of getcwd.  It's also more dangerous
4272  *     because you might chdir out of a directory that you can't chdir
4273  *     back into. */
4274
4275 int
4276 Perl_getcwd_sv(pTHX_ SV *sv)
4277 {
4278 #ifndef PERL_MICRO
4279     SvTAINTED_on(sv);
4280
4281     PERL_ARGS_ASSERT_GETCWD_SV;
4282
4283 #ifdef HAS_GETCWD
4284     {
4285         char buf[MAXPATHLEN];
4286
4287         /* Some getcwd()s automatically allocate a buffer of the given
4288          * size from the heap if they are given a NULL buffer pointer.
4289          * The problem is that this behaviour is not portable. */
4290         if (getcwd(buf, sizeof(buf) - 1)) {
4291             sv_setpv(sv, buf);
4292             return TRUE;
4293         }
4294         else {
4295             SV_CWD_RETURN_UNDEF;
4296         }
4297     }
4298
4299 #else
4300
4301     Stat_t statbuf;
4302     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4303     int pathlen=0;
4304     Direntry_t *dp;
4305
4306     SvUPGRADE(sv, SVt_PV);
4307
4308     if (PerlLIO_lstat(".", &statbuf) < 0) {
4309         SV_CWD_RETURN_UNDEF;
4310     }
4311
4312     orig_cdev = statbuf.st_dev;
4313     orig_cino = statbuf.st_ino;
4314     cdev = orig_cdev;
4315     cino = orig_cino;
4316
4317     for (;;) {
4318         DIR *dir;
4319         int namelen;
4320         odev = cdev;
4321         oino = cino;
4322
4323         if (PerlDir_chdir("..") < 0) {
4324             SV_CWD_RETURN_UNDEF;
4325         }
4326         if (PerlLIO_stat(".", &statbuf) < 0) {
4327             SV_CWD_RETURN_UNDEF;
4328         }
4329
4330         cdev = statbuf.st_dev;
4331         cino = statbuf.st_ino;
4332
4333         if (odev == cdev && oino == cino) {
4334             break;
4335         }
4336         if (!(dir = PerlDir_open("."))) {
4337             SV_CWD_RETURN_UNDEF;
4338         }
4339
4340         while ((dp = PerlDir_read(dir)) != NULL) {
4341 #ifdef DIRNAMLEN
4342             namelen = dp->d_namlen;
4343 #else
4344             namelen = strlen(dp->d_name);
4345 #endif
4346             /* skip . and .. */
4347             if (SV_CWD_ISDOT(dp)) {
4348                 continue;
4349             }
4350
4351             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4352                 SV_CWD_RETURN_UNDEF;
4353             }
4354
4355             tdev = statbuf.st_dev;
4356             tino = statbuf.st_ino;
4357             if (tino == oino && tdev == odev) {
4358                 break;
4359             }
4360         }
4361
4362         if (!dp) {
4363             SV_CWD_RETURN_UNDEF;
4364         }
4365
4366         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4367             SV_CWD_RETURN_UNDEF;
4368         }
4369
4370         SvGROW(sv, pathlen + namelen + 1);
4371
4372         if (pathlen) {
4373             /* shift down */
4374             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4375         }
4376
4377         /* prepend current directory to the front */
4378         *SvPVX(sv) = '/';
4379         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4380         pathlen += (namelen + 1);
4381
4382 #ifdef VOID_CLOSEDIR
4383         PerlDir_close(dir);
4384 #else
4385         if (PerlDir_close(dir) < 0) {
4386             SV_CWD_RETURN_UNDEF;
4387         }
4388 #endif
4389     }
4390
4391     if (pathlen) {
4392         SvCUR_set(sv, pathlen);
4393         *SvEND(sv) = '\0';
4394         SvPOK_only(sv);
4395
4396         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4397             SV_CWD_RETURN_UNDEF;
4398         }
4399     }
4400     if (PerlLIO_stat(".", &statbuf) < 0) {
4401         SV_CWD_RETURN_UNDEF;
4402     }
4403
4404     cdev = statbuf.st_dev;
4405     cino = statbuf.st_ino;
4406
4407     if (cdev != orig_cdev || cino != orig_cino) {
4408         Perl_croak(aTHX_ "Unstable directory path, "
4409                    "current directory changed unexpectedly");
4410     }
4411
4412     return TRUE;
4413 #endif
4414
4415 #else
4416     return FALSE;
4417 #endif
4418 }
4419
4420 #include "vutil.c"
4421
4422 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4423 #   define EMULATE_SOCKETPAIR_UDP
4424 #endif
4425
4426 #ifdef EMULATE_SOCKETPAIR_UDP
4427 static int
4428 S_socketpair_udp (int fd[2]) {
4429     dTHX;
4430     /* Fake a datagram socketpair using UDP to localhost.  */
4431     int sockets[2] = {-1, -1};
4432     struct sockaddr_in addresses[2];
4433     int i;
4434     Sock_size_t size = sizeof(struct sockaddr_in);
4435     unsigned short port;
4436     int got;
4437
4438     memset(&addresses, 0, sizeof(addresses));
4439     i = 1;
4440     do {
4441         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4442         if (sockets[i] == -1)
4443             goto tidy_up_and_fail;
4444
4445         addresses[i].sin_family = AF_INET;
4446         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4447         addresses[i].sin_port = 0;      /* kernel choses port.  */
4448         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4449                 sizeof(struct sockaddr_in)) == -1)
4450             goto tidy_up_and_fail;
4451     } while (i--);
4452
4453     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4454        for each connect the other socket to it.  */
4455     i = 1;
4456     do {
4457         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4458                 &size) == -1)
4459             goto tidy_up_and_fail;
4460         if (size != sizeof(struct sockaddr_in))
4461             goto abort_tidy_up_and_fail;
4462         /* !1 is 0, !0 is 1 */
4463         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4464                 sizeof(struct sockaddr_in)) == -1)
4465             goto tidy_up_and_fail;
4466     } while (i--);
4467
4468     /* Now we have 2 sockets connected to each other. I don't trust some other
4469        process not to have already sent a packet to us (by random) so send
4470        a packet from each to the other.  */
4471     i = 1;
4472     do {
4473         /* I'm going to send my own port number.  As a short.
4474            (Who knows if someone somewhere has sin_port as a bitfield and needs
4475            this routine. (I'm assuming crays have socketpair)) */
4476         port = addresses[i].sin_port;
4477         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4478         if (got != sizeof(port)) {
4479             if (got == -1)
4480                 goto tidy_up_and_fail;
4481             goto abort_tidy_up_and_fail;
4482         }
4483     } while (i--);
4484
4485     /* Packets sent. I don't trust them to have arrived though.
4486        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4487        connect to localhost will use a second kernel thread. In 2.6 the
4488        first thread running the connect() returns before the second completes,
4489        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4490        returns 0. Poor programs have tripped up. One poor program's authors'
4491        had a 50-1 reverse stock split. Not sure how connected these were.)
4492        So I don't trust someone not to have an unpredictable UDP stack.
4493     */
4494
4495     {
4496         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4497         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4498         fd_set rset;
4499
4500         FD_ZERO(&rset);
4501         FD_SET((unsigned int)sockets[0], &rset);
4502         FD_SET((unsigned int)sockets[1], &rset);
4503
4504         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4505         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4506                 || !FD_ISSET(sockets[1], &rset)) {
4507             /* I hope this is portable and appropriate.  */
4508             if (got == -1)
4509                 goto tidy_up_and_fail;
4510             goto abort_tidy_up_and_fail;
4511         }
4512     }
4513
4514     /* And the paranoia department even now doesn't trust it to have arrive
4515        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4516     {
4517         struct sockaddr_in readfrom;
4518         unsigned short buffer[2];
4519
4520         i = 1;
4521         do {
4522 #ifdef MSG_DONTWAIT
4523             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4524                     sizeof(buffer), MSG_DONTWAIT,
4525                     (struct sockaddr *) &readfrom, &size);
4526 #else
4527             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4528                     sizeof(buffer), 0,
4529                     (struct sockaddr *) &readfrom, &size);
4530 #endif
4531
4532             if (got == -1)
4533                 goto tidy_up_and_fail;
4534             if (got != sizeof(port)
4535                     || size != sizeof(struct sockaddr_in)
4536                     /* Check other socket sent us its port.  */
4537                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4538                     /* Check kernel says we got the datagram from that socket */
4539                     || readfrom.sin_family != addresses[!i].sin_family
4540                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4541                     || readfrom.sin_port != addresses[!i].sin_port)
4542                 goto abort_tidy_up_and_fail;
4543         } while (i--);
4544     }
4545     /* My caller (my_socketpair) has validated that this is non-NULL  */
4546     fd[0] = sockets[0];
4547     fd[1] = sockets[1];
4548     /* I hereby declare this connection open.  May God bless all who cross
4549        her.  */
4550     return 0;
4551
4552   abort_tidy_up_and_fail:
4553     errno = ECONNABORTED;
4554   tidy_up_and_fail:
4555     {
4556         dSAVE_ERRNO;
4557         if (sockets[0] != -1)
4558             PerlLIO_close(sockets[0]);
4559         if (sockets[1] != -1)
4560             PerlLIO_close(sockets[1]);
4561         RESTORE_ERRNO;
4562         return -1;
4563     }
4564 }
4565 #endif /*  EMULATE_SOCKETPAIR_UDP */
4566
4567 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4568 int
4569 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4570     /* Stevens says that family must be AF_LOCAL, protocol 0.
4571        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4572     dTHXa(NULL);
4573     int listener = -1;
4574     int connector = -1;
4575     int acceptor = -1;
4576     struct sockaddr_in listen_addr;
4577     struct sockaddr_in connect_addr;
4578     Sock_size_t size;
4579
4580     if (protocol
4581 #ifdef AF_UNIX
4582         || family != AF_UNIX
4583 #endif
4584     ) {
4585         errno = EAFNOSUPPORT;
4586         return -1;
4587     }
4588     if (!fd) {
4589         errno = EINVAL;
4590         return -1;
4591     }
4592
4593 #ifdef SOCK_CLOEXEC
4594     type &= ~SOCK_CLOEXEC;
4595 #endif
4596
4597 #ifdef EMULATE_SOCKETPAIR_UDP
4598     if (type == SOCK_DGRAM)
4599         return S_socketpair_udp(fd);
4600 #endif
4601
4602     aTHXa(PERL_GET_THX);
4603     listener = PerlSock_socket(AF_INET, type, 0);
4604     if (listener == -1)
4605         return -1;
4606     memset(&listen_addr, 0, sizeof(listen_addr));
4607     listen_addr.sin_family = AF_INET;
4608     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4609     listen_addr.sin_port = 0;   /* kernel choses port.  */
4610     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4611             sizeof(listen_addr)) == -1)
4612         goto tidy_up_and_fail;
4613     if (PerlSock_listen(listener, 1) == -1)
4614         goto tidy_up_and_fail;
4615
4616     connector = PerlSock_socket(AF_INET, type, 0);
4617     if (connector == -1)
4618         goto tidy_up_and_fail;
4619     /* We want to find out the port number to connect to.  */
4620     size = sizeof(connect_addr);
4621     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4622             &size) == -1)
4623         goto tidy_up_and_fail;
4624     if (size != sizeof(connect_addr))
4625         goto abort_tidy_up_and_fail;
4626     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4627             sizeof(connect_addr)) == -1)
4628         goto tidy_up_and_fail;
4629
4630     size = sizeof(listen_addr);
4631     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4632             &size);
4633     if (acceptor == -1)
4634         goto tidy_up_and_fail;
4635     if (size != sizeof(listen_addr))
4636         goto abort_tidy_up_and_fail;
4637     PerlLIO_close(listener);
4638     /* Now check we are talking to ourself by matching port and host on the
4639        two sockets.  */
4640     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4641             &size) == -1)
4642         goto tidy_up_and_fail;
4643     if (size != sizeof(connect_addr)
4644             || listen_addr.sin_family != connect_addr.sin_family
4645             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4646             || listen_addr.sin_port != connect_addr.sin_port) {
4647         goto abort_tidy_up_and_fail;
4648     }
4649     fd[0] = connector;
4650     fd[1] = acceptor;
4651     return 0;
4652
4653   abort_tidy_up_and_fail:
4654 #ifdef ECONNABORTED
4655   errno = ECONNABORTED; /* This would be the standard thing to do. */
4656 #elif defined(ECONNREFUSED)
4657   errno = ECONNREFUSED; /* some OSes might not have ECONNABORTED. */
4658 #else
4659   errno = ETIMEDOUT;    /* Desperation time. */
4660 #endif
4661   tidy_up_and_fail:
4662     {
4663         dSAVE_ERRNO;
4664         if (listener != -1)
4665             PerlLIO_close(listener);
4666         if (connector != -1)
4667             PerlLIO_close(connector);
4668         if (acceptor != -1)
4669             PerlLIO_close(acceptor);
4670         RESTORE_ERRNO;
4671         return -1;
4672     }
4673 }
4674 #else
4675 /* In any case have a stub so that there's code corresponding
4676  * to the my_socketpair in embed.fnc. */
4677 int
4678 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4679 #ifdef HAS_SOCKETPAIR
4680     return socketpair(family, type, protocol, fd);
4681 #else
4682     return -1;
4683 #endif
4684 }
4685 #endif
4686
4687 /*
4688
4689 =for apidoc sv_nosharing
4690
4691 Dummy routine which "shares" an SV when there is no sharing module present.
4692 Or "locks" it.  Or "unlocks" it.  In other
4693 words, ignores its single SV argument.
4694 Exists to avoid test for a C<NULL> function pointer and because it could
4695 potentially warn under some level of strict-ness.
4696
4697 =cut
4698 */
4699
4700 void
4701 Perl_sv_nosharing(pTHX_ SV *sv)
4702 {
4703     PERL_UNUSED_CONTEXT;
4704     PERL_UNUSED_ARG(sv);
4705 }
4706
4707 /*
4708
4709 =for apidoc sv_destroyable
4710
4711 Dummy routine which reports that object can be destroyed when there is no
4712 sharing module present.  It ignores its single SV argument, and returns
4713 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4714 could potentially warn under some level of strict-ness.
4715
4716 =cut
4717 */
4718
4719 bool
4720 Perl_sv_destroyable(pTHX_ SV *sv)
4721 {
4722     PERL_UNUSED_CONTEXT;
4723     PERL_UNUSED_ARG(sv);
4724     return TRUE;
4725 }
4726
4727 U32
4728 Perl_parse_unicode_opts(pTHX_ const char **popt)
4729 {
4730   const char *p = *popt;
4731   U32 opt = 0;
4732
4733   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4734
4735   if (*p) {
4736        if (isDIGIT(*p)) {
4737             const char* endptr = p + strlen(p);
4738             UV uv;
4739             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4740                 opt = (U32)uv;
4741                 p = endptr;
4742                 if (p && *p && *p != '\n' && *p != '\r') {
4743                     if (isSPACE(*p))
4744                         goto the_end_of_the_opts_parser;
4745                     else
4746                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4747                 }
4748             }
4749             else {
4750                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4751             }
4752         }
4753         else {
4754             for (; *p; p++) {
4755                  switch (*p) {
4756                  case PERL_UNICODE_STDIN:
4757                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4758                  case PERL_UNICODE_STDOUT:
4759                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4760                  case PERL_UNICODE_STDERR:
4761                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4762                  case PERL_UNICODE_STD:
4763                       opt |= PERL_UNICODE_STD_FLAG;     break;
4764                  case PERL_UNICODE_IN:
4765                       opt |= PERL_UNICODE_IN_FLAG;      break;
4766                  case PERL_UNICODE_OUT:
4767                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4768                  case PERL_UNICODE_INOUT:
4769                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4770                  case PERL_UNICODE_LOCALE:
4771                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4772                  case PERL_UNICODE_ARGV:
4773                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4774                  case PERL_UNICODE_UTF8CACHEASSERT:
4775                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4776                  default:
4777                       if (*p != '\n' && *p != '\r') {
4778                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4779                         else
4780                           Perl_croak(aTHX_
4781                                      "Unknown Unicode option letter '%c'", *p);
4782                       }
4783                  }
4784             }
4785        }
4786   }
4787   else
4788        opt = PERL_UNICODE_DEFAULT_FLAGS;
4789
4790   the_end_of_the_opts_parser:
4791
4792   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4793        Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4794                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4795
4796   *popt = p;
4797
4798   return opt;
4799 }
4800
4801 #ifdef VMS
4802 #  include <starlet.h>
4803 #endif
4804
4805 U32
4806 Perl_seed(pTHX)
4807 {
4808     /*
4809      * This is really just a quick hack which grabs various garbage
4810      * values.  It really should be a real hash algorithm which
4811      * spreads the effect of every input bit onto every output bit,
4812      * if someone who knows about such things would bother to write it.
4813      * Might be a good idea to add that function to CORE as well.
4814      * No numbers below come from careful analysis or anything here,
4815      * except they are primes and SEED_C1 > 1E6 to get a full-width
4816      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4817      * probably be bigger too.
4818      */
4819 #if RANDBITS > 16
4820 #  define SEED_C1       1000003
4821 #define   SEED_C4       73819
4822 #else
4823 #  define SEED_C1       25747
4824 #define   SEED_C4       20639
4825 #endif
4826 #define   SEED_C2       3
4827 #define   SEED_C3       269
4828 #define   SEED_C5       26107
4829
4830 #ifndef PERL_NO_DEV_RANDOM
4831     int fd;
4832 #endif
4833     U32 u;
4834 #ifdef HAS_GETTIMEOFDAY
4835     struct timeval when;
4836 #else
4837     Time_t when;
4838 #endif
4839
4840 /* This test is an escape hatch, this symbol isn't set by Configure. */
4841 #ifndef PERL_NO_DEV_RANDOM
4842 #ifndef PERL_RANDOM_DEVICE
4843    /* /dev/random isn't used by default because reads from it will block
4844     * if there isn't enough entropy available.  You can compile with
4845     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4846     * is enough real entropy to fill the seed. */
4847 #  ifdef __amigaos4__
4848 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4849 #  else
4850 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4851 #  endif
4852 #endif
4853     fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
4854     if (fd != -1) {
4855         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4856             u = 0;
4857         PerlLIO_close(fd);
4858         if (u)
4859             return u;
4860     }
4861 #endif
4862
4863 #ifdef HAS_GETTIMEOFDAY
4864     PerlProc_gettimeofday(&when,NULL);
4865     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4866 #else
4867     (void)time(&when);
4868     u = (U32)SEED_C1 * when;
4869 #endif
4870     u += SEED_C3 * (U32)PerlProc_getpid();
4871     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4872 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4873     u += SEED_C5 * (U32)PTR2UV(&when);
4874 #endif
4875     return u;
4876 }
4877
4878 void
4879 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4880 {
4881 #ifndef NO_PERL_HASH_ENV
4882     const char *env_pv;
4883 #endif
4884     unsigned long i;
4885
4886     PERL_ARGS_ASSERT_GET_HASH_SEED;
4887
4888 #ifndef NO_PERL_HASH_ENV
4889     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4890
4891     if ( env_pv )
4892     {
4893         /* ignore leading spaces */
4894         while (isSPACE(*env_pv))
4895             env_pv++;
4896 #    ifdef USE_PERL_PERTURB_KEYS
4897         /* if they set it to "0" we disable key traversal randomization completely */
4898         if (strEQ(env_pv,"0")) {
4899             PL_hash_rand_bits_enabled= 0;
4900         } else {
4901             /* otherwise switch to deterministic mode */
4902             PL_hash_rand_bits_enabled= 2;
4903         }
4904 #    endif
4905         /* ignore a leading 0x... if it is there */
4906         if (env_pv[0] == '0' && env_pv[1] == 'x')
4907             env_pv += 2;
4908
4909         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4910             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4911             if ( isXDIGIT(*env_pv)) {
4912                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4913             }
4914         }
4915         while (isSPACE(*env_pv))
4916             env_pv++;
4917
4918         if (*env_pv && !isXDIGIT(*env_pv)) {
4919             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4920         }
4921         /* should we check for unparsed crap? */
4922         /* should we warn about unused hex? */
4923         /* should we warn about insufficient hex? */
4924     }
4925     else
4926 #endif /* NO_PERL_HASH_ENV */
4927     {
4928         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4929             seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
4930         }
4931     }
4932 #ifdef USE_PERL_PERTURB_KEYS
4933     {   /* initialize PL_hash_rand_bits from the hash seed.
4934          * This value is highly volatile, it is updated every
4935          * hash insert, and is used as part of hash bucket chain
4936          * randomization and hash iterator randomization. */
4937         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4938         for( i = 0; i < sizeof(UV) ; i++ ) {
4939             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4940             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4941         }
4942     }
4943 #  ifndef NO_PERL_HASH_ENV
4944     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4945     if (env_pv) {
4946         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4947             PL_hash_rand_bits_enabled= 0;
4948         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4949             PL_hash_rand_bits_enabled= 1;
4950         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4951             PL_hash_rand_bits_enabled= 2;
4952         } else {
4953             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4954         }
4955     }
4956 #  endif
4957 #endif
4958 }
4959
4960 #ifdef PERL_MEM_LOG
4961
4962 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4963  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4964  * given, and you supply your own implementation.
4965  *
4966  * The default implementation reads a single env var, PERL_MEM_LOG,
4967  * expecting one or more of the following:
4968  *
4969  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4970  *    'm' - memlog      was PERL_MEM_LOG=1
4971  *    's' - svlog       was PERL_SV_LOG=1
4972  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4973  *
4974  * This makes the logger controllable enough that it can reasonably be
4975  * added to the system perl.
4976  */
4977
4978 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4979  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4980  */
4981 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4982
4983 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4984  * writes to.  In the default logger, this is settable at runtime.
4985  */
4986 #ifndef PERL_MEM_LOG_FD
4987 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4988 #endif
4989
4990 #ifndef PERL_MEM_LOG_NOIMPL
4991
4992 # ifdef DEBUG_LEAKING_SCALARS
4993 #   define SV_LOG_SERIAL_FMT        " [%lu]"
4994 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
4995 # else
4996 #   define SV_LOG_SERIAL_FMT
4997 #   define _SV_LOG_SERIAL_ARG(sv)
4998 # endif
4999
5000 static void
5001 S_mem_log_common(enum mem_log_type mlt, const UV n, 
5002                  const UV typesize, const char *type_name, const SV *sv,
5003                  Malloc_t oldalloc, Malloc_t newalloc,
5004                  const char *filename, const int linenumber,
5005                  const char *funcname)
5006 {
5007     const char *pmlenv;
5008
5009     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5010
5011     pmlenv = PerlEnv_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
5042             ) {
5043                 fd = (int)uv;
5044             } else {
5045                 fd = PERL_MEM_LOG_FD;
5046             }
5047
5048             if (strchr(pmlenv, 't')) {
5049                 len = my_snprintf(buf, sizeof(buf),
5050                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5051                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5052             }
5053             switch (mlt) {
5054             case MLT_ALLOC:
5055                 len = my_snprintf(buf, sizeof(buf),
5056                         "alloc: %s:%d:%s: %" IVdf " %" UVuf
5057                         " %s = %" IVdf ": %" UVxf "\n",
5058                         filename, linenumber, funcname, n, typesize,