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