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