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