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