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
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.
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
15 * [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
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.
25 #define PERL_IN_UTIL_C
29 #if defined(USE_PERLIO)
30 #include "perliol.h" /* For PerlIOUnix_refcnt */
36 # define SIG_ERR ((Sighandler_t) -1)
44 /* Missing protos on LynxOS */
49 # include "amigaos4/amigaio.h"
54 # include <sys/select.h>
58 #ifdef USE_C_BACKTRACE
62 # undef USE_BFD /* BFD is useless in OS X. */
72 # include <execinfo.h>
76 #ifdef PERL_DEBUG_READONLY_COW
77 # include <sys/mman.h>
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.
88 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
89 # define ALWAYS_NEED_THX
92 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
94 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
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);
103 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
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);
110 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
111 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
113 # define maybe_protect_rw(foo) NOOP
114 # define maybe_protect_ro(foo) NOOP
117 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
118 /* Use memory_debug_header */
120 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
121 || defined(PERL_DEBUG_READONLY_COW)
122 # define MDH_HAS_SIZE
126 /* paranoid version of system's malloc() */
129 Perl_safesysmalloc(MEM_SIZE size)
131 #ifdef ALWAYS_NEED_THX
137 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
139 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
142 if ((SSize_t)size < 0)
143 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
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");
153 ptr = (Malloc_t)PerlMem_malloc(size?size:1);
155 PERL_ALLOC_CHECK(ptr);
158 struct perl_memory_debug_header *const header
159 = (struct perl_memory_debug_header *)ptr;
163 PoisonNew(((char *)ptr), size, char);
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;
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));
191 #ifndef ALWAYS_NEED_THX
203 /* paranoid version of system's realloc() */
206 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
208 #ifdef ALWAYS_NEED_THX
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
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) */
226 ptr = safesysmalloc(size);
230 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
231 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
233 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
235 struct perl_memory_debug_header *const header
236 = (struct perl_memory_debug_header *)where;
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);
243 assert(header->next->prev == header);
244 assert(header->prev->next == header);
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);
259 if ((SSize_t)size < 0)
260 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
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");
268 Copy(where,ptr,oldsize < size ? oldsize : size,char);
269 if (munmap(where, oldsize)) {
270 perror("munmap failed");
274 ptr = (Malloc_t)PerlMem_realloc(where,size);
276 PERL_ALLOC_CHECK(ptr);
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. */
282 #ifdef PERL_TRACK_MEMPOOL
283 struct perl_memory_debug_header *const header
284 = (struct perl_memory_debug_header *)ptr;
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);
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);
301 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
304 /* In particular, must do that fixup above before logging anything via
305 *printf(), as it can reallocate memory, which can cause SEGVs. */
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));
315 #ifndef ALWAYS_NEED_THX
328 /* safe version of system's free() */
331 Perl_safesysfree(Malloc_t where)
333 #ifdef ALWAYS_NEED_THX
336 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
339 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
341 struct perl_memory_debug_header *const header
342 = (struct perl_memory_debug_header *)where_intrn;
345 const MEM_SIZE size = header->size;
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);
353 Perl_croak_nocontext("panic: duplicate free");
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,
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);
372 PoisonNew(where_intrn, size, char);
374 /* Trigger the duplicate free warning. */
377 # ifdef PERL_DEBUG_READONLY_COW
378 if (munmap(where_intrn, size)) {
379 perror("munmap failed");
385 Malloc_t where_intrn = where;
387 #ifndef PERL_DEBUG_READONLY_COW
388 PerlMem_free(where_intrn);
393 /* safe version of system's calloc() */
396 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
398 #ifdef ALWAYS_NEED_THX
402 #if defined(USE_MDH) || defined(DEBUGGING)
403 MEM_SIZE total_size = 0;
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;
415 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
416 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
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);
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");
431 #elif defined(PERL_TRACK_MEMPOOL)
432 /* Have to use malloc() because we've added some space for our tracking
434 /* malloc(0) is non-portable. */
435 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
437 /* Use calloc() because it might save a memset() if the memory is fresh
438 and clean from the OS. */
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);
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));
449 struct perl_memory_debug_header *const header
450 = (struct perl_memory_debug_header *)ptr;
452 # ifndef PERL_DEBUG_READONLY_COW
453 memset((void*)ptr, 0, total_size);
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;
469 header->size = total_size;
471 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
477 #ifndef ALWAYS_NEED_THX
486 /* These must be defined when not using Perl's malloc for binary
491 Malloc_t Perl_malloc (MEM_SIZE nbytes)
493 #ifdef PERL_IMPLICIT_SYS
496 return (Malloc_t)PerlMem_malloc(nbytes);
499 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
501 #ifdef PERL_IMPLICIT_SYS
504 return (Malloc_t)PerlMem_calloc(elements, size);
507 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
509 #ifdef PERL_IMPLICIT_SYS
512 return (Malloc_t)PerlMem_realloc(where, nbytes);
515 Free_t Perl_mfree (Malloc_t where)
517 #ifdef PERL_IMPLICIT_SYS
525 /* copy a string up to some (non-backslashed) delimiter, if any */
528 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
532 PERL_ARGS_ASSERT_DELIMCPY;
534 for (tolen = 0; from < fromend; from++, tolen++) {
536 if (from[1] != delim) {
543 else if (*from == delim)
554 /* return ptr to little string in big string, NULL if not found */
555 /* This routine was donated by Corey Satten. */
558 Perl_instr(const char *big, const char *little)
561 PERL_ARGS_ASSERT_INSTR;
563 return strstr((char*)big, (char*)little);
566 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond
567 * the final character desired to be checked */
570 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
572 PERL_ARGS_ASSERT_NINSTR;
576 const char first = *little;
578 bigend -= lend - little++;
580 while (big <= bigend) {
581 if (*big++ == first) {
582 for (x=big,s=little; s < lend; x++,s++) {
586 return (char*)(big-1);
593 /* reverse of the above--find last substring */
596 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
599 const I32 first = *little;
600 const char * const littleend = lend;
602 PERL_ARGS_ASSERT_RNINSTR;
604 if (little >= littleend)
605 return (char*)bigend;
607 big = bigend - (littleend - little++);
608 while (big >= bigbeg) {
612 for (x=big+2,s=little; s < littleend; /**/ ) {
621 return (char*)(big+1);
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().
630 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
633 =head1 Miscellaneous Functions
635 =for apidoc fbm_compile
637 Analyses the string in order to make fast searches on it using C<fbm_instr()>
638 -- the Boyer-Moore algorithm.
644 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
651 PERL_DEB( STRLEN rarest = 0 );
653 PERL_ARGS_ASSERT_FBM_COMPILE;
655 if (isGV_with_GP(sv) || SvROK(sv))
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)
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. */
672 SvUPGRADE(sv, SVt_PVMG);
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.
681 The comment itself (and "deeper magic" below) date back to
682 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
684 where the magic (presumably) was that the scalar had a BM table hidden
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. */
691 assert(!mg_find(sv, PERL_MAGIC_bm));
692 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
696 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
698 const U8 mlen = (len>255) ? 255 : (U8)len;
699 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
702 Newx(table, 256, U8);
703 memset((void*)table, mlen, 256);
704 mg->mg_ptr = (char *)table;
707 s += len - 1; /* last char */
710 if (table[*s] == mlen)
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]];
723 BmUSEFUL(sv) = 100; /* Initial value */
724 if (flags & FBMcf_TAIL)
726 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
727 s[rarest], (UV)rarest));
732 =for apidoc fbm_instr
734 Returns the location of the SV in the string delimited by C<big> and
735 C<bigend> (C<bigend>) is the char following the last char).
736 It returns C<NULL> if the string can't be found. The C<sv>
737 does not have to be C<fbm_compiled>, but the search will not be as fast
742 If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
743 during FBM compilation due to FBMcf_TAIL in flags. It indicates that
744 the littlestr must be anchored to the end of bigstr (or to any \n if
747 E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
748 while /abc$/ compiles to "abc\n" with SvTAIL() true.
750 A littlestr of "abc", !SvTAIL matches as /abc/;
751 a littlestr of "ab\n", SvTAIL matches as:
752 without FBMrf_MULTILINE: /ab\n?\z/
753 with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
755 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
756 "If SvTAIL is actually due to \Z or \z, this gives false positives
762 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
766 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
767 STRLEN littlelen = l;
768 const I32 multiline = flags & FBMrf_MULTILINE;
770 PERL_ARGS_ASSERT_FBM_INSTR;
772 if ((STRLEN)(bigend - big) < littlelen) {
773 if ( SvTAIL(littlestr)
774 && ((STRLEN)(bigend - big) == littlelen - 1)
776 || (*big == *little &&
777 memEQ((char *)big, (char *)little, littlelen - 1))))
782 switch (littlelen) { /* Special cases for 0, 1 and 2 */
784 return (char*)big; /* Cannot be SvTAIL! */
787 if (SvTAIL(littlestr) && !multiline) /* Anchor only! */
788 /* [-1] is safe because we know that bigend != big. */
789 return (char *) (bigend - (bigend[-1] == '\n'));
791 s = (unsigned char *)memchr((void*)big, *little, bigend-big);
794 if (SvTAIL(littlestr))
795 return (char *) bigend;
799 if (SvTAIL(littlestr) && !multiline) {
800 /* a littlestr with SvTAIL must be of the form "X\n" (where X
801 * is a single char). It is anchored, and can only match
802 * "....X\n" or "....X" */
803 if (bigend[-2] == *little && bigend[-1] == '\n')
804 return (char*)bigend - 2;
805 if (bigend[-1] == *little)
806 return (char*)bigend - 1;
811 /* memchr() is likely to be very fast, possibly using whatever
812 * hardware support is available, such as checking a whole
813 * cache line in one instruction.
814 * So for a 2 char pattern, calling memchr() is likely to be
815 * faster than running FBM, or rolling our own. The previous
816 * version of this code was roll-your-own which typically
817 * only needed to read every 2nd char, which was good back in
818 * the day, but no longer.
820 unsigned char c1 = little[0];
821 unsigned char c2 = little[1];
823 /* *** for all this case, bigend points to the last char,
824 * not the trailing \0: this makes the conditions slightly
830 /* do a quick test for c1 before calling memchr();
831 * this avoids the expensive fn call overhead when
832 * there are lots of c1's */
833 if (LIKELY(*s != c1)) {
835 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
842 /* failed; try searching for c2 this time; that way
843 * we don't go pathologically slow when the string
844 * consists mostly of c1's or vice versa.
849 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
857 /* c1, c2 the same */
867 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
868 if (!s || s >= bigend)
875 /* failed to find 2 chars; try anchored match at end without
877 if (SvTAIL(littlestr) && bigend[0] == little[0])
878 return (char *)bigend;
883 break; /* Only lengths 0 1 and 2 have special-case code. */
886 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
887 s = bigend - littlelen;
888 if (s >= big && bigend[-1] == '\n' && *s == *little
889 /* Automatically of length > 2 */
890 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
892 return (char*)s; /* how sweet it is */
895 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
897 return (char*)s + 1; /* how sweet it is */
902 if (!SvVALID(littlestr)) {
903 /* not compiled; use Perl_ninstr() instead */
904 char * const b = ninstr((char*)big,(char*)bigend,
905 (char*)little, (char*)little + littlelen);
907 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
908 /* Chop \n from littlestr: */
909 s = bigend - littlelen + 1;
911 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
921 if (littlelen > (STRLEN)(bigend - big))
925 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
926 const unsigned char *oldlittle;
930 --littlelen; /* Last char found by table lookup */
933 little += littlelen; /* last char */
936 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
937 const unsigned char lastc = *little;
941 if ((tmp = table[*s])) {
942 /* *s != lastc; earliest position it could match now is
943 * tmp slots further on */
944 if ((s += tmp) >= bigend)
946 if (LIKELY(*s != lastc)) {
948 s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
958 /* hand-rolled strncmp(): less expensive than calling the
959 * real function (maybe???) */
961 unsigned char * const olds = s;
966 if (*--s == *--little)
968 s = olds + 1; /* here we pay the price for failure */
970 if (s < bigend) /* fake up continue to outer loop */
980 && memEQ((char *)(bigend - littlelen),
981 (char *)(oldlittle - littlelen), littlelen) )
982 return (char*)bigend - littlelen;
991 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
993 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
994 match themselves and their opposite case counterparts. Non-cased and non-ASCII
995 range bytes match only themselves.
1002 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1004 const U8 *a = (const U8 *)s1;
1005 const U8 *b = (const U8 *)s2;
1007 PERL_ARGS_ASSERT_FOLDEQ;
1012 if (*a != *b && *a != PL_fold[*b])
1019 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1021 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1022 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1023 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1024 * does it check that the strings each have at least 'len' characters */
1026 const U8 *a = (const U8 *)s1;
1027 const U8 *b = (const U8 *)s2;
1029 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1034 if (*a != *b && *a != PL_fold_latin1[*b]) {
1043 =for apidoc foldEQ_locale
1045 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1046 same case-insensitively in the current locale; false otherwise.
1052 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1055 const U8 *a = (const U8 *)s1;
1056 const U8 *b = (const U8 *)s2;
1058 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1063 if (*a != *b && *a != PL_fold_locale[*b])
1070 /* copy a string to a safe spot */
1073 =head1 Memory Management
1077 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1078 string which is a duplicate of C<pv>. The size of the string is
1079 determined by C<strlen()>, which means it may not contain embedded C<NUL>
1080 characters and must have a trailing C<NUL>. The memory allocated for the new
1081 string can be freed with the C<Safefree()> function.
1083 On some platforms, Windows for example, all allocated memory owned by a thread
1084 is deallocated when that thread ends. So if you need that not to happen, you
1085 need to use the shared memory functions, such as C<L</savesharedpv>>.
1091 Perl_savepv(pTHX_ const char *pv)
1093 PERL_UNUSED_CONTEXT;
1098 const STRLEN pvlen = strlen(pv)+1;
1099 Newx(newaddr, pvlen, char);
1100 return (char*)memcpy(newaddr, pv, pvlen);
1104 /* same thing but with a known length */
1109 Perl's version of what C<strndup()> would be if it existed. Returns a
1110 pointer to a newly allocated string which is a duplicate of the first
1111 C<len> bytes from C<pv>, plus a trailing
1112 C<NUL> byte. The memory allocated for
1113 the new string can be freed with the C<Safefree()> function.
1115 On some platforms, Windows for example, all allocated memory owned by a thread
1116 is deallocated when that thread ends. So if you need that not to happen, you
1117 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1123 Perl_savepvn(pTHX_ const char *pv, I32 len)
1126 PERL_UNUSED_CONTEXT;
1130 Newx(newaddr,len+1,char);
1131 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1133 /* might not be null terminated */
1134 newaddr[len] = '\0';
1135 return (char *) CopyD(pv,newaddr,len,char);
1138 return (char *) ZeroD(newaddr,len+1,char);
1143 =for apidoc savesharedpv
1145 A version of C<savepv()> which allocates the duplicate string in memory
1146 which is shared between threads.
1151 Perl_savesharedpv(pTHX_ const char *pv)
1156 PERL_UNUSED_CONTEXT;
1161 pvlen = strlen(pv)+1;
1162 newaddr = (char*)PerlMemShared_malloc(pvlen);
1166 return (char*)memcpy(newaddr, pv, pvlen);
1170 =for apidoc savesharedpvn
1172 A version of C<savepvn()> which allocates the duplicate string in memory
1173 which is shared between threads. (With the specific difference that a C<NULL>
1174 pointer is not acceptable)
1179 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1181 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1183 PERL_UNUSED_CONTEXT;
1184 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1189 newaddr[len] = '\0';
1190 return (char*)memcpy(newaddr, pv, len);
1194 =for apidoc savesvpv
1196 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1197 the passed in SV using C<SvPV()>
1199 On some platforms, Windows for example, all allocated memory owned by a thread
1200 is deallocated when that thread ends. So if you need that not to happen, you
1201 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1207 Perl_savesvpv(pTHX_ SV *sv)
1210 const char * const pv = SvPV_const(sv, len);
1213 PERL_ARGS_ASSERT_SAVESVPV;
1216 Newx(newaddr,len,char);
1217 return (char *) CopyD(pv,newaddr,len,char);
1221 =for apidoc savesharedsvpv
1223 A version of C<savesharedpv()> which allocates the duplicate string in
1224 memory which is shared between threads.
1230 Perl_savesharedsvpv(pTHX_ SV *sv)
1233 const char * const pv = SvPV_const(sv, len);
1235 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1237 return savesharedpvn(pv, len);
1240 /* the SV for Perl_form() and mess() is not kept in an arena */
1248 if (PL_phase != PERL_PHASE_DESTRUCT)
1249 return newSVpvs_flags("", SVs_TEMP);
1254 /* Create as PVMG now, to avoid any upgrading later */
1256 Newxz(any, 1, XPVMG);
1257 SvFLAGS(sv) = SVt_PVMG;
1258 SvANY(sv) = (void*)any;
1260 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1265 #if defined(PERL_IMPLICIT_CONTEXT)
1267 Perl_form_nocontext(const char* pat, ...)
1272 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1273 va_start(args, pat);
1274 retval = vform(pat, &args);
1278 #endif /* PERL_IMPLICIT_CONTEXT */
1281 =head1 Miscellaneous Functions
1284 Takes a sprintf-style format pattern and conventional
1285 (non-SV) arguments and returns the formatted string.
1287 (char *) Perl_form(pTHX_ const char* pat, ...)
1289 can be used any place a string (char *) is required:
1291 char * s = Perl_form("%d.%d",major,minor);
1293 Uses a single private buffer so if you want to format several strings you
1294 must explicitly copy the earlier strings away (and free the copies when you
1301 Perl_form(pTHX_ const char* pat, ...)
1305 PERL_ARGS_ASSERT_FORM;
1306 va_start(args, pat);
1307 retval = vform(pat, &args);
1313 Perl_vform(pTHX_ const char *pat, va_list *args)
1315 SV * const sv = mess_alloc();
1316 PERL_ARGS_ASSERT_VFORM;
1317 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1322 =for apidoc Am|SV *|mess|const char *pat|...
1324 Take a sprintf-style format pattern and argument list. These are used to
1325 generate a string message. If the message does not end with a newline,
1326 then it will be extended with some indication of the current location
1327 in the code, as described for L</mess_sv>.
1329 Normally, the resulting message is returned in a new mortal SV.
1330 During global destruction a single SV may be shared between uses of
1336 #if defined(PERL_IMPLICIT_CONTEXT)
1338 Perl_mess_nocontext(const char *pat, ...)
1343 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1344 va_start(args, pat);
1345 retval = vmess(pat, &args);
1349 #endif /* PERL_IMPLICIT_CONTEXT */
1352 Perl_mess(pTHX_ const char *pat, ...)
1356 PERL_ARGS_ASSERT_MESS;
1357 va_start(args, pat);
1358 retval = vmess(pat, &args);
1364 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1367 /* Look for curop starting from o. cop is the last COP we've seen. */
1368 /* opnext means that curop is actually the ->op_next of the op we are
1371 PERL_ARGS_ASSERT_CLOSEST_COP;
1373 if (!o || !curop || (
1374 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1378 if (o->op_flags & OPf_KIDS) {
1380 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1383 /* If the OP_NEXTSTATE has been optimised away we can still use it
1384 * the get the file and line number. */
1386 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1387 cop = (const COP *)kid;
1389 /* Keep searching, and return when we've found something. */
1391 new_cop = closest_cop(cop, kid, curop, opnext);
1397 /* Nothing found. */
1403 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1405 Expands a message, intended for the user, to include an indication of
1406 the current location in the code, if the message does not already appear
1409 C<basemsg> is the initial message or object. If it is a reference, it
1410 will be used as-is and will be the result of this function. Otherwise it
1411 is used as a string, and if it already ends with a newline, it is taken
1412 to be complete, and the result of this function will be the same string.
1413 If the message does not end with a newline, then a segment such as C<at
1414 foo.pl line 37> will be appended, and possibly other clauses indicating
1415 the current state of execution. The resulting message will end with a
1418 Normally, the resulting message is returned in a new mortal SV.
1419 During global destruction a single SV may be shared between uses of this
1420 function. If C<consume> is true, then the function is permitted (but not
1421 required) to modify and return C<basemsg> instead of allocating a new SV.
1427 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1431 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1435 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1436 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1437 && grok_atoUV(ws, &wi, NULL)
1438 && wi <= PERL_INT_MAX
1440 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1445 PERL_ARGS_ASSERT_MESS_SV;
1447 if (SvROK(basemsg)) {
1453 sv_setsv(sv, basemsg);
1458 if (SvPOK(basemsg) && consume) {
1463 sv_copypv(sv, basemsg);
1466 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1468 * Try and find the file and line for PL_op. This will usually be
1469 * PL_curcop, but it might be a cop that has been optimised away. We
1470 * can try to find such a cop by searching through the optree starting
1471 * from the sibling of PL_curcop.
1475 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1480 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1481 OutCopFILE(cop), (IV)CopLINE(cop));
1482 /* Seems that GvIO() can be untrustworthy during global destruction. */
1483 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1484 && IoLINES(GvIOp(PL_last_in_gv)))
1487 const bool line_mode = (RsSIMPLE(PL_rs) &&
1488 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1489 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1490 SVfARG(PL_last_in_gv == PL_argvgv
1492 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1493 line_mode ? "line" : "chunk",
1494 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1496 if (PL_phase == PERL_PHASE_DESTRUCT)
1497 sv_catpvs(sv, " during global destruction");
1498 sv_catpvs(sv, ".\n");
1504 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1506 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1507 argument list, respectively. These are used to generate a string message. If
1509 message does not end with a newline, then it will be extended with
1510 some indication of the current location in the code, as described for
1513 Normally, the resulting message is returned in a new mortal SV.
1514 During global destruction a single SV may be shared between uses of
1521 Perl_vmess(pTHX_ const char *pat, va_list *args)
1523 SV * const sv = mess_alloc();
1525 PERL_ARGS_ASSERT_VMESS;
1527 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1528 return mess_sv(sv, 1);
1532 Perl_write_to_stderr(pTHX_ SV* msv)
1537 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1539 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1540 && (io = GvIO(PL_stderrgv))
1541 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1542 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1543 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1545 PerlIO * const serr = Perl_error_log;
1547 do_print(msv, serr);
1548 (void)PerlIO_flush(serr);
1553 =head1 Warning and Dieing
1556 /* Common code used in dieing and warning */
1559 S_with_queued_errors(pTHX_ SV *ex)
1561 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1562 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1563 sv_catsv(PL_errors, ex);
1564 ex = sv_mortalcopy(PL_errors);
1565 SvCUR_set(PL_errors, 0);
1571 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1576 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1577 /* sv_2cv might call Perl_croak() or Perl_warner() */
1578 SV * const oldhook = *hook;
1586 cv = sv_2cv(oldhook, &stash, &gv, 0);
1588 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1598 exarg = newSVsv(ex);
1599 SvREADONLY_on(exarg);
1602 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1606 call_sv(MUTABLE_SV(cv), G_DISCARD);
1615 =for apidoc Am|OP *|die_sv|SV *baseex
1617 Behaves the same as L</croak_sv>, except for the return type.
1618 It should be used only where the C<OP *> return type is required.
1619 The function never actually returns.
1625 # pragma warning( push )
1626 # pragma warning( disable : 4646 ) /* warning C4646: function declared with
1627 __declspec(noreturn) has non-void return type */
1628 # pragma warning( disable : 4645 ) /* warning C4645: function declared with
1629 __declspec(noreturn) has a return statement */
1632 Perl_die_sv(pTHX_ SV *baseex)
1634 PERL_ARGS_ASSERT_DIE_SV;
1637 NORETURN_FUNCTION_END;
1640 # pragma warning( pop )
1644 =for apidoc Am|OP *|die|const char *pat|...
1646 Behaves the same as L</croak>, except for the return type.
1647 It should be used only where the C<OP *> return type is required.
1648 The function never actually returns.
1653 #if defined(PERL_IMPLICIT_CONTEXT)
1655 # pragma warning( push )
1656 # pragma warning( disable : 4646 ) /* warning C4646: function declared with
1657 __declspec(noreturn) has non-void return type */
1658 # pragma warning( disable : 4645 ) /* warning C4645: function declared with
1659 __declspec(noreturn) has a return statement */
1662 Perl_die_nocontext(const char* pat, ...)
1666 va_start(args, pat);
1668 NOT_REACHED; /* NOTREACHED */
1670 NORETURN_FUNCTION_END;
1673 # pragma warning( pop )
1675 #endif /* PERL_IMPLICIT_CONTEXT */
1678 # pragma warning( push )
1679 # pragma warning( disable : 4646 ) /* warning C4646: function declared with
1680 __declspec(noreturn) has non-void return type */
1681 # pragma warning( disable : 4645 ) /* warning C4645: function declared with
1682 __declspec(noreturn) has a return statement */
1685 Perl_die(pTHX_ const char* pat, ...)
1688 va_start(args, pat);
1690 NOT_REACHED; /* NOTREACHED */
1692 NORETURN_FUNCTION_END;
1695 # pragma warning( pop )
1699 =for apidoc Am|void|croak_sv|SV *baseex
1701 This is an XS interface to Perl's C<die> function.
1703 C<baseex> is the error message or object. If it is a reference, it
1704 will be used as-is. Otherwise it is used as a string, and if it does
1705 not end with a newline then it will be extended with some indication of
1706 the current location in the code, as described for L</mess_sv>.
1708 The error message or object will be used as an exception, by default
1709 returning control to the nearest enclosing C<eval>, but subject to
1710 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1711 function never returns normally.
1713 To die with a simple string message, the L</croak> function may be
1720 Perl_croak_sv(pTHX_ SV *baseex)
1722 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1723 PERL_ARGS_ASSERT_CROAK_SV;
1724 invoke_exception_hook(ex, FALSE);
1729 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1731 This is an XS interface to Perl's C<die> function.
1733 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1734 argument list. These are used to generate a string message. If the
1735 message does not end with a newline, then it will be extended with
1736 some indication of the current location in the code, as described for
1739 The error message will be used as an exception, by default
1740 returning control to the nearest enclosing C<eval>, but subject to
1741 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1742 function never returns normally.
1744 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1745 (C<$@>) will be used as an error message or object instead of building an
1746 error message from arguments. If you want to throw a non-string object,
1747 or build an error message in an SV yourself, it is preferable to use
1748 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1754 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1756 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1757 invoke_exception_hook(ex, FALSE);
1762 =for apidoc Am|void|croak|const char *pat|...
1764 This is an XS interface to Perl's C<die> function.
1766 Take a sprintf-style format pattern and argument list. These are used to
1767 generate a string message. If the message does not end with a newline,
1768 then it will be extended with some indication of the current location
1769 in the code, as described for L</mess_sv>.
1771 The error message will be used as an exception, by default
1772 returning control to the nearest enclosing C<eval>, but subject to
1773 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1774 function never returns normally.
1776 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1777 (C<$@>) will be used as an error message or object instead of building an
1778 error message from arguments. If you want to throw a non-string object,
1779 or build an error message in an SV yourself, it is preferable to use
1780 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1785 #if defined(PERL_IMPLICIT_CONTEXT)
1787 Perl_croak_nocontext(const char *pat, ...)
1791 va_start(args, pat);
1793 NOT_REACHED; /* NOTREACHED */
1796 #endif /* PERL_IMPLICIT_CONTEXT */
1799 Perl_croak(pTHX_ const char *pat, ...)
1802 va_start(args, pat);
1804 NOT_REACHED; /* NOTREACHED */
1809 =for apidoc Am|void|croak_no_modify
1811 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1812 terser object code than using C<Perl_croak>. Less code used on exception code
1813 paths reduces CPU cache pressure.
1819 Perl_croak_no_modify(void)
1821 Perl_croak_nocontext( "%s", PL_no_modify);
1824 /* does not return, used in util.c perlio.c and win32.c
1825 This is typically called when malloc returns NULL.
1828 Perl_croak_no_mem(void)
1832 int fd = PerlIO_fileno(Perl_error_log);
1834 SETERRNO(EBADF,RMS_IFI);
1836 /* Can't use PerlIO to write as it allocates memory */
1837 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
1842 /* does not return, used only in POPSTACK */
1844 Perl_croak_popstack(void)
1847 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1852 =for apidoc Am|void|warn_sv|SV *baseex
1854 This is an XS interface to Perl's C<warn> function.
1856 C<baseex> is the error message or object. If it is a reference, it
1857 will be used as-is. Otherwise it is used as a string, and if it does
1858 not end with a newline then it will be extended with some indication of
1859 the current location in the code, as described for L</mess_sv>.
1861 The error message or object will by default be written to standard error,
1862 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1864 To warn with a simple string message, the L</warn> function may be
1871 Perl_warn_sv(pTHX_ SV *baseex)
1873 SV *ex = mess_sv(baseex, 0);
1874 PERL_ARGS_ASSERT_WARN_SV;
1875 if (!invoke_exception_hook(ex, TRUE))
1876 write_to_stderr(ex);
1880 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1882 This is an XS interface to Perl's C<warn> function.
1884 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1885 argument list. These are used to generate a string message. If the
1886 message does not end with a newline, then it will be extended with
1887 some indication of the current location in the code, as described for
1890 The error message or object will by default be written to standard error,
1891 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1893 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1899 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1901 SV *ex = vmess(pat, args);
1902 PERL_ARGS_ASSERT_VWARN;
1903 if (!invoke_exception_hook(ex, TRUE))
1904 write_to_stderr(ex);
1908 =for apidoc Am|void|warn|const char *pat|...
1910 This is an XS interface to Perl's C<warn> function.
1912 Take a sprintf-style format pattern and argument list. These are used to
1913 generate a string message. If the message does not end with a newline,
1914 then it will be extended with some indication of the current location
1915 in the code, as described for L</mess_sv>.
1917 The error message or object will by default be written to standard error,
1918 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1920 Unlike with L</croak>, C<pat> is not permitted to be null.
1925 #if defined(PERL_IMPLICIT_CONTEXT)
1927 Perl_warn_nocontext(const char *pat, ...)
1931 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1932 va_start(args, pat);
1936 #endif /* PERL_IMPLICIT_CONTEXT */
1939 Perl_warn(pTHX_ const char *pat, ...)
1942 PERL_ARGS_ASSERT_WARN;
1943 va_start(args, pat);
1948 #if defined(PERL_IMPLICIT_CONTEXT)
1950 Perl_warner_nocontext(U32 err, const char *pat, ...)
1954 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1955 va_start(args, pat);
1956 vwarner(err, pat, &args);
1959 #endif /* PERL_IMPLICIT_CONTEXT */
1962 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1964 PERL_ARGS_ASSERT_CK_WARNER_D;
1966 if (Perl_ckwarn_d(aTHX_ err)) {
1968 va_start(args, pat);
1969 vwarner(err, pat, &args);
1975 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1977 PERL_ARGS_ASSERT_CK_WARNER;
1979 if (Perl_ckwarn(aTHX_ err)) {
1981 va_start(args, pat);
1982 vwarner(err, pat, &args);
1988 Perl_warner(pTHX_ U32 err, const char* pat,...)
1991 PERL_ARGS_ASSERT_WARNER;
1992 va_start(args, pat);
1993 vwarner(err, pat, &args);
1998 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
2001 PERL_ARGS_ASSERT_VWARNER;
2003 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2004 !(PL_in_eval & EVAL_KEEPERR)
2006 SV * const msv = vmess(pat, args);
2008 if (PL_parser && PL_parser->error_count) {
2012 invoke_exception_hook(msv, FALSE);
2017 Perl_vwarn(aTHX_ pat, args);
2021 /* implements the ckWARN? macros */
2024 Perl_ckwarn(pTHX_ U32 w)
2026 /* If lexical warnings have not been set, use $^W. */
2028 return PL_dowarn & G_WARN_ON;
2030 return ckwarn_common(w);
2033 /* implements the ckWARN?_d macro */
2036 Perl_ckwarn_d(pTHX_ U32 w)
2038 /* If lexical warnings have not been set then default classes warn. */
2042 return ckwarn_common(w);
2046 S_ckwarn_common(pTHX_ U32 w)
2048 if (PL_curcop->cop_warnings == pWARN_ALL)
2051 if (PL_curcop->cop_warnings == pWARN_NONE)
2054 /* Check the assumption that at least the first slot is non-zero. */
2055 assert(unpackWARN1(w));
2057 /* Check the assumption that it is valid to stop as soon as a zero slot is
2059 if (!unpackWARN2(w)) {
2060 assert(!unpackWARN3(w));
2061 assert(!unpackWARN4(w));
2062 } else if (!unpackWARN3(w)) {
2063 assert(!unpackWARN4(w));
2066 /* Right, dealt with all the special cases, which are implemented as non-
2067 pointers, so there is a pointer to a real warnings mask. */
2069 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2071 } while (w >>= WARNshift);
2076 /* Set buffer=NULL to get a new one. */
2078 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2080 const MEM_SIZE len_wanted =
2081 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2082 PERL_UNUSED_CONTEXT;
2083 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2086 (specialWARN(buffer) ?
2087 PerlMemShared_malloc(len_wanted) :
2088 PerlMemShared_realloc(buffer, len_wanted));
2090 Copy(bits, (buffer + 1), size, char);
2091 if (size < WARNsize)
2092 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2096 /* since we've already done strlen() for both nam and val
2097 * we can use that info to make things faster than
2098 * sprintf(s, "%s=%s", nam, val)
2100 #define my_setenv_format(s, nam, nlen, val, vlen) \
2101 Copy(nam, s, nlen, char); \
2103 Copy(val, s+(nlen+1), vlen, char); \
2104 *(s+(nlen+1+vlen)) = '\0'
2106 #ifdef USE_ENVIRON_ARRAY
2107 /* VMS' my_setenv() is in vms.c */
2108 #if !defined(WIN32) && !defined(NETWARE)
2110 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2114 amigaos4_obtain_environ(__FUNCTION__);
2117 /* only parent thread can modify process environment */
2118 if (PL_curinterp == aTHX)
2121 #ifndef PERL_USE_SAFE_PUTENV
2122 if (!PL_use_safe_putenv) {
2123 /* most putenv()s leak, so we manipulate environ directly */
2125 const I32 len = strlen(nam);
2128 /* where does it go? */
2129 for (i = 0; environ[i]; i++) {
2130 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2134 if (environ == PL_origenviron) { /* need we copy environment? */
2140 while (environ[max])
2142 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2143 for (j=0; j<max; j++) { /* copy environment */
2144 const int len = strlen(environ[j]);
2145 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2146 Copy(environ[j], tmpenv[j], len+1, char);
2149 environ = tmpenv; /* tell exec where it is now */
2152 safesysfree(environ[i]);
2153 while (environ[i]) {
2154 environ[i] = environ[i+1];
2163 if (!environ[i]) { /* does not exist yet */
2164 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2165 environ[i+1] = NULL; /* make sure it's null terminated */
2168 safesysfree(environ[i]);
2172 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2173 /* all that work just for this */
2174 my_setenv_format(environ[i], nam, nlen, val, vlen);
2177 /* This next branch should only be called #if defined(HAS_SETENV), but
2178 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
2179 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2181 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
2182 # if defined(HAS_UNSETENV)
2184 (void)unsetenv(nam);
2186 (void)setenv(nam, val, 1);
2188 # else /* ! HAS_UNSETENV */
2189 (void)setenv(nam, val, 1);
2190 # endif /* HAS_UNSETENV */
2192 # if defined(HAS_UNSETENV)
2194 if (environ) /* old glibc can crash with null environ */
2195 (void)unsetenv(nam);
2197 const int nlen = strlen(nam);
2198 const int vlen = strlen(val);
2199 char * const new_env =
2200 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2201 my_setenv_format(new_env, nam, nlen, val, vlen);
2202 (void)putenv(new_env);
2204 # else /* ! HAS_UNSETENV */
2206 const int nlen = strlen(nam);
2212 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2213 /* all that work just for this */
2214 my_setenv_format(new_env, nam, nlen, val, vlen);
2215 (void)putenv(new_env);
2216 # endif /* HAS_UNSETENV */
2217 # endif /* __CYGWIN__ */
2218 #ifndef PERL_USE_SAFE_PUTENV
2224 amigaos4_release_environ(__FUNCTION__);
2228 #else /* WIN32 || NETWARE */
2231 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2235 const int nlen = strlen(nam);
2242 Newx(envstr, nlen+vlen+2, char);
2243 my_setenv_format(envstr, nam, nlen, val, vlen);
2244 (void)PerlEnv_putenv(envstr);
2248 #endif /* WIN32 || NETWARE */
2252 #ifdef UNLINK_ALL_VERSIONS
2254 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2258 PERL_ARGS_ASSERT_UNLNK;
2260 while (PerlLIO_unlink(f) >= 0)
2262 return retries ? 0 : -1;
2266 /* this is a drop-in replacement for bcopy() */
2267 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2269 Perl_my_bcopy(const char *from, char *to, I32 len)
2271 char * const retval = to;
2273 PERL_ARGS_ASSERT_MY_BCOPY;
2277 if (from - to >= 0) {
2285 *(--to) = *(--from);
2291 /* this is a drop-in replacement for memset() */
2294 Perl_my_memset(char *loc, I32 ch, I32 len)
2296 char * const retval = loc;
2298 PERL_ARGS_ASSERT_MY_MEMSET;
2308 /* this is a drop-in replacement for bzero() */
2309 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2311 Perl_my_bzero(char *loc, I32 len)
2313 char * const retval = loc;
2315 PERL_ARGS_ASSERT_MY_BZERO;
2325 /* this is a drop-in replacement for memcmp() */
2326 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2328 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2330 const U8 *a = (const U8 *)s1;
2331 const U8 *b = (const U8 *)s2;
2334 PERL_ARGS_ASSERT_MY_MEMCMP;
2339 if ((tmp = *a++ - *b++))
2344 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2347 /* This vsprintf replacement should generally never get used, since
2348 vsprintf was available in both System V and BSD 2.11. (There may
2349 be some cross-compilation or embedded set-ups where it is needed,
2352 If you encounter a problem in this function, it's probably a symptom
2353 that Configure failed to detect your system's vprintf() function.
2354 See the section on "item vsprintf" in the INSTALL file.
2356 This version may compile on systems with BSD-ish <stdio.h>,
2357 but probably won't on others.
2360 #ifdef USE_CHAR_VSPRINTF
2365 vsprintf(char *dest, const char *pat, void *args)
2369 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2370 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2371 FILE_cnt(&fakebuf) = 32767;
2373 /* These probably won't compile -- If you really need
2374 this, you'll have to figure out some other method. */
2375 fakebuf._ptr = dest;
2376 fakebuf._cnt = 32767;
2381 fakebuf._flag = _IOWRT|_IOSTRG;
2382 _doprnt(pat, args, &fakebuf); /* what a kludge */
2383 #if defined(STDIO_PTR_LVALUE)
2384 *(FILE_ptr(&fakebuf)++) = '\0';
2386 /* PerlIO has probably #defined away fputc, but we want it here. */
2388 # undef fputc /* XXX Should really restore it later */
2390 (void)fputc('\0', &fakebuf);
2392 #ifdef USE_CHAR_VSPRINTF
2395 return 0; /* perl doesn't use return value */
2399 #endif /* HAS_VPRINTF */
2402 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2404 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2412 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2414 PERL_FLUSHALL_FOR_CHILD;
2415 This = (*mode == 'w');
2419 taint_proper("Insecure %s%s", "EXEC");
2421 if (PerlProc_pipe(p) < 0)
2423 /* Try for another pipe pair for error return */
2424 if (PerlProc_pipe(pp) >= 0)
2426 while ((pid = PerlProc_fork()) < 0) {
2427 if (errno != EAGAIN) {
2428 PerlLIO_close(p[This]);
2429 PerlLIO_close(p[that]);
2431 PerlLIO_close(pp[0]);
2432 PerlLIO_close(pp[1]);
2436 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2445 /* Close parent's end of error status pipe (if any) */
2447 PerlLIO_close(pp[0]);
2448 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2449 /* Close error pipe automatically if exec works */
2450 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2454 /* Now dup our end of _the_ pipe to right position */
2455 if (p[THIS] != (*mode == 'r')) {
2456 PerlLIO_dup2(p[THIS], *mode == 'r');
2457 PerlLIO_close(p[THIS]);
2458 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2459 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2462 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2463 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2464 /* No automatic close - do it by hand */
2471 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2477 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2483 do_execfree(); /* free any memory malloced by child on fork */
2485 PerlLIO_close(pp[1]);
2486 /* Keep the lower of the two fd numbers */
2487 if (p[that] < p[This]) {
2488 PerlLIO_dup2(p[This], p[that]);
2489 PerlLIO_close(p[This]);
2493 PerlLIO_close(p[that]); /* close child's end of pipe */
2495 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2496 SvUPGRADE(sv,SVt_IV);
2498 PL_forkprocess = pid;
2499 /* If we managed to get status pipe check for exec fail */
2500 if (did_pipes && pid > 0) {
2505 while (n < sizeof(int)) {
2506 n1 = PerlLIO_read(pp[0],
2507 (void*)(((char*)&errkid)+n),
2513 PerlLIO_close(pp[0]);
2515 if (n) { /* Error */
2517 PerlLIO_close(p[This]);
2518 if (n != sizeof(int))
2519 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2521 pid2 = wait4pid(pid, &status, 0);
2522 } while (pid2 == -1 && errno == EINTR);
2523 errno = errkid; /* Propagate errno from kid */
2528 PerlLIO_close(pp[0]);
2529 return PerlIO_fdopen(p[This], mode);
2531 # if defined(OS2) /* Same, without fork()ing and all extra overhead... */
2532 return my_syspopen4(aTHX_ NULL, mode, n, args);
2533 # elif defined(WIN32)
2534 return win32_popenlist(mode, n, args);
2536 Perl_croak(aTHX_ "List form of piped open not implemented");
2537 return (PerlIO *) NULL;
2542 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2543 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2545 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2551 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2555 PERL_ARGS_ASSERT_MY_POPEN;
2557 PERL_FLUSHALL_FOR_CHILD;
2560 return my_syspopen(aTHX_ cmd,mode);
2563 This = (*mode == 'w');
2565 if (doexec && TAINTING_get) {
2567 taint_proper("Insecure %s%s", "EXEC");
2569 if (PerlProc_pipe(p) < 0)
2571 if (doexec && PerlProc_pipe(pp) >= 0)
2573 while ((pid = PerlProc_fork()) < 0) {
2574 if (errno != EAGAIN) {
2575 PerlLIO_close(p[This]);
2576 PerlLIO_close(p[that]);
2578 PerlLIO_close(pp[0]);
2579 PerlLIO_close(pp[1]);
2582 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2585 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2595 PerlLIO_close(pp[0]);
2596 #if defined(HAS_FCNTL) && defined(F_SETFD)
2597 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2601 if (p[THIS] != (*mode == 'r')) {
2602 PerlLIO_dup2(p[THIS], *mode == 'r');
2603 PerlLIO_close(p[THIS]);
2604 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2605 PerlLIO_close(p[THAT]);
2608 PerlLIO_close(p[THAT]);
2611 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2618 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2623 /* may or may not use the shell */
2624 do_exec3(cmd, pp[1], did_pipes);
2627 #endif /* defined OS2 */
2629 #ifdef PERLIO_USING_CRLF
2630 /* Since we circumvent IO layers when we manipulate low-level
2631 filedescriptors directly, need to manually switch to the
2632 default, binary, low-level mode; see PerlIOBuf_open(). */
2633 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2636 #ifdef PERL_USES_PL_PIDSTATUS
2637 hv_clear(PL_pidstatus); /* we have no children */
2643 do_execfree(); /* free any memory malloced by child on vfork */
2645 PerlLIO_close(pp[1]);
2646 if (p[that] < p[This]) {
2647 PerlLIO_dup2(p[This], p[that]);
2648 PerlLIO_close(p[This]);
2652 PerlLIO_close(p[that]);
2654 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2655 SvUPGRADE(sv,SVt_IV);
2657 PL_forkprocess = pid;
2658 if (did_pipes && pid > 0) {
2663 while (n < sizeof(int)) {
2664 n1 = PerlLIO_read(pp[0],
2665 (void*)(((char*)&errkid)+n),
2671 PerlLIO_close(pp[0]);
2673 if (n) { /* Error */
2675 PerlLIO_close(p[This]);
2676 if (n != sizeof(int))
2677 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2679 pid2 = wait4pid(pid, &status, 0);
2680 } while (pid2 == -1 && errno == EINTR);
2681 errno = errkid; /* Propagate errno from kid */
2686 PerlLIO_close(pp[0]);
2687 return PerlIO_fdopen(p[This], mode);
2691 FILE *djgpp_popen();
2693 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2695 PERL_FLUSHALL_FOR_CHILD;
2696 /* Call system's popen() to get a FILE *, then import it.
2697 used 0 for 2nd parameter to PerlIO_importFILE;
2700 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2703 #if defined(__LIBCATAMOUNT__)
2705 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2712 #endif /* !DOSISH */
2714 /* this is called in parent before the fork() */
2716 Perl_atfork_lock(void)
2718 #if defined(USE_ITHREADS)
2720 /* locks must be held in locking order (if any) */
2722 MUTEX_LOCK(&PL_perlio_mutex);
2725 MUTEX_LOCK(&PL_malloc_mutex);
2731 /* this is called in both parent and child after the fork() */
2733 Perl_atfork_unlock(void)
2735 #if defined(USE_ITHREADS)
2737 /* locks must be released in same order as in atfork_lock() */
2739 MUTEX_UNLOCK(&PL_perlio_mutex);
2742 MUTEX_UNLOCK(&PL_malloc_mutex);
2751 #if defined(HAS_FORK)
2753 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2758 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2759 * handlers elsewhere in the code */
2763 #elif defined(__amigaos4__)
2764 return amigaos_fork();
2766 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2767 Perl_croak_nocontext("fork() not available");
2769 #endif /* HAS_FORK */
2774 dup2(int oldfd, int newfd)
2776 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2779 PerlLIO_close(newfd);
2780 return fcntl(oldfd, F_DUPFD, newfd);
2782 #define DUP2_MAX_FDS 256
2783 int fdtmp[DUP2_MAX_FDS];
2789 PerlLIO_close(newfd);
2790 /* good enough for low fd's... */
2791 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2792 if (fdx >= DUP2_MAX_FDS) {
2800 PerlLIO_close(fdtmp[--fdx]);
2807 #ifdef HAS_SIGACTION
2810 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2812 struct sigaction act, oact;
2816 /* only "parent" interpreter can diddle signals */
2817 if (PL_curinterp != aTHX)
2818 return (Sighandler_t) SIG_ERR;
2821 act.sa_handler = (void(*)(int))handler;
2822 sigemptyset(&act.sa_mask);
2825 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2826 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2828 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2829 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2830 act.sa_flags |= SA_NOCLDWAIT;
2832 if (sigaction(signo, &act, &oact) == -1)
2833 return (Sighandler_t) SIG_ERR;
2835 return (Sighandler_t) oact.sa_handler;
2839 Perl_rsignal_state(pTHX_ int signo)
2841 struct sigaction oact;
2842 PERL_UNUSED_CONTEXT;
2844 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2845 return (Sighandler_t) SIG_ERR;
2847 return (Sighandler_t) oact.sa_handler;
2851 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2856 struct sigaction act;
2858 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2861 /* only "parent" interpreter can diddle signals */
2862 if (PL_curinterp != aTHX)
2866 act.sa_handler = (void(*)(int))handler;
2867 sigemptyset(&act.sa_mask);
2870 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2871 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2873 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2874 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2875 act.sa_flags |= SA_NOCLDWAIT;
2877 return sigaction(signo, &act, save);
2881 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2886 PERL_UNUSED_CONTEXT;
2888 /* only "parent" interpreter can diddle signals */
2889 if (PL_curinterp != aTHX)
2893 return sigaction(signo, save, (struct sigaction *)NULL);
2896 #else /* !HAS_SIGACTION */
2899 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2901 #if defined(USE_ITHREADS) && !defined(WIN32)
2902 /* only "parent" interpreter can diddle signals */
2903 if (PL_curinterp != aTHX)
2904 return (Sighandler_t) SIG_ERR;
2907 return PerlProc_signal(signo, handler);
2918 Perl_rsignal_state(pTHX_ int signo)
2921 Sighandler_t oldsig;
2923 #if defined(USE_ITHREADS) && !defined(WIN32)
2924 /* only "parent" interpreter can diddle signals */
2925 if (PL_curinterp != aTHX)
2926 return (Sighandler_t) SIG_ERR;
2930 oldsig = PerlProc_signal(signo, sig_trap);
2931 PerlProc_signal(signo, oldsig);
2933 PerlProc_kill(PerlProc_getpid(), signo);
2938 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2940 #if defined(USE_ITHREADS) && !defined(WIN32)
2941 /* only "parent" interpreter can diddle signals */
2942 if (PL_curinterp != aTHX)
2945 *save = PerlProc_signal(signo, handler);
2946 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2950 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2952 #if defined(USE_ITHREADS) && !defined(WIN32)
2953 /* only "parent" interpreter can diddle signals */
2954 if (PL_curinterp != aTHX)
2957 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2960 #endif /* !HAS_SIGACTION */
2961 #endif /* !PERL_MICRO */
2963 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2964 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2966 Perl_my_pclose(pTHX_ PerlIO *ptr)
2974 const int fd = PerlIO_fileno(ptr);
2977 svp = av_fetch(PL_fdpid,fd,TRUE);
2978 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2982 #if defined(USE_PERLIO)
2983 /* Find out whether the refcount is low enough for us to wait for the
2984 child proc without blocking. */
2985 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2987 should_wait = pid > 0;
2991 if (pid == -1) { /* Opened by popen. */
2992 return my_syspclose(ptr);
2995 close_failed = (PerlIO_close(ptr) == EOF);
2997 if (should_wait) do {
2998 pid2 = wait4pid(pid, &status, 0);
2999 } while (pid2 == -1 && errno == EINTR);
3006 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3011 #if defined(__LIBCATAMOUNT__)
3013 Perl_my_pclose(pTHX_ PerlIO *ptr)
3018 #endif /* !DOSISH */
3020 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3022 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3025 PERL_ARGS_ASSERT_WAIT4PID;
3026 #ifdef PERL_USES_PL_PIDSTATUS
3028 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3029 waitpid() nor wait4() is available, or on OS/2, which
3030 doesn't appear to support waiting for a progress group
3031 member, so we can only treat a 0 pid as an unknown child.
3038 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3039 pid, rather than a string form. */
3040 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3041 if (svp && *svp != &PL_sv_undef) {
3042 *statusp = SvIVX(*svp);
3043 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3051 hv_iterinit(PL_pidstatus);
3052 if ((entry = hv_iternext(PL_pidstatus))) {
3053 SV * const sv = hv_iterval(PL_pidstatus,entry);
3055 const char * const spid = hv_iterkey(entry,&len);
3057 assert (len == sizeof(Pid_t));
3058 memcpy((char *)&pid, spid, len);
3059 *statusp = SvIVX(sv);
3060 /* The hash iterator is currently on this entry, so simply
3061 calling hv_delete would trigger the lazy delete, which on
3062 aggregate does more work, because next call to hv_iterinit()
3063 would spot the flag, and have to call the delete routine,
3064 while in the meantime any new entries can't re-use that
3066 hv_iterinit(PL_pidstatus);
3067 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3074 # ifdef HAS_WAITPID_RUNTIME
3075 if (!HAS_WAITPID_RUNTIME)
3078 result = PerlProc_waitpid(pid,statusp,flags);
3081 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3082 result = wait4(pid,statusp,flags,NULL);
3085 #ifdef PERL_USES_PL_PIDSTATUS
3086 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3091 Perl_croak(aTHX_ "Can't do waitpid with flags");
3093 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3094 pidgone(result,*statusp);
3100 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3103 if (result < 0 && errno == EINTR) {
3105 errno = EINTR; /* reset in case a signal handler changed $! */
3109 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3111 #ifdef PERL_USES_PL_PIDSTATUS
3113 S_pidgone(pTHX_ Pid_t pid, int status)
3117 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3118 SvUPGRADE(sv,SVt_IV);
3119 SvIV_set(sv, status);
3124 #if defined(OS2) || defined(__amigaos4__)
3125 # if defined(__amigaos4__) && defined(pclose)
3130 int /* Cannot prototype with I32
3132 my_syspclose(PerlIO *ptr)
3135 Perl_my_pclose(pTHX_ PerlIO *ptr)
3138 /* Needs work for PerlIO ! */
3139 FILE * const f = PerlIO_findFILE(ptr);
3140 const I32 result = pclose(f);
3141 PerlIO_releaseFILE(ptr,f);
3149 Perl_my_pclose(pTHX_ PerlIO *ptr)
3151 /* Needs work for PerlIO ! */
3152 FILE * const f = PerlIO_findFILE(ptr);
3153 I32 result = djgpp_pclose(f);
3154 result = (result << 8) & 0xff00;
3155 PerlIO_releaseFILE(ptr,f);
3160 #define PERL_REPEATCPY_LINEAR 4
3162 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3164 PERL_ARGS_ASSERT_REPEATCPY;
3169 croak_memory_wrap();
3172 memset(to, *from, count);
3175 IV items, linear, half;
3177 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3178 for (items = 0; items < linear; ++items) {
3179 const char *q = from;
3181 for (todo = len; todo > 0; todo--)
3186 while (items <= half) {
3187 IV size = items * len;
3188 memcpy(p, to, size);
3194 memcpy(p, to, (count - items) * len);
3200 Perl_same_dirent(pTHX_ const char *a, const char *b)
3202 char *fa = strrchr(a,'/');
3203 char *fb = strrchr(b,'/');
3206 SV * const tmpsv = sv_newmortal();
3208 PERL_ARGS_ASSERT_SAME_DIRENT;
3221 sv_setpvs(tmpsv, ".");
3223 sv_setpvn(tmpsv, a, fa - a);
3224 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3227 sv_setpvs(tmpsv, ".");
3229 sv_setpvn(tmpsv, b, fb - b);
3230 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3232 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3233 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3235 #endif /* !HAS_RENAME */
3238 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3239 const char *const *const search_ext, I32 flags)
3241 const char *xfound = NULL;
3242 char *xfailed = NULL;
3243 char tmpbuf[MAXPATHLEN];
3248 #if defined(DOSISH) && !defined(OS2)
3249 # define SEARCH_EXTS ".bat", ".cmd", NULL
3250 # define MAX_EXT_LEN 4
3253 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3254 # define MAX_EXT_LEN 4
3257 # define SEARCH_EXTS ".pl", ".com", NULL
3258 # define MAX_EXT_LEN 4
3260 /* additional extensions to try in each dir if scriptname not found */
3262 static const char *const exts[] = { SEARCH_EXTS };
3263 const char *const *const ext = search_ext ? search_ext : exts;
3264 int extidx = 0, i = 0;
3265 const char *curext = NULL;
3267 PERL_UNUSED_ARG(search_ext);
3268 # define MAX_EXT_LEN 0
3271 PERL_ARGS_ASSERT_FIND_SCRIPT;
3274 * If dosearch is true and if scriptname does not contain path
3275 * delimiters, search the PATH for scriptname.
3277 * If SEARCH_EXTS is also defined, will look for each
3278 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3279 * while searching the PATH.
3281 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3282 * proceeds as follows:
3283 * If DOSISH or VMSISH:
3284 * + look for ./scriptname{,.foo,.bar}
3285 * + search the PATH for scriptname{,.foo,.bar}
3288 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3289 * this will not look in '.' if it's not in the PATH)
3294 # ifdef ALWAYS_DEFTYPES
3295 len = strlen(scriptname);
3296 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3297 int idx = 0, deftypes = 1;
3300 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3303 int idx = 0, deftypes = 1;
3306 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3308 /* The first time through, just add SEARCH_EXTS to whatever we
3309 * already have, so we can check for default file types. */
3311 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3318 if ((strlen(tmpbuf) + strlen(scriptname)
3319 + MAX_EXT_LEN) >= sizeof tmpbuf)
3320 continue; /* don't search dir with too-long name */
3321 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3325 if (strEQ(scriptname, "-"))
3327 if (dosearch) { /* Look in '.' first. */
3328 const char *cur = scriptname;
3330 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3332 if (strEQ(ext[i++],curext)) {
3333 extidx = -1; /* already has an ext */
3338 DEBUG_p(PerlIO_printf(Perl_debug_log,
3339 "Looking for %s\n",cur));
3342 if (PerlLIO_stat(cur,&statbuf) >= 0
3343 && !S_ISDIR(statbuf.st_mode)) {
3352 if (cur == scriptname) {
3353 len = strlen(scriptname);
3354 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3356 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3359 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3360 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3365 if (dosearch && !strchr(scriptname, '/')
3367 && !strchr(scriptname, '\\')
3369 && (s = PerlEnv_getenv("PATH")))
3373 bufend = s + strlen(s);
3374 while (s < bufend) {
3378 && *s != ';'; len++, s++) {
3379 if (len < sizeof tmpbuf)
3382 if (len < sizeof tmpbuf)
3385 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3391 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3392 continue; /* don't search dir with too-long name */
3395 && tmpbuf[len - 1] != '/'
3396 && tmpbuf[len - 1] != '\\'
3399 tmpbuf[len++] = '/';
3400 if (len == 2 && tmpbuf[0] == '.')
3402 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3406 len = strlen(tmpbuf);
3407 if (extidx > 0) /* reset after previous loop */
3411 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3412 retval = PerlLIO_stat(tmpbuf,&statbuf);
3413 if (S_ISDIR(statbuf.st_mode)) {
3417 } while ( retval < 0 /* not there */
3418 && extidx>=0 && ext[extidx] /* try an extension? */
3419 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3424 if (S_ISREG(statbuf.st_mode)
3425 && cando(S_IRUSR,TRUE,&statbuf)
3426 #if !defined(DOSISH)
3427 && cando(S_IXUSR,TRUE,&statbuf)
3431 xfound = tmpbuf; /* bingo! */
3435 xfailed = savepv(tmpbuf);
3440 if (!xfound && !seen_dot && !xfailed &&
3441 (PerlLIO_stat(scriptname,&statbuf) < 0
3442 || S_ISDIR(statbuf.st_mode)))
3444 seen_dot = 1; /* Disable message. */
3449 if (flags & 1) { /* do or die? */
3450 /* diag_listed_as: Can't execute %s */
3451 Perl_croak(aTHX_ "Can't %s %s%s%s",
3452 (xfailed ? "execute" : "find"),
3453 (xfailed ? xfailed : scriptname),
3454 (xfailed ? "" : " on PATH"),
3455 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3460 scriptname = xfound;
3462 return (scriptname ? savepv(scriptname) : NULL);
3465 #ifndef PERL_GET_CONTEXT_DEFINED
3468 Perl_get_context(void)
3470 #if defined(USE_ITHREADS)
3472 # ifdef OLD_PTHREADS_API
3474 int error = pthread_getspecific(PL_thr_key, &t)
3476 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3479 # ifdef I_MACH_CTHREADS
3480 return (void*)cthread_data(cthread_self());
3482 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3491 Perl_set_context(void *t)
3493 #if defined(USE_ITHREADS)
3496 PERL_ARGS_ASSERT_SET_CONTEXT;
3497 #if defined(USE_ITHREADS)
3498 # ifdef I_MACH_CTHREADS
3499 cthread_set_data(cthread_self(), t);
3502 const int error = pthread_setspecific(PL_thr_key, t);
3504 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3512 #endif /* !PERL_GET_CONTEXT_DEFINED */
3514 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3518 PERL_UNUSED_CONTEXT;
3524 Perl_get_op_names(pTHX)
3526 PERL_UNUSED_CONTEXT;
3527 return (char **)PL_op_name;
3531 Perl_get_op_descs(pTHX)
3533 PERL_UNUSED_CONTEXT;
3534 return (char **)PL_op_desc;
3538 Perl_get_no_modify(pTHX)
3540 PERL_UNUSED_CONTEXT;
3541 return PL_no_modify;
3545 Perl_get_opargs(pTHX)
3547 PERL_UNUSED_CONTEXT;
3548 return (U32 *)PL_opargs;
3552 Perl_get_ppaddr(pTHX)
3555 PERL_UNUSED_CONTEXT;
3556 return (PPADDR_t*)PL_ppaddr;
3559 #ifndef HAS_GETENV_LEN
3561 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3563 char * const env_trans = PerlEnv_getenv(env_elem);
3564 PERL_UNUSED_CONTEXT;
3565 PERL_ARGS_ASSERT_GETENV_LEN;
3567 *len = strlen(env_trans);
3574 Perl_get_vtbl(pTHX_ int vtbl_id)
3576 PERL_UNUSED_CONTEXT;
3578 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3579 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3583 Perl_my_fflush_all(pTHX)
3585 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3586 return PerlIO_flush(NULL);
3588 # if defined(HAS__FWALK)
3589 extern int fflush(FILE *);
3590 /* undocumented, unprototyped, but very useful BSDism */
3591 extern void _fwalk(int (*)(FILE *));
3595 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3597 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3598 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3600 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3601 open_max = sysconf(_SC_OPEN_MAX);
3604 open_max = FOPEN_MAX;
3607 open_max = OPEN_MAX;
3618 for (i = 0; i < open_max; i++)
3619 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3620 STDIO_STREAM_ARRAY[i]._file < open_max &&
3621 STDIO_STREAM_ARRAY[i]._flag)
3622 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3626 SETERRNO(EBADF,RMS_IFI);
3633 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3635 if (ckWARN(WARN_IO)) {
3637 = gv && (isGV_with_GP(gv))
3640 const char * const direction = have == '>' ? "out" : "in";
3642 if (name && HEK_LEN(name))
3643 Perl_warner(aTHX_ packWARN(WARN_IO),
3644 "Filehandle %"HEKf" opened only for %sput",
3645 HEKfARG(name), direction);
3647 Perl_warner(aTHX_ packWARN(WARN_IO),
3648 "Filehandle opened only for %sput", direction);
3653 Perl_report_evil_fh(pTHX_ const GV *gv)
3655 const IO *io = gv ? GvIO(gv) : NULL;
3656 const PERL_BITFIELD16 op = PL_op->op_type;
3660 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3662 warn_type = WARN_CLOSED;
3666 warn_type = WARN_UNOPENED;
3669 if (ckWARN(warn_type)) {
3671 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3672 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3673 const char * const pars =
3674 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3675 const char * const func =
3677 (op == OP_READLINE || op == OP_RCATLINE
3678 ? "readline" : /* "<HANDLE>" not nice */
3679 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3681 const char * const type =
3683 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3684 ? "socket" : "filehandle");
3685 const bool have_name = name && SvCUR(name);
3686 Perl_warner(aTHX_ packWARN(warn_type),
3687 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3688 have_name ? " " : "",
3689 SVfARG(have_name ? name : &PL_sv_no));
3690 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3692 aTHX_ packWARN(warn_type),
3693 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3694 func, pars, have_name ? " " : "",
3695 SVfARG(have_name ? name : &PL_sv_no)
3700 /* To workaround core dumps from the uninitialised tm_zone we get the
3701 * system to give us a reasonable struct to copy. This fix means that
3702 * strftime uses the tm_zone and tm_gmtoff values returned by
3703 * localtime(time()). That should give the desired result most of the
3704 * time. But probably not always!
3706 * This does not address tzname aspects of NETaa14816.
3711 # ifndef STRUCT_TM_HASZONE
3712 # define STRUCT_TM_HASZONE
3716 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3717 # ifndef HAS_TM_TM_ZONE
3718 # define HAS_TM_TM_ZONE
3723 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3725 #ifdef HAS_TM_TM_ZONE
3727 const struct tm* my_tm;
3728 PERL_UNUSED_CONTEXT;
3729 PERL_ARGS_ASSERT_INIT_TM;
3731 my_tm = localtime(&now);
3733 Copy(my_tm, ptm, 1, struct tm);
3735 PERL_UNUSED_CONTEXT;
3736 PERL_ARGS_ASSERT_INIT_TM;
3737 PERL_UNUSED_ARG(ptm);
3742 * mini_mktime - normalise struct tm values without the localtime()
3743 * semantics (and overhead) of mktime().
3746 Perl_mini_mktime(struct tm *ptm)
3750 int month, mday, year, jday;
3751 int odd_cent, odd_year;
3753 PERL_ARGS_ASSERT_MINI_MKTIME;
3755 #define DAYS_PER_YEAR 365
3756 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3757 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3758 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3759 #define SECS_PER_HOUR (60*60)
3760 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3761 /* parentheses deliberately absent on these two, otherwise they don't work */
3762 #define MONTH_TO_DAYS 153/5
3763 #define DAYS_TO_MONTH 5/153
3764 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3765 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3766 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3767 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3770 * Year/day algorithm notes:
3772 * With a suitable offset for numeric value of the month, one can find
3773 * an offset into the year by considering months to have 30.6 (153/5) days,
3774 * using integer arithmetic (i.e., with truncation). To avoid too much
3775 * messing about with leap days, we consider January and February to be
3776 * the 13th and 14th month of the previous year. After that transformation,
3777 * we need the month index we use to be high by 1 from 'normal human' usage,
3778 * so the month index values we use run from 4 through 15.
3780 * Given that, and the rules for the Gregorian calendar (leap years are those
3781 * divisible by 4 unless also divisible by 100, when they must be divisible
3782 * by 400 instead), we can simply calculate the number of days since some
3783 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3784 * the days we derive from our month index, and adding in the day of the
3785 * month. The value used here is not adjusted for the actual origin which
3786 * it normally would use (1 January A.D. 1), since we're not exposing it.
3787 * We're only building the value so we can turn around and get the
3788 * normalised values for the year, month, day-of-month, and day-of-year.
3790 * For going backward, we need to bias the value we're using so that we find
3791 * the right year value. (Basically, we don't want the contribution of
3792 * March 1st to the number to apply while deriving the year). Having done
3793 * that, we 'count up' the contribution to the year number by accounting for
3794 * full quadracenturies (400-year periods) with their extra leap days, plus
3795 * the contribution from full centuries (to avoid counting in the lost leap
3796 * days), plus the contribution from full quad-years (to count in the normal
3797 * leap days), plus the leftover contribution from any non-leap years.
3798 * At this point, if we were working with an actual leap day, we'll have 0
3799 * days left over. This is also true for March 1st, however. So, we have
3800 * to special-case that result, and (earlier) keep track of the 'odd'
3801 * century and year contributions. If we got 4 extra centuries in a qcent,
3802 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3803 * Otherwise, we add back in the earlier bias we removed (the 123 from
3804 * figuring in March 1st), find the month index (integer division by 30.6),
3805 * and the remainder is the day-of-month. We then have to convert back to
3806 * 'real' months (including fixing January and February from being 14/15 in
3807 * the previous year to being in the proper year). After that, to get
3808 * tm_yday, we work with the normalised year and get a new yearday value for
3809 * January 1st, which we subtract from the yearday value we had earlier,
3810 * representing the date we've re-built. This is done from January 1
3811 * because tm_yday is 0-origin.
3813 * Since POSIX time routines are only guaranteed to work for times since the
3814 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3815 * applies Gregorian calendar rules even to dates before the 16th century
3816 * doesn't bother me. Besides, you'd need cultural context for a given
3817 * date to know whether it was Julian or Gregorian calendar, and that's
3818 * outside the scope for this routine. Since we convert back based on the
3819 * same rules we used to build the yearday, you'll only get strange results
3820 * for input which needed normalising, or for the 'odd' century years which
3821 * were leap years in the Julian calendar but not in the Gregorian one.
3822 * I can live with that.
3824 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3825 * that's still outside the scope for POSIX time manipulation, so I don't
3829 year = 1900 + ptm->tm_year;
3830 month = ptm->tm_mon;
3831 mday = ptm->tm_mday;
3837 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3838 yearday += month*MONTH_TO_DAYS + mday + jday;
3840 * Note that we don't know when leap-seconds were or will be,
3841 * so we have to trust the user if we get something which looks
3842 * like a sensible leap-second. Wild values for seconds will
3843 * be rationalised, however.
3845 if ((unsigned) ptm->tm_sec <= 60) {
3852 secs += 60 * ptm->tm_min;
3853 secs += SECS_PER_HOUR * ptm->tm_hour;
3855 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3856 /* got negative remainder, but need positive time */
3857 /* back off an extra day to compensate */
3858 yearday += (secs/SECS_PER_DAY)-1;
3859 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3862 yearday += (secs/SECS_PER_DAY);
3863 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3866 else if (secs >= SECS_PER_DAY) {
3867 yearday += (secs/SECS_PER_DAY);
3868 secs %= SECS_PER_DAY;
3870 ptm->tm_hour = secs/SECS_PER_HOUR;
3871 secs %= SECS_PER_HOUR;
3872 ptm->tm_min = secs/60;
3874 ptm->tm_sec += secs;
3875 /* done with time of day effects */
3877 * The algorithm for yearday has (so far) left it high by 428.
3878 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3879 * bias it by 123 while trying to figure out what year it
3880 * really represents. Even with this tweak, the reverse
3881 * translation fails for years before A.D. 0001.
3882 * It would still fail for Feb 29, but we catch that one below.
3884 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3885 yearday -= YEAR_ADJUST;
3886 year = (yearday / DAYS_PER_QCENT) * 400;
3887 yearday %= DAYS_PER_QCENT;
3888 odd_cent = yearday / DAYS_PER_CENT;
3889 year += odd_cent * 100;
3890 yearday %= DAYS_PER_CENT;
3891 year += (yearday / DAYS_PER_QYEAR) * 4;
3892 yearday %= DAYS_PER_QYEAR;
3893 odd_year = yearday / DAYS_PER_YEAR;
3895 yearday %= DAYS_PER_YEAR;
3896 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3901 yearday += YEAR_ADJUST; /* recover March 1st crock */
3902 month = yearday*DAYS_TO_MONTH;
3903 yearday -= month*MONTH_TO_DAYS;
3904 /* recover other leap-year adjustment */
3913 ptm->tm_year = year - 1900;
3915 ptm->tm_mday = yearday;
3916 ptm->tm_mon = month;
3920 ptm->tm_mon = month - 1;
3922 /* re-build yearday based on Jan 1 to get tm_yday */
3924 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3925 yearday += 14*MONTH_TO_DAYS + 1;
3926 ptm->tm_yday = jday - yearday;
3927 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3931 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3935 /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
3942 PERL_ARGS_ASSERT_MY_STRFTIME;
3944 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3947 mytm.tm_hour = hour;
3948 mytm.tm_mday = mday;
3950 mytm.tm_year = year;
3951 mytm.tm_wday = wday;
3952 mytm.tm_yday = yday;
3953 mytm.tm_isdst = isdst;
3955 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3956 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3961 #ifdef HAS_TM_TM_GMTOFF
3962 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3964 #ifdef HAS_TM_TM_ZONE
3965 mytm.tm_zone = mytm2.tm_zone;
3970 Newx(buf, buflen, char);
3972 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3973 len = strftime(buf, buflen, fmt, &mytm);
3977 ** The following is needed to handle to the situation where
3978 ** tmpbuf overflows. Basically we want to allocate a buffer
3979 ** and try repeatedly. The reason why it is so complicated
3980 ** is that getting a return value of 0 from strftime can indicate
3981 ** one of the following:
3982 ** 1. buffer overflowed,
3983 ** 2. illegal conversion specifier, or
3984 ** 3. the format string specifies nothing to be returned(not
3985 ** an error). This could be because format is an empty string
3986 ** or it specifies %p that yields an empty string in some locale.
3987 ** If there is a better way to make it portable, go ahead by
3990 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3993 /* Possibly buf overflowed - try again with a bigger buf */
3994 const int fmtlen = strlen(fmt);
3995 int bufsize = fmtlen + buflen;
3997 Renew(buf, bufsize, char);
4000 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4001 buflen = strftime(buf, bufsize, fmt, &mytm);
4004 if (buflen > 0 && buflen < bufsize)
4006 /* heuristic to prevent out-of-memory errors */
4007 if (bufsize > 100*fmtlen) {
4013 Renew(buf, bufsize, char);
4018 Perl_croak(aTHX_ "panic: no strftime");
4024 #define SV_CWD_RETURN_UNDEF \
4025 sv_setsv(sv, &PL_sv_undef); \
4028 #define SV_CWD_ISDOT(dp) \
4029 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4030 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4033 =head1 Miscellaneous Functions
4035 =for apidoc getcwd_sv
4037 Fill C<sv> with current working directory
4042 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4043 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4044 * getcwd(3) if available
4045 * Comments from the original:
4046 * This is a faster version of getcwd. It's also more dangerous
4047 * because you might chdir out of a directory that you can't chdir
4051 Perl_getcwd_sv(pTHX_ SV *sv)
4056 PERL_ARGS_ASSERT_GETCWD_SV;
4060 char buf[MAXPATHLEN];
4062 /* Some getcwd()s automatically allocate a buffer of the given
4063 * size from the heap if they are given a NULL buffer pointer.
4064 * The problem is that this behaviour is not portable. */
4065 if (getcwd(buf, sizeof(buf) - 1)) {
4070 sv_setsv(sv, &PL_sv_undef);
4078 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4082 SvUPGRADE(sv, SVt_PV);
4084 if (PerlLIO_lstat(".", &statbuf) < 0) {
4085 SV_CWD_RETURN_UNDEF;
4088 orig_cdev = statbuf.st_dev;
4089 orig_cino = statbuf.st_ino;
4099 if (PerlDir_chdir("..") < 0) {
4100 SV_CWD_RETURN_UNDEF;
4102 if (PerlLIO_stat(".", &statbuf) < 0) {
4103 SV_CWD_RETURN_UNDEF;
4106 cdev = statbuf.st_dev;
4107 cino = statbuf.st_ino;
4109 if (odev == cdev && oino == cino) {
4112 if (!(dir = PerlDir_open("."))) {
4113 SV_CWD_RETURN_UNDEF;
4116 while ((dp = PerlDir_read(dir)) != NULL) {
4118 namelen = dp->d_namlen;
4120 namelen = strlen(dp->d_name);
4123 if (SV_CWD_ISDOT(dp)) {
4127 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4128 SV_CWD_RETURN_UNDEF;
4131 tdev = statbuf.st_dev;
4132 tino = statbuf.st_ino;
4133 if (tino == oino && tdev == odev) {
4139 SV_CWD_RETURN_UNDEF;
4142 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4143 SV_CWD_RETURN_UNDEF;
4146 SvGROW(sv, pathlen + namelen + 1);
4150 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4153 /* prepend current directory to the front */
4155 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4156 pathlen += (namelen + 1);
4158 #ifdef VOID_CLOSEDIR
4161 if (PerlDir_close(dir) < 0) {
4162 SV_CWD_RETURN_UNDEF;
4168 SvCUR_set(sv, pathlen);
4172 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4173 SV_CWD_RETURN_UNDEF;
4176 if (PerlLIO_stat(".", &statbuf) < 0) {
4177 SV_CWD_RETURN_UNDEF;
4180 cdev = statbuf.st_dev;
4181 cino = statbuf.st_ino;
4183 if (cdev != orig_cdev || cino != orig_cino) {
4184 Perl_croak(aTHX_ "Unstable directory path, "
4185 "current directory changed unexpectedly");
4198 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4199 # define EMULATE_SOCKETPAIR_UDP
4202 #ifdef EMULATE_SOCKETPAIR_UDP
4204 S_socketpair_udp (int fd[2]) {
4206 /* Fake a datagram socketpair using UDP to localhost. */
4207 int sockets[2] = {-1, -1};
4208 struct sockaddr_in addresses[2];
4210 Sock_size_t size = sizeof(struct sockaddr_in);
4211 unsigned short port;
4214 memset(&addresses, 0, sizeof(addresses));
4217 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4218 if (sockets[i] == -1)
4219 goto tidy_up_and_fail;
4221 addresses[i].sin_family = AF_INET;
4222 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4223 addresses[i].sin_port = 0; /* kernel choses port. */
4224 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4225 sizeof(struct sockaddr_in)) == -1)
4226 goto tidy_up_and_fail;
4229 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4230 for each connect the other socket to it. */
4233 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4235 goto tidy_up_and_fail;
4236 if (size != sizeof(struct sockaddr_in))
4237 goto abort_tidy_up_and_fail;
4238 /* !1 is 0, !0 is 1 */
4239 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4240 sizeof(struct sockaddr_in)) == -1)
4241 goto tidy_up_and_fail;
4244 /* Now we have 2 sockets connected to each other. I don't trust some other
4245 process not to have already sent a packet to us (by random) so send
4246 a packet from each to the other. */
4249 /* I'm going to send my own port number. As a short.
4250 (Who knows if someone somewhere has sin_port as a bitfield and needs
4251 this routine. (I'm assuming crays have socketpair)) */
4252 port = addresses[i].sin_port;
4253 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4254 if (got != sizeof(port)) {
4256 goto tidy_up_and_fail;
4257 goto abort_tidy_up_and_fail;
4261 /* Packets sent. I don't trust them to have arrived though.
4262 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4263 connect to localhost will use a second kernel thread. In 2.6 the
4264 first thread running the connect() returns before the second completes,
4265 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4266 returns 0. Poor programs have tripped up. One poor program's authors'
4267 had a 50-1 reverse stock split. Not sure how connected these were.)
4268 So I don't trust someone not to have an unpredictable UDP stack.
4272 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4273 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4277 FD_SET((unsigned int)sockets[0], &rset);
4278 FD_SET((unsigned int)sockets[1], &rset);
4280 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4281 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4282 || !FD_ISSET(sockets[1], &rset)) {
4283 /* I hope this is portable and appropriate. */
4285 goto tidy_up_and_fail;
4286 goto abort_tidy_up_and_fail;
4290 /* And the paranoia department even now doesn't trust it to have arrive
4291 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4293 struct sockaddr_in readfrom;
4294 unsigned short buffer[2];
4299 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4300 sizeof(buffer), MSG_DONTWAIT,
4301 (struct sockaddr *) &readfrom, &size);
4303 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4305 (struct sockaddr *) &readfrom, &size);
4309 goto tidy_up_and_fail;
4310 if (got != sizeof(port)
4311 || size != sizeof(struct sockaddr_in)
4312 /* Check other socket sent us its port. */
4313 || buffer[0] != (unsigned short) addresses[!i].sin_port
4314 /* Check kernel says we got the datagram from that socket */
4315 || readfrom.sin_family != addresses[!i].sin_family
4316 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4317 || readfrom.sin_port != addresses[!i].sin_port)
4318 goto abort_tidy_up_and_fail;
4321 /* My caller (my_socketpair) has validated that this is non-NULL */
4324 /* I hereby declare this connection open. May God bless all who cross
4328 abort_tidy_up_and_fail:
4329 errno = ECONNABORTED;
4333 if (sockets[0] != -1)
4334 PerlLIO_close(sockets[0]);
4335 if (sockets[1] != -1)
4336 PerlLIO_close(sockets[1]);
4341 #endif /* EMULATE_SOCKETPAIR_UDP */
4343 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4345 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4346 /* Stevens says that family must be AF_LOCAL, protocol 0.
4347 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4352 struct sockaddr_in listen_addr;
4353 struct sockaddr_in connect_addr;
4358 || family != AF_UNIX
4361 errno = EAFNOSUPPORT;
4369 #ifdef EMULATE_SOCKETPAIR_UDP
4370 if (type == SOCK_DGRAM)
4371 return S_socketpair_udp(fd);
4374 aTHXa(PERL_GET_THX);
4375 listener = PerlSock_socket(AF_INET, type, 0);
4378 memset(&listen_addr, 0, sizeof(listen_addr));
4379 listen_addr.sin_family = AF_INET;
4380 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4381 listen_addr.sin_port = 0; /* kernel choses port. */
4382 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4383 sizeof(listen_addr)) == -1)
4384 goto tidy_up_and_fail;
4385 if (PerlSock_listen(listener, 1) == -1)
4386 goto tidy_up_and_fail;
4388 connector = PerlSock_socket(AF_INET, type, 0);
4389 if (connector == -1)
4390 goto tidy_up_and_fail;
4391 /* We want to find out the port number to connect to. */
4392 size = sizeof(connect_addr);
4393 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4395 goto tidy_up_and_fail;
4396 if (size != sizeof(connect_addr))
4397 goto abort_tidy_up_and_fail;
4398 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4399 sizeof(connect_addr)) == -1)
4400 goto tidy_up_and_fail;
4402 size = sizeof(listen_addr);
4403 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4406 goto tidy_up_and_fail;
4407 if (size != sizeof(listen_addr))
4408 goto abort_tidy_up_and_fail;
4409 PerlLIO_close(listener);
4410 /* Now check we are talking to ourself by matching port and host on the
4412 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4414 goto tidy_up_and_fail;
4415 if (size != sizeof(connect_addr)
4416 || listen_addr.sin_family != connect_addr.sin_family
4417 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4418 || listen_addr.sin_port != connect_addr.sin_port) {
4419 goto abort_tidy_up_and_fail;
4425 abort_tidy_up_and_fail:
4427 errno = ECONNABORTED; /* This would be the standard thing to do. */
4429 # ifdef ECONNREFUSED
4430 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4432 errno = ETIMEDOUT; /* Desperation time. */
4439 PerlLIO_close(listener);
4440 if (connector != -1)
4441 PerlLIO_close(connector);
4443 PerlLIO_close(acceptor);
4449 /* In any case have a stub so that there's code corresponding
4450 * to the my_socketpair in embed.fnc. */
4452 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4453 #ifdef HAS_SOCKETPAIR
4454 return socketpair(family, type, protocol, fd);
4463 =for apidoc sv_nosharing
4465 Dummy routine which "shares" an SV when there is no sharing module present.
4466 Or "locks" it. Or "unlocks" it. In other
4467 words, ignores its single SV argument.
4468 Exists to avoid test for a C<NULL> function pointer and because it could
4469 potentially warn under some level of strict-ness.
4475 Perl_sv_nosharing(pTHX_ SV *sv)
4477 PERL_UNUSED_CONTEXT;
4478 PERL_UNUSED_ARG(sv);
4483 =for apidoc sv_destroyable
4485 Dummy routine which reports that object can be destroyed when there is no
4486 sharing module present. It ignores its single SV argument, and returns
4487 'true'. Exists to avoid test for a C<NULL> function pointer and because it
4488 could potentially warn under some level of strict-ness.
4494 Perl_sv_destroyable(pTHX_ SV *sv)
4496 PERL_UNUSED_CONTEXT;
4497 PERL_UNUSED_ARG(sv);
4502 Perl_parse_unicode_opts(pTHX_ const char **popt)
4504 const char *p = *popt;
4507 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4513 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4516 if (p && *p && *p != '\n' && *p != '\r') {
4518 goto the_end_of_the_opts_parser;
4520 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4527 case PERL_UNICODE_STDIN:
4528 opt |= PERL_UNICODE_STDIN_FLAG; break;
4529 case PERL_UNICODE_STDOUT:
4530 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4531 case PERL_UNICODE_STDERR:
4532 opt |= PERL_UNICODE_STDERR_FLAG; break;
4533 case PERL_UNICODE_STD:
4534 opt |= PERL_UNICODE_STD_FLAG; break;
4535 case PERL_UNICODE_IN:
4536 opt |= PERL_UNICODE_IN_FLAG; break;
4537 case PERL_UNICODE_OUT:
4538 opt |= PERL_UNICODE_OUT_FLAG; break;
4539 case PERL_UNICODE_INOUT:
4540 opt |= PERL_UNICODE_INOUT_FLAG; break;
4541 case PERL_UNICODE_LOCALE:
4542 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4543 case PERL_UNICODE_ARGV:
4544 opt |= PERL_UNICODE_ARGV_FLAG; break;
4545 case PERL_UNICODE_UTF8CACHEASSERT:
4546 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4548 if (*p != '\n' && *p != '\r') {
4549 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4552 "Unknown Unicode option letter '%c'", *p);
4559 opt = PERL_UNICODE_DEFAULT_FLAGS;
4561 the_end_of_the_opts_parser:
4563 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4564 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4565 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4573 # include <starlet.h>
4580 * This is really just a quick hack which grabs various garbage
4581 * values. It really should be a real hash algorithm which
4582 * spreads the effect of every input bit onto every output bit,
4583 * if someone who knows about such things would bother to write it.
4584 * Might be a good idea to add that function to CORE as well.
4585 * No numbers below come from careful analysis or anything here,
4586 * except they are primes and SEED_C1 > 1E6 to get a full-width
4587 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4588 * probably be bigger too.
4591 # define SEED_C1 1000003
4592 #define SEED_C4 73819
4594 # define SEED_C1 25747
4595 #define SEED_C4 20639
4599 #define SEED_C5 26107
4601 #ifndef PERL_NO_DEV_RANDOM
4605 #ifdef HAS_GETTIMEOFDAY
4606 struct timeval when;
4611 /* This test is an escape hatch, this symbol isn't set by Configure. */
4612 #ifndef PERL_NO_DEV_RANDOM
4613 #ifndef PERL_RANDOM_DEVICE
4614 /* /dev/random isn't used by default because reads from it will block
4615 * if there isn't enough entropy available. You can compile with
4616 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4617 * is enough real entropy to fill the seed. */
4618 # ifdef __amigaos4__
4619 # define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4621 # define PERL_RANDOM_DEVICE "/dev/urandom"
4624 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4626 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4634 #ifdef HAS_GETTIMEOFDAY
4635 PerlProc_gettimeofday(&when,NULL);
4636 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4639 u = (U32)SEED_C1 * when;
4641 u += SEED_C3 * (U32)PerlProc_getpid();
4642 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4643 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4644 u += SEED_C5 * (U32)PTR2UV(&when);
4650 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4655 PERL_ARGS_ASSERT_GET_HASH_SEED;
4657 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4660 #ifndef USE_HASH_SEED_EXPLICIT
4662 /* ignore leading spaces */
4663 while (isSPACE(*env_pv))
4665 #ifdef USE_PERL_PERTURB_KEYS
4666 /* if they set it to "0" we disable key traversal randomization completely */
4667 if (strEQ(env_pv,"0")) {
4668 PL_hash_rand_bits_enabled= 0;
4670 /* otherwise switch to deterministic mode */
4671 PL_hash_rand_bits_enabled= 2;
4674 /* ignore a leading 0x... if it is there */
4675 if (env_pv[0] == '0' && env_pv[1] == 'x')
4678 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4679 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4680 if ( isXDIGIT(*env_pv)) {
4681 seed_buffer[i] |= READ_XDIGIT(env_pv);
4684 while (isSPACE(*env_pv))
4687 if (*env_pv && !isXDIGIT(*env_pv)) {
4688 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4690 /* should we check for unparsed crap? */
4691 /* should we warn about unused hex? */
4692 /* should we warn about insufficient hex? */
4697 (void)seedDrand01((Rand_seed_t)seed());
4699 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4700 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4703 #ifdef USE_PERL_PERTURB_KEYS
4704 { /* initialize PL_hash_rand_bits from the hash seed.
4705 * This value is highly volatile, it is updated every
4706 * hash insert, and is used as part of hash bucket chain
4707 * randomization and hash iterator randomization. */
4708 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4709 for( i = 0; i < sizeof(UV) ; i++ ) {
4710 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4711 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4714 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4716 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4717 PL_hash_rand_bits_enabled= 0;
4718 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4719 PL_hash_rand_bits_enabled= 1;
4720 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4721 PL_hash_rand_bits_enabled= 2;
4723 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4729 #ifdef PERL_GLOBAL_STRUCT
4731 #define PERL_GLOBAL_STRUCT_INIT
4732 #include "opcode.h" /* the ppaddr and check */
4735 Perl_init_global_struct(pTHX)
4737 struct perl_vars *plvarsp = NULL;
4738 # ifdef PERL_GLOBAL_STRUCT
4739 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4740 const IV ncheck = C_ARRAY_LENGTH(Gcheck);
4741 PERL_UNUSED_CONTEXT;
4742 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4743 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4744 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4748 plvarsp = PL_VarsPtr;
4749 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4754 # define PERLVAR(prefix,var,type) /**/
4755 # define PERLVARA(prefix,var,n,type) /**/
4756 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4757 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4758 # include "perlvars.h"
4763 # ifdef PERL_GLOBAL_STRUCT
4766 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4767 if (!plvarsp->Gppaddr)
4771 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4772 if (!plvarsp->Gcheck)
4774 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4775 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4777 # ifdef PERL_SET_VARS
4778 PERL_SET_VARS(plvarsp);
4780 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4781 plvarsp->Gsv_placeholder.sv_flags = 0;
4782 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4784 # undef PERL_GLOBAL_STRUCT_INIT
4789 #endif /* PERL_GLOBAL_STRUCT */
4791 #ifdef PERL_GLOBAL_STRUCT
4794 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4796 int veto = plvarsp->Gveto_cleanup;
4798 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4799 PERL_UNUSED_CONTEXT;
4800 # ifdef PERL_GLOBAL_STRUCT
4801 # ifdef PERL_UNSET_VARS
4802 PERL_UNSET_VARS(plvarsp);
4806 free(plvarsp->Gppaddr);
4807 free(plvarsp->Gcheck);
4808 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4814 #endif /* PERL_GLOBAL_STRUCT */
4818 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4819 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4820 * given, and you supply your own implementation.
4822 * The default implementation reads a single env var, PERL_MEM_LOG,
4823 * expecting one or more of the following:
4825 * \d+ - fd fd to write to : must be 1st (grok_atoUV)
4826 * 'm' - memlog was PERL_MEM_LOG=1
4827 * 's' - svlog was PERL_SV_LOG=1
4828 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
4830 * This makes the logger controllable enough that it can reasonably be
4831 * added to the system perl.
4834 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4835 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4837 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4839 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4840 * writes to. In the default logger, this is settable at runtime.
4842 #ifndef PERL_MEM_LOG_FD
4843 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4846 #ifndef PERL_MEM_LOG_NOIMPL
4848 # ifdef DEBUG_LEAKING_SCALARS
4849 # define SV_LOG_SERIAL_FMT " [%lu]"
4850 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
4852 # define SV_LOG_SERIAL_FMT
4853 # define _SV_LOG_SERIAL_ARG(sv)
4857 S_mem_log_common(enum mem_log_type mlt, const UV n,
4858 const UV typesize, const char *type_name, const SV *sv,
4859 Malloc_t oldalloc, Malloc_t newalloc,
4860 const char *filename, const int linenumber,
4861 const char *funcname)
4865 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4867 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4870 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4872 /* We can't use SVs or PerlIO for obvious reasons,
4873 * so we'll use stdio and low-level IO instead. */
4874 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4876 # ifdef HAS_GETTIMEOFDAY
4877 # define MEM_LOG_TIME_FMT "%10d.%06d: "
4878 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
4880 gettimeofday(&tv, 0);
4882 # define MEM_LOG_TIME_FMT "%10d: "
4883 # define MEM_LOG_TIME_ARG (int)when
4887 /* If there are other OS specific ways of hires time than
4888 * gettimeofday() (see ext/Time-HiRes), the easiest way is
4889 * probably that they would be used to fill in the struct
4896 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4897 && uv && uv <= PERL_INT_MAX
4901 fd = PERL_MEM_LOG_FD;
4904 if (strchr(pmlenv, 't')) {
4905 len = my_snprintf(buf, sizeof(buf),
4906 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4907 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4911 len = my_snprintf(buf, sizeof(buf),
4912 "alloc: %s:%d:%s: %"IVdf" %"UVuf
4913 " %s = %"IVdf": %"UVxf"\n",
4914 filename, linenumber, funcname, n, typesize,
4915 type_name, n * typesize, PTR2UV(newalloc));
4918 len = my_snprintf(buf, sizeof(buf),
4919 "realloc: %s:%d:%s: %"IVdf" %"UVuf
4920 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
4921 filename, linenumber, funcname, n, typesize,
4922 type_name, n * typesize, PTR2UV(oldalloc),
4926 len = my_snprintf(buf, sizeof(buf),
4927 "free: %s:%d:%s: %"UVxf"\n",
4928 filename, linenumber, funcname,
4933 len = my_snprintf(buf, sizeof(buf),
4934 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
4935 mlt == MLT_NEW_SV ? "new" : "del",
4936 filename, linenumber, funcname,
4937 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4942 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4946 #endif /* !PERL_MEM_LOG_NOIMPL */
4948 #ifndef PERL_MEM_LOG_NOIMPL
4950 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
4951 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
4953 /* this is suboptimal, but bug compatible. User is providing their
4954 own implementation, but is getting these functions anyway, and they
4955 do nothing. But _NOIMPL users should be able to cope or fix */
4957 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
4958 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
4962 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
4964 const char *filename, const int linenumber,
4965 const char *funcname)
4967 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
4968 NULL, NULL, newalloc,
4969 filename, linenumber, funcname);
4974 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
4975 Malloc_t oldalloc, Malloc_t newalloc,
4976 const char *filename, const int linenumber,
4977 const char *funcname)
4979 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
4980 NULL, oldalloc, newalloc,
4981 filename, linenumber, funcname);
4986 Perl_mem_log_free(Malloc_t oldalloc,
4987 const char *filename, const int linenumber,
4988 const char *funcname)
4990 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
4991 filename, linenumber, funcname);
4996 Perl_mem_log_new_sv(const SV *sv,
4997 const char *filename, const int linenumber,
4998 const char *funcname)
5000 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5001 filename, linenumber, funcname);
5005 Perl_mem_log_del_sv(const SV *sv,
5006 const char *filename, const int linenumber,
5007 const char *funcname)
5009 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5010 filename, linenumber, funcname);
5013 #endif /* PERL_MEM_LOG */
5016 =for apidoc my_sprintf
5018 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5019 the length of the string written to the buffer. Only rare pre-ANSI systems
5020 need the wrapper function - usually this is a direct call to C<sprintf>.
5024 #ifndef SPRINTF_RETURNS_STRLEN
5026 Perl_my_sprintf(char *buffer, const char* pat, ...)
5029 PERL_ARGS_ASSERT_MY_SPRINTF;
5030 va_start(args, pat);
5031 vsprintf(buffer, pat, args);
5033 return strlen(buffer);
5038 =for apidoc quadmath_format_single
5040 C<quadmath_snprintf()> is very strict about its C<format> string and will
5041 fail, returning -1, if the format is invalid. It accepts exactly
5044 C<quadmath_format_single()> checks that the intended single spec looks
5045 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
5046 and has C<Q> before it. This is not a full "printf syntax check",
5049 Returns the format if it is valid, NULL if not.
5051 C<quadmath_format_single()> can and will actually patch in the missing
5052 C<Q>, if necessary. In this case it will return the modified copy of
5053 the format, B<which the caller will need to free.>
5055 See also L</quadmath_format_needed>.
5061 Perl_quadmath_format_single(const char* format)
5065 PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
5067 if (format[0] != '%' || strchr(format + 1, '%'))
5069 len = strlen(format);
5070 /* minimum length three: %Qg */
5071 if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
5073 if (format[len - 2] != 'Q') {
5075 Newx(fixed, len + 1, char);
5076 memcpy(fixed, format, len - 1);
5077 fixed[len - 1] = 'Q';
5078 fixed[len ] = format[len - 1];
5080 return (const char*)fixed;
5087 =for apidoc quadmath_format_needed
5089 C<quadmath_format_needed()> returns true if the C<format> string seems to
5090 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
5091 or returns false otherwise.
5093 The format specifier detection is not complete printf-syntax detection,
5094 but it should catch most common cases.
5096 If true is returned, those arguments B<should> in theory be processed
5097 with C<quadmath_snprintf()>, but in case there is more than one such
5098 format specifier (see L</quadmath_format_single>), and if there is
5099 anything else beyond that one (even just a single byte), they
5100 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
5101 accepting only one format spec, and nothing else.
5102 In this case, the code should probably fail.
5108 Perl_quadmath_format_needed(const char* format)
5110 const char *p = format;
5113 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5115 while ((q = strchr(p, '%'))) {
5117 if (*q == '+') /* plus */
5119 if (*q == '#') /* alt */
5121 if (*q == '*') /* width */
5125 while (isDIGIT(*q)) q++;
5128 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5133 while (isDIGIT(*q)) q++;
5135 if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5144 =for apidoc my_snprintf
5146 The C library C<snprintf> functionality, if available and
5147 standards-compliant (uses C<vsnprintf>, actually). However, if the
5148 C<vsnprintf> is not available, will unfortunately use the unsafe
5149 C<vsprintf> which can overrun the buffer (there is an overrun check,
5150 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5151 getting C<vsnprintf>.
5156 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5160 PERL_ARGS_ASSERT_MY_SNPRINTF;
5161 #ifndef HAS_VSNPRINTF
5162 PERL_UNUSED_VAR(len);
5164 va_start(ap, format);
5167 const char* qfmt = quadmath_format_single(format);
5168 bool quadmath_valid = FALSE;
5170 /* If the format looked promising, use it as quadmath. */
5171 retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
5173 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
5174 quadmath_valid = TRUE;
5179 assert(qfmt == NULL);
5180 /* quadmath_format_single() will return false for example for
5181 * "foo = %g", or simply "%g". We could handle the %g by
5182 * using quadmath for the NV args. More complex cases of
5183 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
5184 * quadmath-valid but has stuff in front).
5186 * Handling the "Q-less" cases right would require walking
5187 * through the va_list and rewriting the format, calling
5188 * quadmath for the NVs, building a new va_list, and then
5189 * letting vsnprintf/vsprintf to take care of the other
5190 * arguments. This may be doable.
5192 * We do not attempt that now. But for paranoia, we here try
5193 * to detect some common (but not all) cases where the
5194 * "Q-less" %[efgaEFGA] formats are present, and die if
5195 * detected. This doesn't fix the problem, but it stops the
5196 * vsnprintf/vsprintf pulling doubles off the va_list when
5197 * __float128 NVs should be pulled off instead.
5199 * If quadmath_format_needed() returns false, we are reasonably
5200 * certain that we can call vnsprintf() or vsprintf() safely. */
5201 if (!quadmath_valid && quadmath_format_needed(format))
5202 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5207 #ifdef HAS_VSNPRINTF
5208 retval = vsnprintf(buffer, len, format, ap);
5210 retval = vsprintf(buffer, format, ap);
5213 /* vsprintf() shows failure with < 0 */
5215 #ifdef HAS_VSNPRINTF
5216 /* vsnprintf() shows failure with >= len */
5218 (len > 0 && (Size_t)retval >= len)
5221 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5226 =for apidoc my_vsnprintf
5228 The C library C<vsnprintf> if available and standards-compliant.
5229 However, if if the C<vsnprintf> is not available, will unfortunately
5230 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5231 overrun check, but that may be too late). Consider using
5232 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5237 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5240 PERL_UNUSED_ARG(buffer);
5241 PERL_UNUSED_ARG(len);
5242 PERL_UNUSED_ARG(format);
5243 PERL_UNUSED_ARG(ap);
5244 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5251 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5252 #ifndef HAS_VSNPRINTF
5253 PERL_UNUSED_VAR(len);
5255 Perl_va_copy(ap, apc);
5256 # ifdef HAS_VSNPRINTF
5257 retval = vsnprintf(buffer, len, format, apc);
5259 retval = vsprintf(buffer, format, apc);
5263 # ifdef HAS_VSNPRINTF
5264 retval = vsnprintf(buffer, len, format, ap);
5266 retval = vsprintf(buffer, format, ap);
5268 #endif /* #ifdef NEED_VA_COPY */
5269 /* vsprintf() shows failure with < 0 */
5271 #ifdef HAS_VSNPRINTF
5272 /* vsnprintf() shows failure with >= len */
5274 (len > 0 && (Size_t)retval >= len)
5277 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5283 Perl_my_clearenv(pTHX)
5286 #if ! defined(PERL_MICRO)
5287 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5289 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5290 # if defined(USE_ENVIRON_ARRAY)
5291 # if defined(USE_ITHREADS)
5292 /* only the parent thread can clobber the process environment */
5293 if (PL_curinterp == aTHX)
5294 # endif /* USE_ITHREADS */
5296 # if ! defined(PERL_USE_SAFE_PUTENV)
5297 if ( !PL_use_safe_putenv) {
5299 if (environ == PL_origenviron)
5300 environ = (char**)safesysmalloc(sizeof(char*));
5302 for (i = 0; environ[i]; i++)
5303 (void)safesysfree(environ[i]);
5306 # else /* PERL_USE_SAFE_PUTENV */
5307 # if defined(HAS_CLEARENV)
5309 # elif defined(HAS_UNSETENV)
5310 int bsiz = 80; /* Most envvar names will be shorter than this. */
5311 char *buf = (char*)safesysmalloc(bsiz);
5312 while (*environ != NULL) {
5313 char *e = strchr(*environ, '=');
5314 int l = e ? e - *environ : (int)strlen(*environ);
5316 (void)safesysfree(buf);
5317 bsiz = l + 1; /* + 1 for the \0. */
5318 buf = (char*)safesysmalloc(bsiz);
5320 memcpy(buf, *environ, l);
5322 (void)unsetenv(buf);
5324 (void)safesysfree(buf);
5325 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5326 /* Just null environ and accept the leakage. */
5328 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5329 # endif /* ! PERL_USE_SAFE_PUTENV */
5331 # endif /* USE_ENVIRON_ARRAY */
5332 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5333 #endif /* PERL_MICRO */
5336 #ifdef PERL_IMPLICIT_CONTEXT
5338 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5339 the global PL_my_cxt_index is incremented, and that value is assigned to
5340 that module's static my_cxt_index (who's address is passed as an arg).
5341 Then, for each interpreter this function is called for, it makes sure a
5342 void* slot is available to hang the static data off, by allocating or
5343 extending the interpreter's PL_my_cxt_list array */
5345 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5347 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5351 PERL_ARGS_ASSERT_MY_CXT_INIT;
5353 /* this module hasn't been allocated an index yet */
5354 #if defined(USE_ITHREADS)
5355 MUTEX_LOCK(&PL_my_ctx_mutex);
5357 *index = PL_my_cxt_index++;
5358 #if defined(USE_ITHREADS)
5359 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5363 /* make sure the array is big enough */
5364 if (PL_my_cxt_size <= *index) {
5365 if (PL_my_cxt_size) {
5366 while (PL_my_cxt_size <= *index)
5367 PL_my_cxt_size *= 2;
5368 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5371 PL_my_cxt_size = 16;
5372 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5375 /* newSV() allocates one more than needed */
5376 p = (void*)SvPVX(newSV(size-1));
5377 PL_my_cxt_list[*index] = p;
5378 Zero(p, size, char);
5382 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5385 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5390 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5392 for (index = 0; index < PL_my_cxt_index; index++) {
5393 const char *key = PL_my_cxt_keys[index];
5394 /* try direct pointer compare first - there are chances to success,
5395 * and it's much faster.
5397 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5404 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5410 PERL_ARGS_ASSERT_MY_CXT_INIT;
5412 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5414 /* this module hasn't been allocated an index yet */
5415 #if defined(USE_ITHREADS)
5416 MUTEX_LOCK(&PL_my_ctx_mutex);
5418 index = PL_my_cxt_index++;
5419 #if defined(USE_ITHREADS)
5420 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5424 /* make sure the array is big enough */
5425 if (PL_my_cxt_size <= index) {
5426 int old_size = PL_my_cxt_size;
5428 if (PL_my_cxt_size) {
5429 while (PL_my_cxt_size <= index)
5430 PL_my_cxt_size *= 2;
5431 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5432 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5435 PL_my_cxt_size = 16;
5436 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5437 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5439 for (i = old_size; i < PL_my_cxt_size; i++) {
5440 PL_my_cxt_keys[i] = 0;
5441 PL_my_cxt_list[i] = 0;
5444 PL_my_cxt_keys[index] = my_cxt_key;
5445 /* newSV() allocates one more than needed */
5446 p = (void*)SvPVX(newSV(size-1));
5447 PL_my_cxt_list[index] = p;
5448 Zero(p, size, char);
5451 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5452 #endif /* PERL_IMPLICIT_CONTEXT */
5455 /* Perl_xs_handshake():
5456 implement the various XS_*_BOOTCHECK macros, which are added to .c
5457 files by ExtUtils::ParseXS, to check that the perl the module was built
5458 with is binary compatible with the running perl.
5461 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5462 [U32 items, U32 ax], [char * api_version], [char * xs_version])
5464 The meaning of the varargs is determined the U32 key arg (which is not
5465 a format string). The fields of key are assembled by using HS_KEY().
5467 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5468 "PerlInterpreter *" and represents the callers context; otherwise it is
5469 of type "CV *", and is the boot xsub's CV.
5471 v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5472 for example, and IO.dll was linked with threaded perl524.dll, and both
5473 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5474 successfully can load IO.dll into the process but simultaneously it
5475 loaded an interpreter of a different version into the process, and XS
5476 code will naturally pass SV*s created by perl524.dll for perl526.dll to
5477 use through perl526.dll's my_perl->Istack_base.
5479 v_my_perl cannot be the first arg, since then 'key' will be out of
5480 place in a threaded vs non-threaded mixup; and analyzing the key
5481 number's bitfields won't reveal the problem, since it will be a valid
5482 key (unthreaded perl) on interp side, but croak will report the XS mod's
5483 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5484 it's a threaded perl and an unthreaded XS module, threaded perl will
5485 look at an uninit C stack or an uninit register to get 'key'
5486 (remember that it assumes that the 1st arg is the interp cxt).
5488 'file' is the source filename of the caller.
5492 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
5498 #ifdef PERL_IMPLICIT_CONTEXT
5505 PERL_ARGS_ASSERT_XS_HANDSHAKE;
5506 va_start(args, file);
5508 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
5509 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
5510 if (UNLIKELY(got != need))
5512 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5513 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5514 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5515 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5516 passed to the XS DLL */
5517 #ifdef PERL_IMPLICIT_CONTEXT
5518 xs_interp = (tTHX)v_my_perl;
5522 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5523 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5524 but the DynaLoder/Perl that started the process and loaded the XS DLL is
5525 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5526 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5527 location in the unthreaded perl binary) stored in CV * to figure out if this
5528 Perl_xs_handshake was called by the same pp_entersub */
5529 cv = (CV*)v_my_perl;
5530 xs_spp = (SV***)CvHSCXT(cv);
5532 need = &PL_stack_sp;
5534 if(UNLIKELY(got != need)) {
5535 bad_handshake:/* recycle branch and string from above */
5536 if(got != (void *)HSf_NOCHK)
5537 noperl_die("%s: loadable library and perl binaries are mismatched"
5538 " (got handshake key %p, needed %p)\n",
5542 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
5543 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5544 PL_xsubfilename = file; /* so the old name must be restored for
5545 additional XSUBs to register themselves */
5546 /* XSUBs can't be perl lang/perl5db.pl debugged
5547 if (PERLDB_LINE_OR_SAVESRC)
5548 (void)gv_fetchfile(file); */
5551 if(key & HSf_POPMARK) {
5553 { SV **mark = PL_stack_base + ax++;
5555 items = (I32)(SP - MARK);
5559 items = va_arg(args, U32);
5560 ax = va_arg(args, U32);
5564 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
5565 if((apiverlen = HS_GETAPIVERLEN(key))) {
5566 char * api_p = va_arg(args, char*);
5567 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5568 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5569 sizeof("v" PERL_API_VERSION_STRING)-1))
5570 Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
5571 api_p, SVfARG(PL_stack_base[ax + 0]),
5572 "v" PERL_API_VERSION_STRING);
5577 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
5578 if((xsverlen = HS_GETXSVERLEN(key)))
5579 S_xs_version_bootcheck(aTHX_
5580 items, ax, va_arg(args, char*), xsverlen);
5588 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5592 const char *vn = NULL;
5593 SV *const module = PL_stack_base[ax];
5595 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5597 if (items >= 2) /* version supplied as bootstrap arg */
5598 sv = PL_stack_base[ax + 1];
5600 /* XXX GV_ADDWARN */
5602 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
5603 if (!sv || !SvOK(sv)) {
5605 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
5609 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5610 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5611 ? sv : sv_2mortal(new_version(sv));
5612 xssv = upg_version(xssv, 0);
5613 if ( vcmp(pmsv,xssv) ) {
5614 SV *string = vstringify(xssv);
5615 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5616 " does not match ", SVfARG(module), SVfARG(string));
5618 SvREFCNT_dec(string);
5619 string = vstringify(pmsv);
5622 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn,
5625 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
5627 SvREFCNT_dec(string);
5629 Perl_sv_2mortal(aTHX_ xpt);
5630 Perl_croak_sv(aTHX_ xpt);
5636 =for apidoc my_strlcat
5638 The C library C<strlcat> if available, or a Perl implementation of it.
5639 This operates on C C<NUL>-terminated strings.
5641 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
5642 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
5643 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5644 practice this should not happen as it means that either C<size> is incorrect or
5645 that C<dst> is not a proper C<NUL>-terminated string).
5647 Note that C<size> is the full size of the destination buffer and
5648 the result is guaranteed to be C<NUL>-terminated if there is room. Note that
5649 room for the C<NUL> should be included in C<size>.
5653 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
5657 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5659 Size_t used, length, copy;
5662 length = strlen(src);
5663 if (size > 0 && used < size - 1) {
5664 copy = (length >= size - used) ? size - used - 1 : length;
5665 memcpy(dst + used, src, copy);
5666 dst[used + copy] = '\0';
5668 return used + length;
5674 =for apidoc my_strlcpy
5676 The C library C<strlcpy> if available, or a Perl implementation of it.
5677 This operates on C C<NUL>-terminated strings.
5679 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5680 to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
5684 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
5688 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5690 Size_t length, copy;
5692 length = strlen(src);
5694 copy = (length >= size) ? size - 1 : length;
5695 memcpy(dst, src, copy);
5702 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5703 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5704 long _ftol( double ); /* Defined by VC6 C libs. */
5705 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5708 PERL_STATIC_INLINE bool
5709 S_gv_has_usable_name(pTHX_ GV *gv)
5713 && HvENAME(GvSTASH(gv))
5714 && (gvp = (GV **)hv_fetchhek(
5715 GvSTASH(gv), GvNAME_HEK(gv), 0
5721 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5723 SV * const dbsv = GvSVn(PL_DBsub);
5724 const bool save_taint = TAINT_get;
5726 /* When we are called from pp_goto (svp is null),
5727 * we do not care about using dbsv to call CV;
5728 * it's for informational purposes only.
5731 PERL_ARGS_ASSERT_GET_DB_SUB;
5735 if (!PERLDB_SUB_NN) {
5738 if (!svp && !CvLEXICAL(cv)) {
5739 gv_efullname3(dbsv, gv, NULL);
5741 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
5742 || strEQ(GvNAME(gv), "END")
5743 || ( /* Could be imported, and old sub redefined. */
5744 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5746 !( (SvTYPE(*svp) == SVt_PVGV)
5747 && (GvCV((const GV *)*svp) == cv)
5748 /* Use GV from the stack as a fallback. */
5749 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
5753 /* GV is potentially non-unique, or contain different CV. */
5754 SV * const tmp = newRV(MUTABLE_SV(cv));
5755 sv_setsv(dbsv, tmp);
5759 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5760 sv_catpvs(dbsv, "::");
5761 sv_cathek(dbsv, GvNAME_HEK(gv));
5765 const int type = SvTYPE(dbsv);
5766 if (type < SVt_PVIV && type != SVt_IV)
5767 sv_upgrade(dbsv, SVt_PVIV);
5768 (void)SvIOK_on(dbsv);
5769 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5772 TAINT_IF(save_taint);
5773 #ifdef NO_TAINT_SUPPORT
5774 PERL_UNUSED_VAR(save_taint);
5779 Perl_my_dirfd(DIR * dir) {
5781 /* Most dirfd implementations have problems when passed NULL. */
5786 #elif defined(HAS_DIR_DD_FD)
5789 Perl_croak_nocontext(PL_no_func, "dirfd");
5790 NOT_REACHED; /* NOTREACHED */
5796 Perl_get_re_arg(pTHX_ SV *sv) {
5802 sv = MUTABLE_SV(SvRV(sv));
5803 if (SvTYPE(sv) == SVt_REGEXP)
5804 return (REGEXP*) sv;
5811 * This code is derived from drand48() implementation from FreeBSD,
5812 * found in lib/libc/gen/_rand48.c.
5814 * The U64 implementation is original, based on the POSIX
5815 * specification for drand48().
5819 * Copyright (c) 1993 Martin Birgmeier
5820 * All rights reserved.
5822 * You may redistribute unmodified or modified versions of this source
5823 * code provided that the above copyright notice and this and the
5824 * following conditions are retained.
5826 * This software is provided ``as is'', and comes with no warranties
5827 * of any kind. I shall in no event be liable for anything that happens
5828 * to anyone/anything when using this software.
5831 #define FREEBSD_DRAND48_SEED_0 (0x330e)
5833 #ifdef PERL_DRAND48_QUAD
5835 #define DRAND48_MULT U64_CONST(0x5deece66d)
5836 #define DRAND48_ADD 0xb
5837 #define DRAND48_MASK U64_CONST(0xffffffffffff)
5841 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
5842 #define FREEBSD_DRAND48_SEED_2 (0x1234)
5843 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
5844 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
5845 #define FREEBSD_DRAND48_MULT_2 (0x0005)
5846 #define FREEBSD_DRAND48_ADD (0x000b)
5848 const unsigned short _rand48_mult[3] = {
5849 FREEBSD_DRAND48_MULT_0,
5850 FREEBSD_DRAND48_MULT_1,
5851 FREEBSD_DRAND48_MULT_2
5853 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5858 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5860 PERL_ARGS_ASSERT_DRAND48_INIT_R;
5862 #ifdef PERL_DRAND48_QUAD
5863 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
5865 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5866 random_state->seed[1] = (U16) seed;
5867 random_state->seed[2] = (U16) (seed >> 16);
5872 Perl_drand48_r(perl_drand48_t *random_state)
5874 PERL_ARGS_ASSERT_DRAND48_R;
5876 #ifdef PERL_DRAND48_QUAD
5877 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5880 return ldexp((double)*random_state, -48);
5886 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5887 + (U32) _rand48_add;
5888 temp[0] = (U16) accu; /* lower 16 bits */
5889 accu >>= sizeof(U16) * 8;
5890 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5891 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5892 temp[1] = (U16) accu; /* middle 16 bits */
5893 accu >>= sizeof(U16) * 8;
5894 accu += _rand48_mult[0] * random_state->seed[2]
5895 + _rand48_mult[1] * random_state->seed[1]
5896 + _rand48_mult[2] * random_state->seed[0];
5897 random_state->seed[0] = temp[0];
5898 random_state->seed[1] = temp[1];
5899 random_state->seed[2] = (U16) accu;
5901 return ldexp((double) random_state->seed[0], -48) +
5902 ldexp((double) random_state->seed[1], -32) +
5903 ldexp((double) random_state->seed[2], -16);
5908 #ifdef USE_C_BACKTRACE
5910 /* Possibly move all this USE_C_BACKTRACE code into a new file. */
5915 /* abfd is the BFD handle. */
5917 /* bfd_syms is the BFD symbol table. */
5919 /* bfd_text is handle to the the ".text" section of the object file. */
5921 /* Since opening the executable and scanning its symbols is quite
5922 * heavy operation, we remember the filename we used the last time,
5923 * and do the opening and scanning only if the filename changes.
5924 * This removes most (but not all) open+scan cycles. */
5925 const char* fname_prev;
5928 /* Given a dl_info, update the BFD context if necessary. */
5929 static void bfd_update(bfd_context* ctx, Dl_info* dl_info)
5931 /* BFD open and scan only if the filename changed. */
5932 if (ctx->fname_prev == NULL ||
5933 strNE(dl_info->dli_fname, ctx->fname_prev)) {
5935 bfd_close(ctx->abfd);
5937 ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
5939 if (bfd_check_format(ctx->abfd, bfd_object)) {
5940 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd);
5941 if (symbol_size > 0) {
5942 Safefree(ctx->bfd_syms);
5943 Newx(ctx->bfd_syms, symbol_size, asymbol*);
5945 bfd_get_section_by_name(ctx->abfd, ".text");
5953 ctx->fname_prev = dl_info->dli_fname;
5957 /* Given a raw frame, try to symbolize it and store
5958 * symbol information (source file, line number) away. */
5959 static void bfd_symbolize(bfd_context* ctx,
5962 STRLEN* symbol_name_size,
5964 STRLEN* source_name_size,
5965 STRLEN* source_line)
5967 *symbol_name = NULL;
5968 *symbol_name_size = 0;
5970 IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma);
5972 bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) {
5975 unsigned int line = 0;
5976 if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text,
5977 ctx->bfd_syms, offset,
5978 &file, &func, &line) &&
5979 file && func && line > 0) {
5980 /* Size and copy the source file, use only
5981 * the basename of the source file.
5983 * NOTE: the basenames are fine for the
5984 * Perl source files, but may not always
5985 * be the best idea for XS files. */
5986 const char *p, *b = NULL;
5987 /* Look for the last slash. */
5988 for (p = file; *p; p++) {
5992 if (b == NULL || *b == 0) {
5995 *source_name_size = p - b + 1;
5996 Newx(*source_name, *source_name_size + 1, char);
5997 Copy(b, *source_name, *source_name_size + 1, char);
5999 *symbol_name_size = strlen(func);
6000 Newx(*symbol_name, *symbol_name_size + 1, char);
6001 Copy(func, *symbol_name, *symbol_name_size + 1, char);
6003 *source_line = line;
6009 #endif /* #ifdef USE_BFD */
6013 /* OS X has no public API for for 'symbolicating' (Apple official term)
6014 * stack addresses to {function_name, source_file, line_number}.
6015 * Good news: there is command line utility atos(1) which does that.
6016 * Bad news 1: it's a command line utility.
6017 * Bad news 2: one needs to have the Developer Tools installed.
6018 * Bad news 3: in newer releases it needs to be run as 'xcrun atos'.
6020 * To recap: we need to open a pipe for reading for a utility which
6021 * might not exist, or exists in different locations, and then parse
6022 * the output. And since this is all for a low-level API, we cannot
6023 * use high-level stuff. Thanks, Apple. */
6026 /* tool is set to the absolute pathname of the tool to use:
6029 /* format is set to a printf format string used for building
6030 * the external command to run. */
6032 /* unavail is set if e.g. xcrun cannot be found, or something
6033 * else happens that makes getting the backtrace dubious. Note,
6034 * however, that the context isn't persistent, the next call to
6035 * get_c_backtrace() will start from scratch. */
6037 /* fname is the current object file name. */
6039 /* object_base_addr is the base address of the shared object. */
6040 void* object_base_addr;
6043 /* Given |dl_info|, updates the context. If the context has been
6044 * marked unavailable, return immediately. If not but the tool has
6045 * not been set, set it to either "xcrun atos" or "atos" (also set the
6046 * format to use for creating commands for piping), or if neither is
6047 * unavailable (one needs the Developer Tools installed), mark the context
6048 * an unavailable. Finally, update the filename (object name),
6049 * and its base address. */
6051 static void atos_update(atos_context* ctx,
6056 if (ctx->tool == NULL) {
6057 const char* tools[] = {
6061 const char* formats[] = {
6062 "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1",
6063 "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1"
6067 for (i = 0; i < C_ARRAY_LENGTH(tools); i++) {
6068 if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) {
6069 ctx->tool = tools[i];
6070 ctx->format = formats[i];
6074 if (ctx->tool == NULL) {
6075 ctx->unavail = TRUE;
6079 if (ctx->fname == NULL ||
6080 strNE(dl_info->dli_fname, ctx->fname)) {
6081 ctx->fname = dl_info->dli_fname;
6082 ctx->object_base_addr = dl_info->dli_fbase;
6086 /* Given an output buffer end |p| and its |start|, matches
6087 * for the atos output, extracting the source code location
6088 * and returning non-NULL if possible, returning NULL otherwise. */
6089 static const char* atos_parse(const char* p,
6091 STRLEN* source_name_size,
6092 STRLEN* source_line) {
6093 /* atos() output is something like:
6094 * perl_parse (in miniperl) (perl.c:2314)\n\n".
6095 * We cannot use Perl regular expressions, because we need to
6096 * stay low-level. Therefore here we have a rolled-out version
6097 * of a state machine which matches _backwards_from_the_end_ and
6098 * if there's a success, returns the starts of the filename,
6099 * also setting the filename size and the source line number.
6100 * The matched regular expression is roughly "\(.*:\d+\)\s*$" */
6101 const char* source_number_start;
6102 const char* source_name_end;
6103 const char* source_line_end;
6104 const char* close_paren;
6107 /* Skip trailing whitespace. */
6108 while (p > start && isspace(*p)) p--;
6109 /* Now we should be at the close paren. */
6110 if (p == start || *p != ')')
6114 /* Now we should be in the line number. */
6115 if (p == start || !isdigit(*p))
6117 /* Skip over the digits. */
6118 while (p > start && isdigit(*p))
6120 /* Now we should be at the colon. */
6121 if (p == start || *p != ':')
6123 source_number_start = p + 1;
6124 source_name_end = p; /* Just beyond the end. */
6126 /* Look for the open paren. */
6127 while (p > start && *p != '(')
6132 *source_name_size = source_name_end - p;
6133 if (grok_atoUV(source_number_start, &uv, &source_line_end)
6134 && source_line_end == close_paren
6137 *source_line = (STRLEN)uv;
6143 /* Given a raw frame, read a pipe from the symbolicator (that's the
6144 * technical term) atos, reads the result, and parses the source code
6145 * location. We must stay low-level, so we use snprintf(), pipe(),
6146 * and fread(), and then also parse the output ourselves. */
6147 static void atos_symbolize(atos_context* ctx,
6150 STRLEN* source_name_size,
6151 STRLEN* source_line)
6159 /* Simple security measure: if there's any funny business with
6160 * the object name (used as "-o '%s'" ), leave since at least
6161 * partially the user controls it. */
6162 for (p = ctx->fname; *p; p++) {
6163 if (*p == '\'' || iscntrl(*p)) {
6164 ctx->unavail = TRUE;
6168 cnt = snprintf(cmd, sizeof(cmd), ctx->format,
6169 ctx->fname, ctx->object_base_addr, raw_frame);
6170 if (cnt < sizeof(cmd)) {
6171 /* Undo nostdio.h #defines that disable stdio.
6172 * This is somewhat naughty, but is used elsewhere
6173 * in the core, and affects only OS X. */
6178 FILE* fp = popen(cmd, "r");
6179 /* At the moment we open a new pipe for each stack frame.
6180 * This is naturally somewhat slow, but hopefully generating
6181 * stack traces is never going to in a performance critical path.
6183 * We could play tricks with atos by batching the stack
6184 * addresses to be resolved: atos can either take multiple
6185 * addresses from the command line, or read addresses from
6186 * a file (though the mess of creating temporary files would
6187 * probably negate much of any possible speedup).
6189 * Normally there are only two objects present in the backtrace:
6190 * perl itself, and the libdyld.dylib. (Note that the object
6191 * filenames contain the full pathname, so perl may not always
6192 * be in the same place.) Whenever the object in the
6193 * backtrace changes, the base address also changes.
6195 * The problem with batching the addresses, though, would be
6196 * matching the results with the addresses: the parsing of
6197 * the results is already painful enough with a single address. */
6200 UV cnt = fread(out, 1, sizeof(out), fp);
6201 if (cnt < sizeof(out)) {
6202 const char* p = atos_parse(out + cnt, out,
6207 *source_name_size + 1, char);
6208 Copy(p, *source_name,
6209 *source_name_size + 1, char);
6217 #endif /* #ifdef PERL_DARWIN */
6220 =for apidoc get_c_backtrace
6222 Collects the backtrace (aka "stacktrace") into a single linear
6223 malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
6225 Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
6226 returning at most C<depth> frames.
6232 Perl_get_c_backtrace(pTHX_ int depth, int skip)
6234 /* Note that here we must stay as low-level as possible: Newx(),
6235 * Copy(), Safefree(); since we may be called from anywhere,
6236 * so we should avoid higher level constructs like SVs or AVs.
6238 * Since we are using safesysmalloc() via Newx(), don't try
6239 * getting backtrace() there, unless you like deep recursion. */
6241 /* Currently only implemented with backtrace() and dladdr(),
6242 * for other platforms NULL is returned. */
6244 #if defined(HAS_BACKTRACE) && defined(HAS_DLADDR)
6245 /* backtrace() is available via <execinfo.h> in glibc and in most
6246 * modern BSDs; dladdr() is available via <dlfcn.h>. */
6248 /* We try fetching this many frames total, but then discard
6249 * the |skip| first ones. For the remaining ones we will try
6250 * retrieving more information with dladdr(). */
6251 int try_depth = skip + depth;
6253 /* The addresses (program counters) returned by backtrace(). */
6256 /* Retrieved with dladdr() from the addresses returned by backtrace(). */
6259 /* Sizes _including_ the terminating \0 of the object name
6260 * and symbol name strings. */
6261 STRLEN* object_name_sizes;
6262 STRLEN* symbol_name_sizes;
6265 /* The symbol names comes either from dli_sname,
6266 * or if using BFD, they can come from BFD. */
6267 char** symbol_names;
6270 /* The source code location information. Dug out with e.g. BFD. */
6271 char** source_names;
6272 STRLEN* source_name_sizes;
6273 STRLEN* source_lines;
6275 Perl_c_backtrace* bt = NULL; /* This is what will be returned. */
6276 int got_depth; /* How many frames were returned from backtrace(). */
6277 UV frame_count = 0; /* How many frames we return. */
6278 UV total_bytes = 0; /* The size of the whole returned backtrace. */
6281 bfd_context bfd_ctx;
6284 atos_context atos_ctx;
6287 /* Here are probably possibilities for optimizing. We could for
6288 * example have a struct that contains most of these and then
6289 * allocate |try_depth| of them, saving a bunch of malloc calls.
6290 * Note, however, that |frames| could not be part of that struct
6291 * because backtrace() will want an array of just them. Also be
6292 * careful about the name strings. */
6293 Newx(raw_frames, try_depth, void*);
6294 Newx(dl_infos, try_depth, Dl_info);
6295 Newx(object_name_sizes, try_depth, STRLEN);
6296 Newx(symbol_name_sizes, try_depth, STRLEN);
6297 Newx(source_names, try_depth, char*);
6298 Newx(source_name_sizes, try_depth, STRLEN);
6299 Newx(source_lines, try_depth, STRLEN);
6301 Newx(symbol_names, try_depth, char*);
6304 /* Get the raw frames. */
6305 got_depth = (int)backtrace(raw_frames, try_depth);
6307 /* We use dladdr() instead of backtrace_symbols() because we want
6308 * the full details instead of opaque strings. This is useful for
6309 * two reasons: () the details are needed for further symbolic
6310 * digging, for example in OS X (2) by having the details we fully
6311 * control the output, which in turn is useful when more platforms
6312 * are added: we can keep out output "portable". */
6314 /* We want a single linear allocation, which can then be freed
6315 * with a single swoop. We will do the usual trick of first
6316 * walking over the structure and seeing how much we need to
6317 * allocate, then allocating, and then walking over the structure
6318 * the second time and populating it. */
6320 /* First we must compute the total size of the buffer. */
6321 total_bytes = sizeof(Perl_c_backtrace_header);
6322 if (got_depth > skip) {
6325 bfd_init(); /* Is this safe to call multiple times? */
6326 Zero(&bfd_ctx, 1, bfd_context);
6329 Zero(&atos_ctx, 1, atos_context);
6331 for (i = skip; i < try_depth; i++) {
6332 Dl_info* dl_info = &dl_infos[i];
6334 total_bytes += sizeof(Perl_c_backtrace_frame);
6336 source_names[i] = NULL;
6337 source_name_sizes[i] = 0;
6338 source_lines[i] = 0;
6340 /* Yes, zero from dladdr() is failure. */
6341 if (dladdr(raw_frames[i], dl_info)) {
6342 object_name_sizes[i] =
6343 dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
6344 symbol_name_sizes[i] =
6345 dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0;
6347 bfd_update(&bfd_ctx, dl_info);
6348 bfd_symbolize(&bfd_ctx, raw_frames[i],
6350 &symbol_name_sizes[i],
6352 &source_name_sizes[i],
6356 atos_update(&atos_ctx, dl_info);
6357 atos_symbolize(&atos_ctx,
6360 &source_name_sizes[i],
6364 /* Plus ones for the terminating \0. */
6365 total_bytes += object_name_sizes[i] + 1;
6366 total_bytes += symbol_name_sizes[i] + 1;
6367 total_bytes += source_name_sizes[i] + 1;
6375 Safefree(bfd_ctx.bfd_syms);
6379 /* Now we can allocate and populate the result buffer. */
6380 Newxc(bt, total_bytes, char, Perl_c_backtrace);
6381 Zero(bt, total_bytes, char);
6382 bt->header.frame_count = frame_count;
6383 bt->header.total_bytes = total_bytes;
6384 if (frame_count > 0) {
6385 Perl_c_backtrace_frame* frame = bt->frame_info;
6386 char* name_base = (char *)(frame + frame_count);
6387 char* name_curr = name_base; /* Outputting the name strings here. */
6389 for (i = skip; i < skip + frame_count; i++) {
6390 Dl_info* dl_info = &dl_infos[i];
6392 frame->addr = raw_frames[i];
6393 frame->object_base_addr = dl_info->dli_fbase;
6394 frame->symbol_addr = dl_info->dli_saddr;
6396 /* Copies a string, including the \0, and advances the name_curr.
6397 * Also copies the start and the size to the frame. */
6398 #define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \
6400 Copy(src, name_curr, size, char); \
6401 frame->doffset = name_curr - (char*)bt; \
6402 frame->dsize = size; \
6403 name_curr += size; \
6406 PERL_C_BACKTRACE_STRCPY(frame, object_name_offset,
6408 object_name_size, object_name_sizes[i]);
6411 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6413 symbol_name_size, symbol_name_sizes[i]);
6414 Safefree(symbol_names[i]);
6416 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6418 symbol_name_size, symbol_name_sizes[i]);
6421 PERL_C_BACKTRACE_STRCPY(frame, source_name_offset,
6423 source_name_size, source_name_sizes[i]);
6424 Safefree(source_names[i]);
6426 #undef PERL_C_BACKTRACE_STRCPY
6428 frame->source_line_number = source_lines[i];
6432 assert(total_bytes ==
6433 (UV)(sizeof(Perl_c_backtrace_header) +
6434 frame_count * sizeof(Perl_c_backtrace_frame) +
6435 name_curr - name_base));
6438 Safefree(symbol_names);
6440 bfd_close(bfd_ctx.abfd);
6443 Safefree(source_lines);
6444 Safefree(source_name_sizes);
6445 Safefree(source_names);
6446 Safefree(symbol_name_sizes);
6447 Safefree(object_name_sizes);
6448 /* Assuming the strings returned by dladdr() are pointers
6449 * to read-only static memory (the object file), so that
6450 * they do not need freeing (and cannot be). */
6452 Safefree(raw_frames);
6455 PERL_UNUSED_ARGV(depth);
6456 PERL_UNUSED_ARGV(skip);
6462 =for apidoc free_c_backtrace
6464 Deallocates a backtrace received from get_c_bracktrace.
6470 =for apidoc get_c_backtrace_dump
6472 Returns a SV containing a dump of C<depth> frames of the call stack, skipping
6473 the C<skip> innermost ones. C<depth> of 20 is usually enough.
6475 The appended output looks like:
6478 1 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl
6479 2 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl
6482 The fields are tab-separated. The first column is the depth (zero
6483 being the innermost non-skipped frame). In the hex:offset, the hex is
6484 where the program counter was in C<S_parse_body>, and the :offset (might
6485 be missing) tells how much inside the C<S_parse_body> the program counter was.
6487 The C<util.c:1716> is the source code file and line number.
6489 The F</usr/bin/perl> is obvious (hopefully).
6491 Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
6492 if the platform doesn't support retrieving the information;
6493 if the binary is missing the debug information;
6494 if the optimizer has transformed the code by for example inlining.
6500 Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
6502 Perl_c_backtrace* bt;
6504 bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */);
6506 Perl_c_backtrace_frame* frame;
6507 SV* dsv = newSVpvs("");
6509 for (i = 0, frame = bt->frame_info;
6510 i < bt->header.frame_count; i++, frame++) {
6511 Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i);
6512 Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-");
6513 /* Symbol (function) names might disappear without debug info.
6515 * The source code location might disappear in case of the
6516 * optimizer inlining or otherwise rearranging the code. */
6517 if (frame->symbol_addr) {
6518 Perl_sv_catpvf(aTHX_ dsv, ":%04x",
6520 ((char*)frame->addr - (char*)frame->symbol_addr));
6522 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6523 frame->symbol_name_size &&
6524 frame->symbol_name_offset ?
6525 (char*)bt + frame->symbol_name_offset : "-");
6526 if (frame->source_name_size &&
6527 frame->source_name_offset &&
6528 frame->source_line_number) {
6529 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
6530 (char*)bt + frame->source_name_offset,
6531 (UV)frame->source_line_number);
6533 Perl_sv_catpvf(aTHX_ dsv, "\t-");
6535 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6536 frame->object_name_size &&
6537 frame->object_name_offset ?
6538 (char*)bt + frame->object_name_offset : "-");
6539 /* The frame->object_base_addr is not output,
6540 * but it is used for symbolizing/symbolicating. */
6541 sv_catpvs(dsv, "\n");
6544 Perl_free_c_backtrace(aTHX_ bt);
6553 =for apidoc dump_c_backtrace
6555 Dumps the C backtrace to the given C<fp>.
6557 Returns true if a backtrace could be retrieved, false if not.
6563 Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
6567 PERL_ARGS_ASSERT_DUMP_C_BACKTRACE;
6569 sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip);
6572 PerlIO_printf(fp, "%s", SvPV_nolen(sv));
6578 #endif /* #ifdef USE_C_BACKTRACE */
6580 #ifdef PERL_TSA_ACTIVE
6582 /* pthread_mutex_t and perl_mutex are typedef equivalent
6583 * so casting the pointers is fine. */
6585 int perl_tsa_mutex_lock(perl_mutex* mutex)
6587 return pthread_mutex_lock((pthread_mutex_t *) mutex);
6590 int perl_tsa_mutex_unlock(perl_mutex* mutex)
6592 return pthread_mutex_unlock((pthread_mutex_t *) mutex);
6595 int perl_tsa_mutex_destroy(perl_mutex* mutex)
6597 return pthread_mutex_destroy((pthread_mutex_t *) mutex);
6603 * ex: set ts=8 sts=4 sw=4 et: