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