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