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