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