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