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