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