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