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