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