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