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