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