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