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
138 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
140 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
143 if ((SSize_t)size < 0)
144 Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
146 if (!size) size = 1; /* malloc(0) is NASTY on our system */
148 #ifdef PERL_DEBUG_READONLY_COW
149 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
150 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
151 perror("mmap failed");
155 ptr = (Malloc_t)PerlMem_malloc(size);
157 PERL_ALLOC_CHECK(ptr);
160 struct perl_memory_debug_header *const header
161 = (struct perl_memory_debug_header *)ptr;
165 PoisonNew(((char *)ptr), size, char);
168 #ifdef PERL_TRACK_MEMPOOL
169 header->interpreter = aTHX;
170 /* Link us into the list. */
171 header->prev = &PL_memory_debug_header;
172 header->next = PL_memory_debug_header.next;
173 PL_memory_debug_header.next = header;
174 maybe_protect_rw(header->next);
175 header->next->prev = header;
176 maybe_protect_ro(header->next);
177 # ifdef PERL_DEBUG_READONLY_COW
178 header->readonly = 0;
184 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
185 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
187 /* malloc() can modify errno() even on success, but since someone
188 writing perl code doesn't have any control over when perl calls
189 malloc() we need to hide that.
198 #ifndef ALWAYS_NEED_THX
210 /* paranoid version of system's realloc() */
213 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
215 #ifdef ALWAYS_NEED_THX
219 #ifdef PERL_DEBUG_READONLY_COW
220 const MEM_SIZE oldsize = where
221 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
230 ptr = safesysmalloc(size);
235 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
236 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
238 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
240 struct perl_memory_debug_header *const header
241 = (struct perl_memory_debug_header *)where;
243 # ifdef PERL_TRACK_MEMPOOL
244 if (header->interpreter != aTHX) {
245 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
246 header->interpreter, aTHX);
248 assert(header->next->prev == header);
249 assert(header->prev->next == header);
251 if (header->size > size) {
252 const MEM_SIZE freed_up = header->size - size;
253 char *start_of_freed = ((char *)where) + size;
254 PoisonFree(start_of_freed, freed_up, char);
264 if ((SSize_t)size < 0)
265 Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
267 #ifdef PERL_DEBUG_READONLY_COW
268 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
269 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
270 perror("mmap failed");
273 Copy(where,ptr,oldsize < size ? oldsize : size,char);
274 if (munmap(where, oldsize)) {
275 perror("munmap failed");
279 ptr = (Malloc_t)PerlMem_realloc(where,size);
281 PERL_ALLOC_CHECK(ptr);
283 /* MUST do this fixup first, before doing ANYTHING else, as anything else
284 might allocate memory/free/move memory, and until we do the fixup, it
285 may well be chasing (and writing to) free memory. */
287 #ifdef PERL_TRACK_MEMPOOL
288 struct perl_memory_debug_header *const header
289 = (struct perl_memory_debug_header *)ptr;
292 if (header->size < size) {
293 const MEM_SIZE fresh = size - header->size;
294 char *start_of_fresh = ((char *)ptr) + size;
295 PoisonNew(start_of_fresh, fresh, char);
299 maybe_protect_rw(header->next);
300 header->next->prev = header;
301 maybe_protect_ro(header->next);
302 maybe_protect_rw(header->prev);
303 header->prev->next = header;
304 maybe_protect_ro(header->prev);
306 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
308 /* realloc() can modify errno() even on success, but since someone
309 writing perl code doesn't have any control over when perl calls
310 realloc() we need to hide that.
315 /* In particular, must do that fixup above before logging anything via
316 *printf(), as it can reallocate memory, which can cause SEGVs. */
318 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
319 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
326 #ifndef ALWAYS_NEED_THX
339 /* safe version of system's free() */
342 Perl_safesysfree(Malloc_t where)
344 #ifdef ALWAYS_NEED_THX
347 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
350 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
352 struct perl_memory_debug_header *const header
353 = (struct perl_memory_debug_header *)where_intrn;
356 const MEM_SIZE size = header->size;
358 # ifdef PERL_TRACK_MEMPOOL
359 if (header->interpreter != aTHX) {
360 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
361 header->interpreter, aTHX);
364 Perl_croak_nocontext("panic: duplicate free");
367 Perl_croak_nocontext("panic: bad free, header->next==NULL");
368 if (header->next->prev != header || header->prev->next != header) {
369 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
370 "header=%p, ->prev->next=%p",
371 header->next->prev, header,
374 /* Unlink us from the chain. */
375 maybe_protect_rw(header->next);
376 header->next->prev = header->prev;
377 maybe_protect_ro(header->next);
378 maybe_protect_rw(header->prev);
379 header->prev->next = header->next;
380 maybe_protect_ro(header->prev);
381 maybe_protect_rw(header);
383 PoisonNew(where_intrn, size, char);
385 /* Trigger the duplicate free warning. */
388 # ifdef PERL_DEBUG_READONLY_COW
389 if (munmap(where_intrn, size)) {
390 perror("munmap failed");
396 Malloc_t where_intrn = where;
398 #ifndef PERL_DEBUG_READONLY_COW
399 PerlMem_free(where_intrn);
404 /* safe version of system's calloc() */
407 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
409 #ifdef ALWAYS_NEED_THX
413 #if defined(USE_MDH) || defined(DEBUGGING)
414 MEM_SIZE total_size = 0;
417 /* Even though calloc() for zero bytes is strange, be robust. */
418 if (size && (count <= MEM_SIZE_MAX / size)) {
419 #if defined(USE_MDH) || defined(DEBUGGING)
420 total_size = size * count;
426 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
427 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
432 if ((SSize_t)size < 0 || (SSize_t)count < 0)
433 Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
434 (UV)size, (UV)count);
436 #ifdef PERL_DEBUG_READONLY_COW
437 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
438 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
439 perror("mmap failed");
442 #elif defined(PERL_TRACK_MEMPOOL)
443 /* Have to use malloc() because we've added some space for our tracking
445 /* malloc(0) is non-portable. */
446 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
448 /* Use calloc() because it might save a memset() if the memory is fresh
449 and clean from the OS. */
451 ptr = (Malloc_t)PerlMem_calloc(count, size);
452 else /* calloc(0) is non-portable. */
453 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
455 PERL_ALLOC_CHECK(ptr);
456 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
460 struct perl_memory_debug_header *const header
461 = (struct perl_memory_debug_header *)ptr;
463 # ifndef PERL_DEBUG_READONLY_COW
464 memset((void*)ptr, 0, total_size);
466 # ifdef PERL_TRACK_MEMPOOL
467 header->interpreter = aTHX;
468 /* Link us into the list. */
469 header->prev = &PL_memory_debug_header;
470 header->next = PL_memory_debug_header.next;
471 PL_memory_debug_header.next = header;
472 maybe_protect_rw(header->next);
473 header->next->prev = header;
474 maybe_protect_ro(header->next);
475 # ifdef PERL_DEBUG_READONLY_COW
476 header->readonly = 0;
480 header->size = total_size;
482 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
488 #ifndef ALWAYS_NEED_THX
497 /* These must be defined when not using Perl's malloc for binary
502 Malloc_t Perl_malloc (MEM_SIZE nbytes)
504 #ifdef PERL_IMPLICIT_SYS
507 return (Malloc_t)PerlMem_malloc(nbytes);
510 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
512 #ifdef PERL_IMPLICIT_SYS
515 return (Malloc_t)PerlMem_calloc(elements, size);
518 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
520 #ifdef PERL_IMPLICIT_SYS
523 return (Malloc_t)PerlMem_realloc(where, nbytes);
526 Free_t Perl_mfree (Malloc_t where)
528 #ifdef PERL_IMPLICIT_SYS
536 /* copy a string up to some (non-backslashed) delimiter, if any.
537 * With allow_escape, converts \<delimiter> to <delimiter>, while leaves
538 * \<non-delimiter> as-is.
539 * Returns the position in the src string of the closing delimiter, if
540 * any, or returns fromend otherwise.
541 * This is the internal implementation for Perl_delimcpy and
542 * Perl_delimcpy_no_escape.
546 S_delimcpy_intern(char *to, const char *toend, const char *from,
547 const char *fromend, int delim, I32 *retlen,
548 const bool allow_escape)
552 PERL_ARGS_ASSERT_DELIMCPY;
554 for (tolen = 0; from < fromend; from++, tolen++) {
555 if (allow_escape && *from == '\\' && from + 1 < fromend) {
556 if (from[1] != delim) {
563 else if (*from == delim)
575 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
577 PERL_ARGS_ASSERT_DELIMCPY;
579 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
583 Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
584 const char *fromend, int delim, I32 *retlen)
586 PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
588 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
592 =head1 Miscellaneous Functions
596 Find the first (leftmost) occurrence of a sequence of bytes within another
597 sequence. This is the Perl version of C<strstr()>, extended to handle
598 arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
599 is what the initial C<n> in the function name stands for; some systems have an
600 equivalent, C<memmem()>, but with a somewhat different API).
602 Another way of thinking about this function is finding a needle in a haystack.
603 C<big> points to the first byte in the haystack. C<big_end> points to one byte
604 beyond the final byte in the haystack. C<little> points to the first byte in
605 the needle. C<little_end> points to one byte beyond the final byte in the
606 needle. All the parameters must be non-C<NULL>.
608 The function returns C<NULL> if there is no occurrence of C<little> within
609 C<big>. If C<little> is the empty string, C<big> is returned.
611 Because this function operates at the byte level, and because of the inherent
612 characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
613 needle and the haystack are strings with the same UTF-8ness, but not if the
621 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
623 PERL_ARGS_ASSERT_NINSTR;
626 return ninstr(big, bigend, little, lend);
632 const char first = *little;
633 bigend -= lend - little++;
635 while (big <= bigend) {
636 if (*big++ == first) {
638 for (x=big,s=little; s < lend; x++,s++) {
642 return (char*)(big-1);
653 =head1 Miscellaneous Functions
657 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
658 sequence of bytes within another sequence, returning C<NULL> if there is no
666 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
669 const I32 first = *little;
670 const char * const littleend = lend;
672 PERL_ARGS_ASSERT_RNINSTR;
674 if (little >= littleend)
675 return (char*)bigend;
677 big = bigend - (littleend - little++);
678 while (big >= bigbeg) {
682 for (x=big+2,s=little; s < littleend; /**/ ) {
691 return (char*)(big+1);
696 /* As a space optimization, we do not compile tables for strings of length
697 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
698 special-cased in fbm_instr().
700 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
703 =head1 Miscellaneous Functions
705 =for apidoc fbm_compile
707 Analyzes the string in order to make fast searches on it using C<fbm_instr()>
708 -- the Boyer-Moore algorithm.
714 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
721 PERL_ARGS_ASSERT_FBM_COMPILE;
723 if (isGV_with_GP(sv) || SvROK(sv))
729 if (flags & FBMcf_TAIL) {
730 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
731 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
732 if (mg && mg->mg_len >= 0)
735 if (!SvPOK(sv) || SvNIOKp(sv))
736 s = (U8*)SvPV_force_mutable(sv, len);
737 else s = (U8 *)SvPV_mutable(sv, len);
738 if (len == 0) /* TAIL might be on a zero-length string. */
740 SvUPGRADE(sv, SVt_PVMG);
744 /* add PERL_MAGIC_bm magic holding the FBM lookup table */
746 assert(!mg_find(sv, PERL_MAGIC_bm));
747 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
751 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
753 const U8 mlen = (len>255) ? 255 : (U8)len;
754 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
757 Newx(table, 256, U8);
758 memset((void*)table, mlen, 256);
759 mg->mg_ptr = (char *)table;
762 s += len - 1; /* last char */
765 if (table[*s] == mlen)
771 BmUSEFUL(sv) = 100; /* Initial value */
772 ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
777 =for apidoc fbm_instr
779 Returns the location of the SV in the string delimited by C<big> and
780 C<bigend> (C<bigend>) is the char following the last char).
781 It returns C<NULL> if the string can't be found. The C<sv>
782 does not have to be C<fbm_compiled>, but the search will not be as fast
787 If SvTAIL(littlestr) is true, a fake "\n" was appended to the string
788 during FBM compilation due to FBMcf_TAIL in flags. It indicates that
789 the littlestr must be anchored to the end of bigstr (or to any \n if
792 E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
793 while /abc$/ compiles to "abc\n" with SvTAIL() true.
795 A littlestr of "abc", !SvTAIL matches as /abc/;
796 a littlestr of "ab\n", SvTAIL matches as:
797 without FBMrf_MULTILINE: /ab\n?\z/
798 with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
800 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
801 "If SvTAIL is actually due to \Z or \z, this gives false positives
807 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
811 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
812 STRLEN littlelen = l;
813 const I32 multiline = flags & FBMrf_MULTILINE;
814 bool valid = SvVALID(littlestr);
815 bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
817 PERL_ARGS_ASSERT_FBM_INSTR;
819 assert(bigend >= big);
821 if ((STRLEN)(bigend - big) < littlelen) {
823 && ((STRLEN)(bigend - big) == littlelen - 1)
825 || (*big == *little &&
826 memEQ((char *)big, (char *)little, littlelen - 1))))
831 switch (littlelen) { /* Special cases for 0, 1 and 2 */
833 return (char*)big; /* Cannot be SvTAIL! */
836 if (tail && !multiline) /* Anchor only! */
837 /* [-1] is safe because we know that bigend != big. */
838 return (char *) (bigend - (bigend[-1] == '\n'));
840 s = (unsigned char *)memchr((void*)big, *little, bigend-big);
844 return (char *) bigend;
848 if (tail && !multiline) {
849 /* a littlestr with SvTAIL must be of the form "X\n" (where X
850 * is a single char). It is anchored, and can only match
851 * "....X\n" or "....X" */
852 if (bigend[-2] == *little && bigend[-1] == '\n')
853 return (char*)bigend - 2;
854 if (bigend[-1] == *little)
855 return (char*)bigend - 1;
860 /* memchr() is likely to be very fast, possibly using whatever
861 * hardware support is available, such as checking a whole
862 * cache line in one instruction.
863 * So for a 2 char pattern, calling memchr() is likely to be
864 * faster than running FBM, or rolling our own. The previous
865 * version of this code was roll-your-own which typically
866 * only needed to read every 2nd char, which was good back in
867 * the day, but no longer.
869 unsigned char c1 = little[0];
870 unsigned char c2 = little[1];
872 /* *** for all this case, bigend points to the last char,
873 * not the trailing \0: this makes the conditions slightly
879 /* do a quick test for c1 before calling memchr();
880 * this avoids the expensive fn call overhead when
881 * there are lots of c1's */
882 if (LIKELY(*s != c1)) {
884 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
891 /* failed; try searching for c2 this time; that way
892 * we don't go pathologically slow when the string
893 * consists mostly of c1's or vice versa.
898 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
906 /* c1, c2 the same */
916 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
917 if (!s || s >= bigend)
924 /* failed to find 2 chars; try anchored match at end without
926 if (tail && bigend[0] == little[0])
927 return (char *)bigend;
932 break; /* Only lengths 0 1 and 2 have special-case code. */
935 if (tail && !multiline) { /* tail anchored? */
936 s = bigend - littlelen;
937 if (s >= big && bigend[-1] == '\n' && *s == *little
938 /* Automatically of length > 2 */
939 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
941 return (char*)s; /* how sweet it is */
944 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
946 return (char*)s + 1; /* how sweet it is */
952 /* not compiled; use Perl_ninstr() instead */
953 char * const b = ninstr((char*)big,(char*)bigend,
954 (char*)little, (char*)little + littlelen);
956 assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
961 if (littlelen > (STRLEN)(bigend - big))
965 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
966 const unsigned char *oldlittle;
970 --littlelen; /* Last char found by table lookup */
973 little += littlelen; /* last char */
976 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
977 const unsigned char lastc = *little;
981 if ((tmp = table[*s])) {
982 /* *s != lastc; earliest position it could match now is
983 * tmp slots further on */
984 if ((s += tmp) >= bigend)
986 if (LIKELY(*s != lastc)) {
988 s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
998 /* hand-rolled strncmp(): less expensive than calling the
999 * real function (maybe???) */
1001 unsigned char * const olds = s;
1006 if (*--s == *--little)
1008 s = olds + 1; /* here we pay the price for failure */
1010 if (s < bigend) /* fake up continue to outer loop */
1020 && memEQ((char *)(bigend - littlelen),
1021 (char *)(oldlittle - littlelen), littlelen) )
1022 return (char*)bigend - littlelen;
1028 Perl_cntrl_to_mnemonic(const U8 c)
1030 /* Returns the mnemonic string that represents character 'c', if one
1031 * exists; NULL otherwise. The only ones that exist for the purposes of
1032 * this routine are a few control characters */
1035 case '\a': return "\\a";
1036 case '\b': return "\\b";
1037 case ESC_NATIVE: return "\\e";
1038 case '\f': return "\\f";
1039 case '\n': return "\\n";
1040 case '\r': return "\\r";
1041 case '\t': return "\\t";
1047 /* copy a string to a safe spot */
1050 =head1 Memory Management
1054 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1055 string which is a duplicate of C<pv>. The size of the string is
1056 determined by C<strlen()>, which means it may not contain embedded C<NUL>
1057 characters and must have a trailing C<NUL>. To prevent memory leaks, the
1058 memory allocated for the new string needs to be freed when no longer needed.
1059 This can be done with the L</C<Safefree>> function, or
1060 L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
1062 On some platforms, Windows for example, all allocated memory owned by a thread
1063 is deallocated when that thread ends. So if you need that not to happen, you
1064 need to use the shared memory functions, such as C<L</savesharedpv>>.
1070 Perl_savepv(pTHX_ const char *pv)
1072 PERL_UNUSED_CONTEXT;
1077 const STRLEN pvlen = strlen(pv)+1;
1078 Newx(newaddr, pvlen, char);
1079 return (char*)memcpy(newaddr, pv, pvlen);
1083 /* same thing but with a known length */
1088 Perl's version of what C<strndup()> would be if it existed. Returns a
1089 pointer to a newly allocated string which is a duplicate of the first
1090 C<len> bytes from C<pv>, plus a trailing
1091 C<NUL> byte. The memory allocated for
1092 the new string can be freed with the C<Safefree()> function.
1094 On some platforms, Windows for example, all allocated memory owned by a thread
1095 is deallocated when that thread ends. So if you need that not to happen, you
1096 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1102 Perl_savepvn(pTHX_ const char *pv, Size_t len)
1105 PERL_UNUSED_CONTEXT;
1107 Newx(newaddr,len+1,char);
1108 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1110 /* might not be null terminated */
1111 newaddr[len] = '\0';
1112 return (char *) CopyD(pv,newaddr,len,char);
1115 return (char *) ZeroD(newaddr,len+1,char);
1120 =for apidoc savesharedpv
1122 A version of C<savepv()> which allocates the duplicate string in memory
1123 which is shared between threads.
1128 Perl_savesharedpv(pTHX_ const char *pv)
1133 PERL_UNUSED_CONTEXT;
1138 pvlen = strlen(pv)+1;
1139 newaddr = (char*)PerlMemShared_malloc(pvlen);
1143 return (char*)memcpy(newaddr, pv, pvlen);
1147 =for apidoc savesharedpvn
1149 A version of C<savepvn()> which allocates the duplicate string in memory
1150 which is shared between threads. (With the specific difference that a C<NULL>
1151 pointer is not acceptable)
1156 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1158 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1160 PERL_UNUSED_CONTEXT;
1161 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1166 newaddr[len] = '\0';
1167 return (char*)memcpy(newaddr, pv, len);
1171 =for apidoc savesvpv
1173 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1174 the passed in SV using C<SvPV()>
1176 On some platforms, Windows for example, all allocated memory owned by a thread
1177 is deallocated when that thread ends. So if you need that not to happen, you
1178 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1184 Perl_savesvpv(pTHX_ SV *sv)
1187 const char * const pv = SvPV_const(sv, len);
1190 PERL_ARGS_ASSERT_SAVESVPV;
1193 Newx(newaddr,len,char);
1194 return (char *) CopyD(pv,newaddr,len,char);
1198 =for apidoc savesharedsvpv
1200 A version of C<savesharedpv()> which allocates the duplicate string in
1201 memory which is shared between threads.
1207 Perl_savesharedsvpv(pTHX_ SV *sv)
1210 const char * const pv = SvPV_const(sv, len);
1212 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1214 return savesharedpvn(pv, len);
1217 /* the SV for Perl_form() and mess() is not kept in an arena */
1225 if (PL_phase != PERL_PHASE_DESTRUCT)
1226 return newSVpvs_flags("", SVs_TEMP);
1231 /* Create as PVMG now, to avoid any upgrading later */
1233 Newxz(any, 1, XPVMG);
1234 SvFLAGS(sv) = SVt_PVMG;
1235 SvANY(sv) = (void*)any;
1237 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1242 #if defined(PERL_IMPLICIT_CONTEXT)
1244 Perl_form_nocontext(const char* pat, ...)
1249 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1250 va_start(args, pat);
1251 retval = vform(pat, &args);
1255 #endif /* PERL_IMPLICIT_CONTEXT */
1258 =head1 Miscellaneous Functions
1261 Takes a sprintf-style format pattern and conventional
1262 (non-SV) arguments and returns the formatted string.
1264 (char *) Perl_form(pTHX_ const char* pat, ...)
1266 can be used any place a string (char *) is required:
1268 char * s = Perl_form("%d.%d",major,minor);
1270 Uses a single private buffer so if you want to format several strings you
1271 must explicitly copy the earlier strings away (and free the copies when you
1278 Perl_form(pTHX_ const char* pat, ...)
1282 PERL_ARGS_ASSERT_FORM;
1283 va_start(args, pat);
1284 retval = vform(pat, &args);
1290 Perl_vform(pTHX_ const char *pat, va_list *args)
1292 SV * const sv = mess_alloc();
1293 PERL_ARGS_ASSERT_VFORM;
1294 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1301 Take a sprintf-style format pattern and argument list. These are used to
1302 generate a string message. If the message does not end with a newline,
1303 then it will be extended with some indication of the current location
1304 in the code, as described for L</mess_sv>.
1306 Normally, the resulting message is returned in a new mortal SV.
1307 During global destruction a single SV may be shared between uses of
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1315 Perl_mess_nocontext(const char *pat, ...)
1320 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1321 va_start(args, pat);
1322 retval = vmess(pat, &args);
1326 #endif /* PERL_IMPLICIT_CONTEXT */
1329 Perl_mess(pTHX_ const char *pat, ...)
1333 PERL_ARGS_ASSERT_MESS;
1334 va_start(args, pat);
1335 retval = vmess(pat, &args);
1341 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1344 /* Look for curop starting from o. cop is the last COP we've seen. */
1345 /* opnext means that curop is actually the ->op_next of the op we are
1348 PERL_ARGS_ASSERT_CLOSEST_COP;
1350 if (!o || !curop || (
1351 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1355 if (o->op_flags & OPf_KIDS) {
1357 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1360 /* If the OP_NEXTSTATE has been optimised away we can still use it
1361 * the get the file and line number. */
1363 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1364 cop = (const COP *)kid;
1366 /* Keep searching, and return when we've found something. */
1368 new_cop = closest_cop(cop, kid, curop, opnext);
1374 /* Nothing found. */
1382 Expands a message, intended for the user, to include an indication of
1383 the current location in the code, if the message does not already appear
1386 C<basemsg> is the initial message or object. If it is a reference, it
1387 will be used as-is and will be the result of this function. Otherwise it
1388 is used as a string, and if it already ends with a newline, it is taken
1389 to be complete, and the result of this function will be the same string.
1390 If the message does not end with a newline, then a segment such as C<at
1391 foo.pl line 37> will be appended, and possibly other clauses indicating
1392 the current state of execution. The resulting message will end with a
1395 Normally, the resulting message is returned in a new mortal SV.
1396 During global destruction a single SV may be shared between uses of this
1397 function. If C<consume> is true, then the function is permitted (but not
1398 required) to modify and return C<basemsg> instead of allocating a new SV.
1404 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1408 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1412 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1413 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1414 && grok_atoUV(ws, &wi, NULL)
1415 && wi <= PERL_INT_MAX
1417 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1422 PERL_ARGS_ASSERT_MESS_SV;
1424 if (SvROK(basemsg)) {
1430 sv_setsv(sv, basemsg);
1435 if (SvPOK(basemsg) && consume) {
1440 sv_copypv(sv, basemsg);
1443 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1445 * Try and find the file and line for PL_op. This will usually be
1446 * PL_curcop, but it might be a cop that has been optimised away. We
1447 * can try to find such a cop by searching through the optree starting
1448 * from the sibling of PL_curcop.
1453 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1458 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1459 OutCopFILE(cop), (IV)CopLINE(cop));
1462 /* Seems that GvIO() can be untrustworthy during global destruction. */
1463 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1464 && IoLINES(GvIOp(PL_last_in_gv)))
1467 const bool line_mode = (RsSIMPLE(PL_rs) &&
1468 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1469 Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
1470 SVfARG(PL_last_in_gv == PL_argvgv
1472 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1473 line_mode ? "line" : "chunk",
1474 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1476 if (PL_phase == PERL_PHASE_DESTRUCT)
1477 sv_catpvs(sv, " during global destruction");
1478 sv_catpvs(sv, ".\n");
1486 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1487 argument list, respectively. These are used to generate a string message. If
1489 message does not end with a newline, then it will be extended with
1490 some indication of the current location in the code, as described for
1493 Normally, the resulting message is returned in a new mortal SV.
1494 During global destruction a single SV may be shared between uses of
1501 Perl_vmess(pTHX_ const char *pat, va_list *args)
1503 SV * const sv = mess_alloc();
1505 PERL_ARGS_ASSERT_VMESS;
1507 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1508 return mess_sv(sv, 1);
1512 Perl_write_to_stderr(pTHX_ SV* msv)
1517 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1519 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1520 && (io = GvIO(PL_stderrgv))
1521 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1522 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1523 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1525 PerlIO * const serr = Perl_error_log;
1527 do_print(msv, serr);
1528 (void)PerlIO_flush(serr);
1533 =head1 Warning and Dieing
1536 /* Common code used in dieing and warning */
1539 S_with_queued_errors(pTHX_ SV *ex)
1541 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1542 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1543 sv_catsv(PL_errors, ex);
1544 ex = sv_mortalcopy(PL_errors);
1545 SvCUR_set(PL_errors, 0);
1551 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1556 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1557 /* sv_2cv might call Perl_croak() or Perl_warner() */
1558 SV * const oldhook = *hook;
1560 if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
1566 cv = sv_2cv(oldhook, &stash, &gv, 0);
1568 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1578 exarg = newSVsv(ex);
1579 SvREADONLY_on(exarg);
1582 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1586 call_sv(MUTABLE_SV(cv), G_DISCARD);
1597 Behaves the same as L</croak_sv>, except for the return type.
1598 It should be used only where the C<OP *> return type is required.
1599 The function never actually returns.
1604 /* silence __declspec(noreturn) warnings */
1605 MSVC_DIAG_IGNORE(4646 4645)
1607 Perl_die_sv(pTHX_ SV *baseex)
1609 PERL_ARGS_ASSERT_DIE_SV;
1612 NORETURN_FUNCTION_END;
1619 Behaves the same as L</croak>, except for the return type.
1620 It should be used only where the C<OP *> return type is required.
1621 The function never actually returns.
1626 #if defined(PERL_IMPLICIT_CONTEXT)
1628 /* silence __declspec(noreturn) warnings */
1629 MSVC_DIAG_IGNORE(4646 4645)
1631 Perl_die_nocontext(const char* pat, ...)
1635 va_start(args, pat);
1637 NOT_REACHED; /* NOTREACHED */
1639 NORETURN_FUNCTION_END;
1643 #endif /* PERL_IMPLICIT_CONTEXT */
1645 /* silence __declspec(noreturn) warnings */
1646 MSVC_DIAG_IGNORE(4646 4645)
1648 Perl_die(pTHX_ const char* pat, ...)
1651 va_start(args, pat);
1653 NOT_REACHED; /* NOTREACHED */
1655 NORETURN_FUNCTION_END;
1660 =for apidoc croak_sv
1662 This is an XS interface to Perl's C<die> function.
1664 C<baseex> is the error message or object. If it is a reference, it
1665 will be used as-is. Otherwise it is used as a string, and if it does
1666 not end with a newline then it will be extended with some indication of
1667 the current location in the code, as described for L</mess_sv>.
1669 The error message or object will be used as an exception, by default
1670 returning control to the nearest enclosing C<eval>, but subject to
1671 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1672 function never returns normally.
1674 To die with a simple string message, the L</croak> function may be
1681 Perl_croak_sv(pTHX_ SV *baseex)
1683 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1684 PERL_ARGS_ASSERT_CROAK_SV;
1685 invoke_exception_hook(ex, FALSE);
1692 This is an XS interface to Perl's C<die> function.
1694 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1695 argument list. These are used to generate a string message. If the
1696 message does not end with a newline, then it will be extended with
1697 some indication of the current location in the code, as described for
1700 The error message will be used as an exception, by default
1701 returning control to the nearest enclosing C<eval>, but subject to
1702 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1703 function never returns normally.
1705 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1706 (C<$@>) will be used as an error message or object instead of building an
1707 error message from arguments. If you want to throw a non-string object,
1708 or build an error message in an SV yourself, it is preferable to use
1709 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1715 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1717 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1718 invoke_exception_hook(ex, FALSE);
1725 This is an XS interface to Perl's C<die> function.
1727 Take a sprintf-style format pattern and argument list. These are used to
1728 generate a string message. If the message does not end with a newline,
1729 then it will be extended with some indication of the current location
1730 in the code, as described for L</mess_sv>.
1732 The error message will be used as an exception, by default
1733 returning control to the nearest enclosing C<eval>, but subject to
1734 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1735 function never returns normally.
1737 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1738 (C<$@>) will be used as an error message or object instead of building an
1739 error message from arguments. If you want to throw a non-string object,
1740 or build an error message in an SV yourself, it is preferable to use
1741 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1746 #if defined(PERL_IMPLICIT_CONTEXT)
1748 Perl_croak_nocontext(const char *pat, ...)
1752 va_start(args, pat);
1754 NOT_REACHED; /* NOTREACHED */
1757 #endif /* PERL_IMPLICIT_CONTEXT */
1759 /* saves machine code for a common noreturn idiom typically used in Newx*() */
1760 GCC_DIAG_IGNORE_DECL(-Wunused-function);
1762 Perl_croak_memory_wrap(void)
1764 Perl_croak_nocontext("%s",PL_memory_wrap);
1766 GCC_DIAG_RESTORE_DECL;
1769 Perl_croak(pTHX_ const char *pat, ...)
1772 va_start(args, pat);
1774 NOT_REACHED; /* NOTREACHED */
1779 =for apidoc croak_no_modify
1781 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1782 terser object code than using C<Perl_croak>. Less code used on exception code
1783 paths reduces CPU cache pressure.
1789 Perl_croak_no_modify(void)
1791 Perl_croak_nocontext( "%s", PL_no_modify);
1794 /* does not return, used in util.c perlio.c and win32.c
1795 This is typically called when malloc returns NULL.
1798 Perl_croak_no_mem(void)
1802 int fd = PerlIO_fileno(Perl_error_log);
1804 SETERRNO(EBADF,RMS_IFI);
1806 /* Can't use PerlIO to write as it allocates memory */
1807 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
1812 /* does not return, used only in POPSTACK */
1814 Perl_croak_popstack(void)
1817 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1824 This is an XS interface to Perl's C<warn> function.
1826 C<baseex> is the error message or object. If it is a reference, it
1827 will be used as-is. Otherwise it is used as a string, and if it does
1828 not end with a newline then it will be extended with some indication of
1829 the current location in the code, as described for L</mess_sv>.
1831 The error message or object will by default be written to standard error,
1832 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1834 To warn with a simple string message, the L</warn> function may be
1841 Perl_warn_sv(pTHX_ SV *baseex)
1843 SV *ex = mess_sv(baseex, 0);
1844 PERL_ARGS_ASSERT_WARN_SV;
1845 if (!invoke_exception_hook(ex, TRUE))
1846 write_to_stderr(ex);
1852 This is an XS interface to Perl's C<warn> function.
1854 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1855 argument list. These are used to generate a string message. If the
1856 message does not end with a newline, then it will be extended with
1857 some indication of the current location in the code, as described for
1860 The error message or object will by default be written to standard error,
1861 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1863 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1869 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1871 SV *ex = vmess(pat, args);
1872 PERL_ARGS_ASSERT_VWARN;
1873 if (!invoke_exception_hook(ex, TRUE))
1874 write_to_stderr(ex);
1880 This is an XS interface to Perl's C<warn> function.
1882 Take a sprintf-style format pattern and argument list. These are used to
1883 generate a string message. If the message does not end with a newline,
1884 then it will be extended with some indication of the current location
1885 in the code, as described for L</mess_sv>.
1887 The error message or object will by default be written to standard error,
1888 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1890 Unlike with L</croak>, C<pat> is not permitted to be null.
1895 #if defined(PERL_IMPLICIT_CONTEXT)
1897 Perl_warn_nocontext(const char *pat, ...)
1901 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1902 va_start(args, pat);
1906 #endif /* PERL_IMPLICIT_CONTEXT */
1909 Perl_warn(pTHX_ const char *pat, ...)
1912 PERL_ARGS_ASSERT_WARN;
1913 va_start(args, pat);
1918 #if defined(PERL_IMPLICIT_CONTEXT)
1920 Perl_warner_nocontext(U32 err, const char *pat, ...)
1924 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1925 va_start(args, pat);
1926 vwarner(err, pat, &args);
1929 #endif /* PERL_IMPLICIT_CONTEXT */
1932 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1934 PERL_ARGS_ASSERT_CK_WARNER_D;
1936 if (Perl_ckwarn_d(aTHX_ err)) {
1938 va_start(args, pat);
1939 vwarner(err, pat, &args);
1945 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1947 PERL_ARGS_ASSERT_CK_WARNER;
1949 if (Perl_ckwarn(aTHX_ err)) {
1951 va_start(args, pat);
1952 vwarner(err, pat, &args);
1958 Perl_warner(pTHX_ U32 err, const char* pat,...)
1961 PERL_ARGS_ASSERT_WARNER;
1962 va_start(args, pat);
1963 vwarner(err, pat, &args);
1968 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1970 PERL_ARGS_ASSERT_VWARNER;
1972 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
1973 !(PL_in_eval & EVAL_KEEPERR)
1975 SV * const msv = vmess(pat, args);
1977 if (PL_parser && PL_parser->error_count) {
1981 invoke_exception_hook(msv, FALSE);
1986 Perl_vwarn(aTHX_ pat, args);
1990 /* implements the ckWARN? macros */
1993 Perl_ckwarn(pTHX_ U32 w)
1995 /* If lexical warnings have not been set, use $^W. */
1997 return PL_dowarn & G_WARN_ON;
1999 return ckwarn_common(w);
2002 /* implements the ckWARN?_d macro */
2005 Perl_ckwarn_d(pTHX_ U32 w)
2007 /* If lexical warnings have not been set then default classes warn. */
2011 return ckwarn_common(w);
2015 S_ckwarn_common(pTHX_ U32 w)
2017 if (PL_curcop->cop_warnings == pWARN_ALL)
2020 if (PL_curcop->cop_warnings == pWARN_NONE)
2023 /* Check the assumption that at least the first slot is non-zero. */
2024 assert(unpackWARN1(w));
2026 /* Check the assumption that it is valid to stop as soon as a zero slot is
2028 if (!unpackWARN2(w)) {
2029 assert(!unpackWARN3(w));
2030 assert(!unpackWARN4(w));
2031 } else if (!unpackWARN3(w)) {
2032 assert(!unpackWARN4(w));
2035 /* Right, dealt with all the special cases, which are implemented as non-
2036 pointers, so there is a pointer to a real warnings mask. */
2038 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2040 } while (w >>= WARNshift);
2045 /* Set buffer=NULL to get a new one. */
2047 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2049 const MEM_SIZE len_wanted =
2050 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2051 PERL_UNUSED_CONTEXT;
2052 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2055 (specialWARN(buffer) ?
2056 PerlMemShared_malloc(len_wanted) :
2057 PerlMemShared_realloc(buffer, len_wanted));
2059 Copy(bits, (buffer + 1), size, char);
2060 if (size < WARNsize)
2061 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2065 /* since we've already done strlen() for both nam and val
2066 * we can use that info to make things faster than
2067 * sprintf(s, "%s=%s", nam, val)
2069 #define my_setenv_format(s, nam, nlen, val, vlen) \
2070 Copy(nam, s, nlen, char); \
2072 Copy(val, s+(nlen+1), vlen, char); \
2073 *(s+(nlen+1+vlen)) = '\0'
2077 #ifdef USE_ENVIRON_ARRAY
2078 /* NB: VMS' my_setenv() is in vms.c */
2080 /* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
2081 * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
2082 * testing for HAS UNSETENV is sufficient.
2084 # if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2085 # define MY_HAS_SETENV
2088 /* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
2089 * 'current' is non-null, with up to three sizes that are added together.
2090 * It handles integer overflow.
2092 # ifndef MY_HAS_SETENV
2094 S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
2097 Size_t sl, l = l1 + l2;
2109 ? safesysrealloc(current, sl)
2110 : safesysmalloc(sl);
2115 croak_memory_wrap();
2120 # if !defined(WIN32) && !defined(NETWARE)
2123 =for apidoc my_setenv
2125 A wrapper for the C library L<setenv(3)>. Don't use the latter, as the perl
2126 version has desirable safeguards
2132 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2134 # ifdef __amigaos4__
2135 amigaos4_obtain_environ(__FUNCTION__);
2138 # ifdef USE_ITHREADS
2139 /* only parent thread can modify process environment, so no need to use a
2141 if (PL_curinterp == aTHX)
2145 # ifndef PERL_USE_SAFE_PUTENV
2146 if (!PL_use_safe_putenv) {
2147 /* most putenv()s leak, so we manipulate environ directly */
2149 Size_t vlen, nlen = strlen(nam);
2151 /* where does it go? */
2152 for (i = 0; environ[i]; i++) {
2153 if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
2157 if (environ == PL_origenviron) { /* need we copy environment? */
2162 while (environ[max])
2165 /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
2166 tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
2168 for (j=0; j<max; j++) { /* copy environment */
2169 const Size_t len = strlen(environ[j]);
2170 tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
2171 Copy(environ[j], tmpenv[j], len+1, char);
2175 environ = tmpenv; /* tell exec where it is now */
2179 safesysfree(environ[i]);
2180 while (environ[i]) {
2181 environ[i] = environ[i+1];
2184 # ifdef __amigaos4__
2191 if (!environ[i]) { /* does not exist yet */
2192 environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
2193 environ[i+1] = NULL; /* make sure it's null terminated */
2196 safesysfree(environ[i]);
2200 environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
2201 /* all that work just for this */
2202 my_setenv_format(environ[i], nam, nlen, val, vlen);
2206 # endif /* !PERL_USE_SAFE_PUTENV */
2208 # ifdef MY_HAS_SETENV
2209 # if defined(HAS_UNSETENV)
2211 (void)unsetenv(nam);
2213 (void)setenv(nam, val, 1);
2215 # else /* ! HAS_UNSETENV */
2216 (void)setenv(nam, val, 1);
2217 # endif /* HAS_UNSETENV */
2219 # elif defined(HAS_UNSETENV)
2222 if (environ) /* old glibc can crash with null environ */
2223 (void)unsetenv(nam);
2225 const Size_t nlen = strlen(nam);
2226 const Size_t vlen = strlen(val);
2227 char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
2228 my_setenv_format(new_env, nam, nlen, val, vlen);
2229 (void)putenv(new_env);
2232 # else /* ! HAS_UNSETENV */
2235 const Size_t nlen = strlen(nam);
2241 new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
2242 /* all that work just for this */
2243 my_setenv_format(new_env, nam, nlen, val, vlen);
2244 (void)putenv(new_env);
2246 # endif /* MY_HAS_SETENV */
2248 # ifndef PERL_USE_SAFE_PUTENV
2253 # ifdef __amigaos4__
2255 amigaos4_release_environ(__FUNCTION__);
2259 # else /* WIN32 || NETWARE */
2262 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2265 const Size_t nlen = strlen(nam);
2272 envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
2273 my_setenv_format(envstr, nam, nlen, val, vlen);
2274 (void)PerlEnv_putenv(envstr);
2275 safesysfree(envstr);
2278 # endif /* WIN32 || NETWARE */
2280 #endif /* USE_ENVIRON_ARRAY */
2285 #ifdef UNLINK_ALL_VERSIONS
2287 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2291 PERL_ARGS_ASSERT_UNLNK;
2293 while (PerlLIO_unlink(f) >= 0)
2295 return retries ? 0 : -1;
2300 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2302 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2310 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2312 PERL_FLUSHALL_FOR_CHILD;
2313 This = (*mode == 'w');
2317 taint_proper("Insecure %s%s", "EXEC");
2319 if (PerlProc_pipe_cloexec(p) < 0)
2321 /* Try for another pipe pair for error return */
2322 if (PerlProc_pipe_cloexec(pp) >= 0)
2324 while ((pid = PerlProc_fork()) < 0) {
2325 if (errno != EAGAIN) {
2326 PerlLIO_close(p[This]);
2327 PerlLIO_close(p[that]);
2329 PerlLIO_close(pp[0]);
2330 PerlLIO_close(pp[1]);
2334 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2343 /* Close parent's end of error status pipe (if any) */
2345 PerlLIO_close(pp[0]);
2346 /* Now dup our end of _the_ pipe to right position */
2347 if (p[THIS] != (*mode == 'r')) {
2348 PerlLIO_dup2(p[THIS], *mode == 'r');
2349 PerlLIO_close(p[THIS]);
2350 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2351 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2354 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
2355 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2357 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2358 /* No automatic close - do it by hand */
2365 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2371 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2378 PerlLIO_close(pp[1]);
2379 /* Keep the lower of the two fd numbers */
2380 if (p[that] < p[This]) {
2381 PerlLIO_dup2_cloexec(p[This], p[that]);
2382 PerlLIO_close(p[This]);
2386 PerlLIO_close(p[that]); /* close child's end of pipe */
2388 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2389 SvUPGRADE(sv,SVt_IV);
2391 PL_forkprocess = pid;
2392 /* If we managed to get status pipe check for exec fail */
2393 if (did_pipes && pid > 0) {
2395 unsigned read_total = 0;
2397 while (read_total < sizeof(int)) {
2398 const SSize_t n1 = PerlLIO_read(pp[0],
2399 (void*)(((char*)&errkid)+read_total),
2400 (sizeof(int)) - read_total);
2405 PerlLIO_close(pp[0]);
2407 if (read_total) { /* Error */
2409 PerlLIO_close(p[This]);
2410 if (read_total != sizeof(int))
2411 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
2413 pid2 = wait4pid(pid, &status, 0);
2414 } while (pid2 == -1 && errno == EINTR);
2415 errno = errkid; /* Propagate errno from kid */
2420 PerlLIO_close(pp[0]);
2421 return PerlIO_fdopen(p[This], mode);
2423 # if defined(OS2) /* Same, without fork()ing and all extra overhead... */
2424 return my_syspopen4(aTHX_ NULL, mode, n, args);
2425 # elif defined(WIN32)
2426 return win32_popenlist(mode, n, args);
2428 Perl_croak(aTHX_ "List form of piped open not implemented");
2429 return (PerlIO *) NULL;
2434 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2435 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2437 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2443 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2447 PERL_ARGS_ASSERT_MY_POPEN;
2449 PERL_FLUSHALL_FOR_CHILD;
2452 return my_syspopen(aTHX_ cmd,mode);
2455 This = (*mode == 'w');
2457 if (doexec && TAINTING_get) {
2459 taint_proper("Insecure %s%s", "EXEC");
2461 if (PerlProc_pipe_cloexec(p) < 0)
2463 if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
2465 while ((pid = PerlProc_fork()) < 0) {
2466 if (errno != EAGAIN) {
2467 PerlLIO_close(p[This]);
2468 PerlLIO_close(p[that]);
2470 PerlLIO_close(pp[0]);
2471 PerlLIO_close(pp[1]);
2474 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2477 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2487 PerlLIO_close(pp[0]);
2488 if (p[THIS] != (*mode == 'r')) {
2489 PerlLIO_dup2(p[THIS], *mode == 'r');
2490 PerlLIO_close(p[THIS]);
2491 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2492 PerlLIO_close(p[THAT]);
2495 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
2496 PerlLIO_close(p[THAT]);
2500 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2507 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2512 /* may or may not use the shell */
2513 do_exec3(cmd, pp[1], did_pipes);
2516 #endif /* defined OS2 */
2518 #ifdef PERLIO_USING_CRLF
2519 /* Since we circumvent IO layers when we manipulate low-level
2520 filedescriptors directly, need to manually switch to the
2521 default, binary, low-level mode; see PerlIOBuf_open(). */
2522 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2525 #ifdef PERL_USES_PL_PIDSTATUS
2526 hv_clear(PL_pidstatus); /* we have no children */
2533 PerlLIO_close(pp[1]);
2534 if (p[that] < p[This]) {
2535 PerlLIO_dup2_cloexec(p[This], p[that]);
2536 PerlLIO_close(p[This]);
2540 PerlLIO_close(p[that]);
2542 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2543 SvUPGRADE(sv,SVt_IV);
2545 PL_forkprocess = pid;
2546 if (did_pipes && pid > 0) {
2550 while (n < sizeof(int)) {
2551 const SSize_t n1 = PerlLIO_read(pp[0],
2552 (void*)(((char*)&errkid)+n),
2558 PerlLIO_close(pp[0]);
2560 if (n) { /* Error */
2562 PerlLIO_close(p[This]);
2563 if (n != sizeof(int))
2564 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2566 pid2 = wait4pid(pid, &status, 0);
2567 } while (pid2 == -1 && errno == EINTR);
2568 errno = errkid; /* Propagate errno from kid */
2573 PerlLIO_close(pp[0]);
2574 return PerlIO_fdopen(p[This], mode);
2576 #elif defined(DJGPP)
2577 FILE *djgpp_popen();
2579 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2581 PERL_FLUSHALL_FOR_CHILD;
2582 /* Call system's popen() to get a FILE *, then import it.
2583 used 0 for 2nd parameter to PerlIO_importFILE;
2586 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2588 #elif defined(__LIBCATAMOUNT__)
2590 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2595 #endif /* !DOSISH */
2597 /* this is called in parent before the fork() */
2599 Perl_atfork_lock(void)
2600 #if defined(USE_ITHREADS)
2602 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2605 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2607 PERL_TSA_ACQUIRE(PL_op_mutex)
2610 #if defined(USE_ITHREADS)
2611 /* locks must be held in locking order (if any) */
2613 MUTEX_LOCK(&PL_perlio_mutex);
2616 MUTEX_LOCK(&PL_malloc_mutex);
2622 /* this is called in both parent and child after the fork() */
2624 Perl_atfork_unlock(void)
2625 #if defined(USE_ITHREADS)
2627 PERL_TSA_RELEASE(PL_perlio_mutex)
2630 PERL_TSA_RELEASE(PL_malloc_mutex)
2632 PERL_TSA_RELEASE(PL_op_mutex)
2635 #if defined(USE_ITHREADS)
2636 /* locks must be released in same order as in atfork_lock() */
2638 MUTEX_UNLOCK(&PL_perlio_mutex);
2641 MUTEX_UNLOCK(&PL_malloc_mutex);
2650 #if defined(HAS_FORK)
2652 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2657 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2658 * handlers elsewhere in the code */
2662 #elif defined(__amigaos4__)
2663 return amigaos_fork();
2665 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2666 Perl_croak_nocontext("fork() not available");
2668 #endif /* HAS_FORK */
2673 dup2(int oldfd, int newfd)
2675 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2678 PerlLIO_close(newfd);
2679 return fcntl(oldfd, F_DUPFD, newfd);
2681 #define DUP2_MAX_FDS 256
2682 int fdtmp[DUP2_MAX_FDS];
2688 PerlLIO_close(newfd);
2689 /* good enough for low fd's... */
2690 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2691 if (fdx >= DUP2_MAX_FDS) {
2699 PerlLIO_close(fdtmp[--fdx]);
2706 #ifdef HAS_SIGACTION
2711 A wrapper for the C library L<signal(2)>. Don't use the latter, as the Perl
2712 version knows things that interact with the rest of the perl interpreter.
2718 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2720 struct sigaction act, oact;
2723 /* only "parent" interpreter can diddle signals */
2724 if (PL_curinterp != aTHX)
2725 return (Sighandler_t) SIG_ERR;
2728 act.sa_handler = handler;
2729 sigemptyset(&act.sa_mask);
2732 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2733 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2735 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2736 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2737 act.sa_flags |= SA_NOCLDWAIT;
2739 if (sigaction(signo, &act, &oact) == -1)
2740 return (Sighandler_t) SIG_ERR;
2742 return (Sighandler_t) oact.sa_handler;
2746 Perl_rsignal_state(pTHX_ int signo)
2748 struct sigaction oact;
2749 PERL_UNUSED_CONTEXT;
2751 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2752 return (Sighandler_t) SIG_ERR;
2754 return (Sighandler_t) oact.sa_handler;
2758 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2762 struct sigaction act;
2764 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2767 /* only "parent" interpreter can diddle signals */
2768 if (PL_curinterp != aTHX)
2772 act.sa_handler = handler;
2773 sigemptyset(&act.sa_mask);
2776 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2777 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2779 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2780 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2781 act.sa_flags |= SA_NOCLDWAIT;
2783 return sigaction(signo, &act, save);
2787 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2791 PERL_UNUSED_CONTEXT;
2793 /* only "parent" interpreter can diddle signals */
2794 if (PL_curinterp != aTHX)
2798 return sigaction(signo, save, (struct sigaction *)NULL);
2801 #else /* !HAS_SIGACTION */
2804 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2806 #if defined(USE_ITHREADS) && !defined(WIN32)
2807 /* only "parent" interpreter can diddle signals */
2808 if (PL_curinterp != aTHX)
2809 return (Sighandler_t) SIG_ERR;
2812 return PerlProc_signal(signo, handler);
2822 Perl_rsignal_state(pTHX_ int signo)
2824 Sighandler_t oldsig;
2826 #if defined(USE_ITHREADS) && !defined(WIN32)
2827 /* only "parent" interpreter can diddle signals */
2828 if (PL_curinterp != aTHX)
2829 return (Sighandler_t) SIG_ERR;
2833 oldsig = PerlProc_signal(signo, sig_trap);
2834 PerlProc_signal(signo, oldsig);
2836 PerlProc_kill(PerlProc_getpid(), signo);
2841 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2843 #if defined(USE_ITHREADS) && !defined(WIN32)
2844 /* only "parent" interpreter can diddle signals */
2845 if (PL_curinterp != aTHX)
2848 *save = PerlProc_signal(signo, handler);
2849 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2853 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2855 #if defined(USE_ITHREADS) && !defined(WIN32)
2856 /* only "parent" interpreter can diddle signals */
2857 if (PL_curinterp != aTHX)
2860 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2863 #endif /* !HAS_SIGACTION */
2864 #endif /* !PERL_MICRO */
2866 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2867 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2869 Perl_my_pclose(pTHX_ PerlIO *ptr)
2877 const int fd = PerlIO_fileno(ptr);
2880 svp = av_fetch(PL_fdpid,fd,TRUE);
2881 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2885 #if defined(USE_PERLIO)
2886 /* Find out whether the refcount is low enough for us to wait for the
2887 child proc without blocking. */
2888 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2890 should_wait = pid > 0;
2894 if (pid == -1) { /* Opened by popen. */
2895 return my_syspclose(ptr);
2898 close_failed = (PerlIO_close(ptr) == EOF);
2900 if (should_wait) do {
2901 pid2 = wait4pid(pid, &status, 0);
2902 } while (pid2 == -1 && errno == EINTR);
2909 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2913 #elif defined(__LIBCATAMOUNT__)
2915 Perl_my_pclose(pTHX_ PerlIO *ptr)
2919 #endif /* !DOSISH */
2921 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2923 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2926 PERL_ARGS_ASSERT_WAIT4PID;
2927 #ifdef PERL_USES_PL_PIDSTATUS
2929 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2930 waitpid() nor wait4() is available, or on OS/2, which
2931 doesn't appear to support waiting for a progress group
2932 member, so we can only treat a 0 pid as an unknown child.
2939 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2940 pid, rather than a string form. */
2941 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2942 if (svp && *svp != &PL_sv_undef) {
2943 *statusp = SvIVX(*svp);
2944 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2952 hv_iterinit(PL_pidstatus);
2953 if ((entry = hv_iternext(PL_pidstatus))) {
2954 SV * const sv = hv_iterval(PL_pidstatus,entry);
2956 const char * const spid = hv_iterkey(entry,&len);
2958 assert (len == sizeof(Pid_t));
2959 memcpy((char *)&pid, spid, len);
2960 *statusp = SvIVX(sv);
2961 /* The hash iterator is currently on this entry, so simply
2962 calling hv_delete would trigger the lazy delete, which on
2963 aggregate does more work, because next call to hv_iterinit()
2964 would spot the flag, and have to call the delete routine,
2965 while in the meantime any new entries can't re-use that
2967 hv_iterinit(PL_pidstatus);
2968 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2975 # ifdef HAS_WAITPID_RUNTIME
2976 if (!HAS_WAITPID_RUNTIME)
2979 result = PerlProc_waitpid(pid,statusp,flags);
2982 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2983 result = wait4(pid,statusp,flags,NULL);
2986 #ifdef PERL_USES_PL_PIDSTATUS
2987 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2992 Perl_croak(aTHX_ "Can't do waitpid with flags");
2994 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2995 pidgone(result,*statusp);
3001 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3004 if (result < 0 && errno == EINTR) {
3006 errno = EINTR; /* reset in case a signal handler changed $! */
3010 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3012 #ifdef PERL_USES_PL_PIDSTATUS
3014 S_pidgone(pTHX_ Pid_t pid, int status)
3018 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3019 SvUPGRADE(sv,SVt_IV);
3020 SvIV_set(sv, status);
3028 int /* Cannot prototype with I32
3030 my_syspclose(PerlIO *ptr)
3033 Perl_my_pclose(pTHX_ PerlIO *ptr)
3036 /* Needs work for PerlIO ! */
3037 FILE * const f = PerlIO_findFILE(ptr);
3038 const I32 result = pclose(f);
3039 PerlIO_releaseFILE(ptr,f);
3047 Perl_my_pclose(pTHX_ PerlIO *ptr)
3049 /* Needs work for PerlIO ! */
3050 FILE * const f = PerlIO_findFILE(ptr);
3051 I32 result = djgpp_pclose(f);
3052 result = (result << 8) & 0xff00;
3053 PerlIO_releaseFILE(ptr,f);
3058 #define PERL_REPEATCPY_LINEAR 4
3060 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3062 PERL_ARGS_ASSERT_REPEATCPY;
3067 croak_memory_wrap();
3070 memset(to, *from, count);
3073 IV items, linear, half;
3075 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3076 for (items = 0; items < linear; ++items) {
3077 const char *q = from;
3079 for (todo = len; todo > 0; todo--)
3084 while (items <= half) {
3085 IV size = items * len;
3086 memcpy(p, to, size);
3092 memcpy(p, to, (count - items) * len);
3098 Perl_same_dirent(pTHX_ const char *a, const char *b)
3100 char *fa = strrchr(a,'/');
3101 char *fb = strrchr(b,'/');
3104 SV * const tmpsv = sv_newmortal();
3106 PERL_ARGS_ASSERT_SAME_DIRENT;
3119 sv_setpvs(tmpsv, ".");
3121 sv_setpvn(tmpsv, a, fa - a);
3122 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3125 sv_setpvs(tmpsv, ".");
3127 sv_setpvn(tmpsv, b, fb - b);
3128 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3130 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3131 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3133 #endif /* !HAS_RENAME */
3136 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3137 const char *const *const search_ext, I32 flags)
3139 const char *xfound = NULL;
3140 char *xfailed = NULL;
3141 char tmpbuf[MAXPATHLEN];
3146 #if defined(DOSISH) && !defined(OS2)
3147 # define SEARCH_EXTS ".bat", ".cmd", NULL
3148 # define MAX_EXT_LEN 4
3151 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3152 # define MAX_EXT_LEN 4
3155 # define SEARCH_EXTS ".pl", ".com", NULL
3156 # define MAX_EXT_LEN 4
3158 /* additional extensions to try in each dir if scriptname not found */
3160 static const char *const exts[] = { SEARCH_EXTS };
3161 const char *const *const ext = search_ext ? search_ext : exts;
3162 int extidx = 0, i = 0;
3163 const char *curext = NULL;
3165 PERL_UNUSED_ARG(search_ext);
3166 # define MAX_EXT_LEN 0
3169 PERL_ARGS_ASSERT_FIND_SCRIPT;
3172 * If dosearch is true and if scriptname does not contain path
3173 * delimiters, search the PATH for scriptname.
3175 * If SEARCH_EXTS is also defined, will look for each
3176 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3177 * while searching the PATH.
3179 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3180 * proceeds as follows:
3181 * If DOSISH or VMSISH:
3182 * + look for ./scriptname{,.foo,.bar}
3183 * + search the PATH for scriptname{,.foo,.bar}
3186 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3187 * this will not look in '.' if it's not in the PATH)
3192 # ifdef ALWAYS_DEFTYPES
3193 len = strlen(scriptname);
3194 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3195 int idx = 0, deftypes = 1;
3198 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3201 int idx = 0, deftypes = 1;
3204 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3206 /* The first time through, just add SEARCH_EXTS to whatever we
3207 * already have, so we can check for default file types. */
3209 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3216 if ((strlen(tmpbuf) + strlen(scriptname)
3217 + MAX_EXT_LEN) >= sizeof tmpbuf)
3218 continue; /* don't search dir with too-long name */
3219 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3223 if (strEQ(scriptname, "-"))
3225 if (dosearch) { /* Look in '.' first. */
3226 const char *cur = scriptname;
3228 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3230 if (strEQ(ext[i++],curext)) {
3231 extidx = -1; /* already has an ext */
3236 DEBUG_p(PerlIO_printf(Perl_debug_log,
3237 "Looking for %s\n",cur));
3240 if (PerlLIO_stat(cur,&statbuf) >= 0
3241 && !S_ISDIR(statbuf.st_mode)) {
3250 if (cur == scriptname) {
3251 len = strlen(scriptname);
3252 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3254 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3257 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3258 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3263 if (dosearch && !strchr(scriptname, '/')
3265 && !strchr(scriptname, '\\')
3267 && (s = PerlEnv_getenv("PATH")))
3271 bufend = s + strlen(s);
3272 while (s < bufend) {
3276 && *s != ';'; len++, s++) {
3277 if (len < sizeof tmpbuf)
3280 if (len < sizeof tmpbuf)
3283 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3288 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3289 continue; /* don't search dir with too-long name */
3292 && tmpbuf[len - 1] != '/'
3293 && tmpbuf[len - 1] != '\\'
3296 tmpbuf[len++] = '/';
3297 if (len == 2 && tmpbuf[0] == '.')
3299 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3303 len = strlen(tmpbuf);
3304 if (extidx > 0) /* reset after previous loop */
3308 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3309 retval = PerlLIO_stat(tmpbuf,&statbuf);
3310 if (S_ISDIR(statbuf.st_mode)) {
3314 } while ( retval < 0 /* not there */
3315 && extidx>=0 && ext[extidx] /* try an extension? */
3316 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3321 if (S_ISREG(statbuf.st_mode)
3322 && cando(S_IRUSR,TRUE,&statbuf)
3323 #if !defined(DOSISH)
3324 && cando(S_IXUSR,TRUE,&statbuf)
3328 xfound = tmpbuf; /* bingo! */
3332 xfailed = savepv(tmpbuf);
3337 if (!xfound && !seen_dot && !xfailed &&
3338 (PerlLIO_stat(scriptname,&statbuf) < 0
3339 || S_ISDIR(statbuf.st_mode)))
3341 seen_dot = 1; /* Disable message. */
3346 if (flags & 1) { /* do or die? */
3347 /* diag_listed_as: Can't execute %s */
3348 Perl_croak(aTHX_ "Can't %s %s%s%s",
3349 (xfailed ? "execute" : "find"),
3350 (xfailed ? xfailed : scriptname),
3351 (xfailed ? "" : " on PATH"),
3352 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3357 scriptname = xfound;
3359 return (scriptname ? savepv(scriptname) : NULL);
3362 #ifndef PERL_GET_CONTEXT_DEFINED
3365 Perl_get_context(void)
3367 #if defined(USE_ITHREADS)
3368 # ifdef OLD_PTHREADS_API
3370 int error = pthread_getspecific(PL_thr_key, &t);
3372 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3374 # elif defined(I_MACH_CTHREADS)
3375 return (void*)cthread_data(cthread_self());
3377 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3385 Perl_set_context(void *t)
3387 #if defined(USE_ITHREADS)
3389 PERL_ARGS_ASSERT_SET_CONTEXT;
3390 #if defined(USE_ITHREADS)
3391 # ifdef I_MACH_CTHREADS
3392 cthread_set_data(cthread_self(), t);
3395 const int error = pthread_setspecific(PL_thr_key, t);
3397 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3405 #endif /* !PERL_GET_CONTEXT_DEFINED */
3408 Perl_get_op_names(pTHX)
3410 PERL_UNUSED_CONTEXT;
3411 return (char **)PL_op_name;
3415 Perl_get_op_descs(pTHX)
3417 PERL_UNUSED_CONTEXT;
3418 return (char **)PL_op_desc;
3422 Perl_get_no_modify(pTHX)
3424 PERL_UNUSED_CONTEXT;
3425 return PL_no_modify;
3429 Perl_get_opargs(pTHX)
3431 PERL_UNUSED_CONTEXT;
3432 return (U32 *)PL_opargs;
3436 Perl_get_ppaddr(pTHX)
3438 PERL_UNUSED_CONTEXT;
3439 return (PPADDR_t*)PL_ppaddr;
3442 #ifndef HAS_GETENV_LEN
3444 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3446 char * const env_trans = PerlEnv_getenv(env_elem);
3447 PERL_UNUSED_CONTEXT;
3448 PERL_ARGS_ASSERT_GETENV_LEN;
3450 *len = strlen(env_trans);
3457 Perl_get_vtbl(pTHX_ int vtbl_id)
3459 PERL_UNUSED_CONTEXT;
3461 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3462 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3466 Perl_my_fflush_all(pTHX)
3468 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3469 return PerlIO_flush(NULL);
3471 # if defined(HAS__FWALK)
3472 extern int fflush(FILE *);
3473 /* undocumented, unprototyped, but very useful BSDism */
3474 extern void _fwalk(int (*)(FILE *));
3478 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3480 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3481 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3482 # elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3483 open_max = sysconf(_SC_OPEN_MAX);
3484 # elif defined(FOPEN_MAX)
3485 open_max = FOPEN_MAX;
3486 # elif defined(OPEN_MAX)
3487 open_max = OPEN_MAX;
3488 # elif defined(_NFILE)
3493 for (i = 0; i < open_max; i++)
3494 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3495 STDIO_STREAM_ARRAY[i]._file < open_max &&
3496 STDIO_STREAM_ARRAY[i]._flag)
3497 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3501 SETERRNO(EBADF,RMS_IFI);
3508 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3510 if (ckWARN(WARN_IO)) {
3512 = gv && (isGV_with_GP(gv))
3515 const char * const direction = have == '>' ? "out" : "in";
3517 if (name && HEK_LEN(name))
3518 Perl_warner(aTHX_ packWARN(WARN_IO),
3519 "Filehandle %" HEKf " opened only for %sput",
3520 HEKfARG(name), direction);
3522 Perl_warner(aTHX_ packWARN(WARN_IO),
3523 "Filehandle opened only for %sput", direction);
3528 Perl_report_evil_fh(pTHX_ const GV *gv)
3530 const IO *io = gv ? GvIO(gv) : NULL;
3531 const PERL_BITFIELD16 op = PL_op->op_type;
3535 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3537 warn_type = WARN_CLOSED;
3541 warn_type = WARN_UNOPENED;
3544 if (ckWARN(warn_type)) {
3546 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3547 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3548 const char * const pars =
3549 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3550 const char * const func =
3552 (op == OP_READLINE || op == OP_RCATLINE
3553 ? "readline" : /* "<HANDLE>" not nice */
3554 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3556 const char * const type =
3558 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3559 ? "socket" : "filehandle");
3560 const bool have_name = name && SvCUR(name);
3561 Perl_warner(aTHX_ packWARN(warn_type),
3562 "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3563 have_name ? " " : "",
3564 SVfARG(have_name ? name : &PL_sv_no));
3565 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3567 aTHX_ packWARN(warn_type),
3568 "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3569 func, pars, have_name ? " " : "",
3570 SVfARG(have_name ? name : &PL_sv_no)
3575 /* To workaround core dumps from the uninitialised tm_zone we get the
3576 * system to give us a reasonable struct to copy. This fix means that
3577 * strftime uses the tm_zone and tm_gmtoff values returned by
3578 * localtime(time()). That should give the desired result most of the
3579 * time. But probably not always!
3581 * This does not address tzname aspects of NETaa14816.
3586 # ifndef STRUCT_TM_HASZONE
3587 # define STRUCT_TM_HASZONE
3591 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3592 # ifndef HAS_TM_TM_ZONE
3593 # define HAS_TM_TM_ZONE
3598 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3600 #ifdef HAS_TM_TM_ZONE
3602 const struct tm* my_tm;
3603 PERL_UNUSED_CONTEXT;
3604 PERL_ARGS_ASSERT_INIT_TM;
3606 ENV_LOCALE_READ_LOCK;
3607 my_tm = localtime(&now);
3609 Copy(my_tm, ptm, 1, struct tm);
3610 ENV_LOCALE_READ_UNLOCK;
3612 PERL_UNUSED_CONTEXT;
3613 PERL_ARGS_ASSERT_INIT_TM;
3614 PERL_UNUSED_ARG(ptm);
3619 * mini_mktime - normalise struct tm values without the localtime()
3620 * semantics (and overhead) of mktime().
3623 Perl_mini_mktime(struct tm *ptm)
3627 int month, mday, year, jday;
3628 int odd_cent, odd_year;
3630 PERL_ARGS_ASSERT_MINI_MKTIME;
3632 #define DAYS_PER_YEAR 365
3633 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3634 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3635 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3636 #define SECS_PER_HOUR (60*60)
3637 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3638 /* parentheses deliberately absent on these two, otherwise they don't work */
3639 #define MONTH_TO_DAYS 153/5
3640 #define DAYS_TO_MONTH 5/153
3641 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3642 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3643 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3644 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3647 * Year/day algorithm notes:
3649 * With a suitable offset for numeric value of the month, one can find
3650 * an offset into the year by considering months to have 30.6 (153/5) days,
3651 * using integer arithmetic (i.e., with truncation). To avoid too much
3652 * messing about with leap days, we consider January and February to be
3653 * the 13th and 14th month of the previous year. After that transformation,
3654 * we need the month index we use to be high by 1 from 'normal human' usage,
3655 * so the month index values we use run from 4 through 15.
3657 * Given that, and the rules for the Gregorian calendar (leap years are those
3658 * divisible by 4 unless also divisible by 100, when they must be divisible
3659 * by 400 instead), we can simply calculate the number of days since some
3660 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3661 * the days we derive from our month index, and adding in the day of the
3662 * month. The value used here is not adjusted for the actual origin which
3663 * it normally would use (1 January A.D. 1), since we're not exposing it.
3664 * We're only building the value so we can turn around and get the
3665 * normalised values for the year, month, day-of-month, and day-of-year.
3667 * For going backward, we need to bias the value we're using so that we find
3668 * the right year value. (Basically, we don't want the contribution of
3669 * March 1st to the number to apply while deriving the year). Having done
3670 * that, we 'count up' the contribution to the year number by accounting for
3671 * full quadracenturies (400-year periods) with their extra leap days, plus
3672 * the contribution from full centuries (to avoid counting in the lost leap
3673 * days), plus the contribution from full quad-years (to count in the normal
3674 * leap days), plus the leftover contribution from any non-leap years.
3675 * At this point, if we were working with an actual leap day, we'll have 0
3676 * days left over. This is also true for March 1st, however. So, we have
3677 * to special-case that result, and (earlier) keep track of the 'odd'
3678 * century and year contributions. If we got 4 extra centuries in a qcent,
3679 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3680 * Otherwise, we add back in the earlier bias we removed (the 123 from
3681 * figuring in March 1st), find the month index (integer division by 30.6),
3682 * and the remainder is the day-of-month. We then have to convert back to
3683 * 'real' months (including fixing January and February from being 14/15 in
3684 * the previous year to being in the proper year). After that, to get
3685 * tm_yday, we work with the normalised year and get a new yearday value for
3686 * January 1st, which we subtract from the yearday value we had earlier,
3687 * representing the date we've re-built. This is done from January 1
3688 * because tm_yday is 0-origin.
3690 * Since POSIX time routines are only guaranteed to work for times since the
3691 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3692 * applies Gregorian calendar rules even to dates before the 16th century
3693 * doesn't bother me. Besides, you'd need cultural context for a given
3694 * date to know whether it was Julian or Gregorian calendar, and that's
3695 * outside the scope for this routine. Since we convert back based on the
3696 * same rules we used to build the yearday, you'll only get strange results
3697 * for input which needed normalising, or for the 'odd' century years which
3698 * were leap years in the Julian calendar but not in the Gregorian one.
3699 * I can live with that.
3701 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3702 * that's still outside the scope for POSIX time manipulation, so I don't
3708 year = 1900 + ptm->tm_year;
3709 month = ptm->tm_mon;
3710 mday = ptm->tm_mday;
3716 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3717 yearday += month*MONTH_TO_DAYS + mday + jday;
3719 * Note that we don't know when leap-seconds were or will be,
3720 * so we have to trust the user if we get something which looks
3721 * like a sensible leap-second. Wild values for seconds will
3722 * be rationalised, however.
3724 if ((unsigned) ptm->tm_sec <= 60) {
3731 secs += 60 * ptm->tm_min;
3732 secs += SECS_PER_HOUR * ptm->tm_hour;
3734 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3735 /* got negative remainder, but need positive time */
3736 /* back off an extra day to compensate */
3737 yearday += (secs/SECS_PER_DAY)-1;
3738 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3741 yearday += (secs/SECS_PER_DAY);
3742 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3745 else if (secs >= SECS_PER_DAY) {
3746 yearday += (secs/SECS_PER_DAY);
3747 secs %= SECS_PER_DAY;
3749 ptm->tm_hour = secs/SECS_PER_HOUR;
3750 secs %= SECS_PER_HOUR;
3751 ptm->tm_min = secs/60;
3753 ptm->tm_sec += secs;
3754 /* done with time of day effects */
3756 * The algorithm for yearday has (so far) left it high by 428.
3757 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3758 * bias it by 123 while trying to figure out what year it
3759 * really represents. Even with this tweak, the reverse
3760 * translation fails for years before A.D. 0001.
3761 * It would still fail for Feb 29, but we catch that one below.
3763 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3764 yearday -= YEAR_ADJUST;
3765 year = (yearday / DAYS_PER_QCENT) * 400;
3766 yearday %= DAYS_PER_QCENT;
3767 odd_cent = yearday / DAYS_PER_CENT;
3768 year += odd_cent * 100;
3769 yearday %= DAYS_PER_CENT;
3770 year += (yearday / DAYS_PER_QYEAR) * 4;
3771 yearday %= DAYS_PER_QYEAR;
3772 odd_year = yearday / DAYS_PER_YEAR;
3774 yearday %= DAYS_PER_YEAR;
3775 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3780 yearday += YEAR_ADJUST; /* recover March 1st crock */
3781 month = yearday*DAYS_TO_MONTH;
3782 yearday -= month*MONTH_TO_DAYS;
3783 /* recover other leap-year adjustment */
3792 ptm->tm_year = year - 1900;
3794 ptm->tm_mday = yearday;
3795 ptm->tm_mon = month;
3799 ptm->tm_mon = month - 1;
3801 /* re-build yearday based on Jan 1 to get tm_yday */
3803 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3804 yearday += 14*MONTH_TO_DAYS + 1;
3805 ptm->tm_yday = jday - yearday;
3806 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3810 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)
3814 /* strftime(), but with a different API so that the return value is a pointer
3815 * to the formatted result (which MUST be arranged to be FREED BY THE
3816 * CALLER). This allows this function to increase the buffer size as needed,
3817 * so that the caller doesn't have to worry about that.
3819 * Note that yday and wday effectively are ignored by this function, as
3820 * mini_mktime() overwrites them */
3827 PERL_ARGS_ASSERT_MY_STRFTIME;
3829 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3832 mytm.tm_hour = hour;
3833 mytm.tm_mday = mday;
3835 mytm.tm_year = year;
3836 mytm.tm_wday = wday;
3837 mytm.tm_yday = yday;
3838 mytm.tm_isdst = isdst;
3840 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3841 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3846 #ifdef HAS_TM_TM_GMTOFF
3847 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3849 #ifdef HAS_TM_TM_ZONE
3850 mytm.tm_zone = mytm2.tm_zone;
3855 Newx(buf, buflen, char);
3857 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
3858 len = strftime(buf, buflen, fmt, &mytm);
3859 GCC_DIAG_RESTORE_STMT;
3862 ** The following is needed to handle to the situation where
3863 ** tmpbuf overflows. Basically we want to allocate a buffer
3864 ** and try repeatedly. The reason why it is so complicated
3865 ** is that getting a return value of 0 from strftime can indicate
3866 ** one of the following:
3867 ** 1. buffer overflowed,
3868 ** 2. illegal conversion specifier, or
3869 ** 3. the format string specifies nothing to be returned(not
3870 ** an error). This could be because format is an empty string
3871 ** or it specifies %p that yields an empty string in some locale.
3872 ** If there is a better way to make it portable, go ahead by
3875 if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
3878 /* Possibly buf overflowed - try again with a bigger buf */
3879 const int fmtlen = strlen(fmt);
3880 int bufsize = fmtlen + buflen;
3882 Renew(buf, bufsize, char);
3885 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
3886 buflen = strftime(buf, bufsize, fmt, &mytm);
3887 GCC_DIAG_RESTORE_STMT;
3889 if (inRANGE(buflen, 1, bufsize - 1))
3891 /* heuristic to prevent out-of-memory errors */
3892 if (bufsize > 100*fmtlen) {
3898 Renew(buf, bufsize, char);
3903 Perl_croak(aTHX_ "panic: no strftime");
3909 #define SV_CWD_RETURN_UNDEF \
3913 #define SV_CWD_ISDOT(dp) \
3914 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3915 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3918 =head1 Miscellaneous Functions
3920 =for apidoc getcwd_sv
3922 Fill C<sv> with current working directory
3927 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3928 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3929 * getcwd(3) if available
3930 * Comments from the original:
3931 * This is a faster version of getcwd. It's also more dangerous
3932 * because you might chdir out of a directory that you can't chdir
3936 Perl_getcwd_sv(pTHX_ SV *sv)
3941 PERL_ARGS_ASSERT_GETCWD_SV;
3945 char buf[MAXPATHLEN];
3947 /* Some getcwd()s automatically allocate a buffer of the given
3948 * size from the heap if they are given a NULL buffer pointer.
3949 * The problem is that this behaviour is not portable. */
3950 if (getcwd(buf, sizeof(buf) - 1)) {
3955 SV_CWD_RETURN_UNDEF;
3962 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3966 SvUPGRADE(sv, SVt_PV);
3968 if (PerlLIO_lstat(".", &statbuf) < 0) {
3969 SV_CWD_RETURN_UNDEF;
3972 orig_cdev = statbuf.st_dev;
3973 orig_cino = statbuf.st_ino;
3983 if (PerlDir_chdir("..") < 0) {
3984 SV_CWD_RETURN_UNDEF;
3986 if (PerlLIO_stat(".", &statbuf) < 0) {
3987 SV_CWD_RETURN_UNDEF;
3990 cdev = statbuf.st_dev;
3991 cino = statbuf.st_ino;
3993 if (odev == cdev && oino == cino) {
3996 if (!(dir = PerlDir_open("."))) {
3997 SV_CWD_RETURN_UNDEF;
4000 while ((dp = PerlDir_read(dir)) != NULL) {
4002 namelen = dp->d_namlen;
4004 namelen = strlen(dp->d_name);
4007 if (SV_CWD_ISDOT(dp)) {
4011 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4012 SV_CWD_RETURN_UNDEF;
4015 tdev = statbuf.st_dev;
4016 tino = statbuf.st_ino;
4017 if (tino == oino && tdev == odev) {
4023 SV_CWD_RETURN_UNDEF;
4026 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4027 SV_CWD_RETURN_UNDEF;
4030 SvGROW(sv, pathlen + namelen + 1);
4034 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4037 /* prepend current directory to the front */
4039 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4040 pathlen += (namelen + 1);
4042 #ifdef VOID_CLOSEDIR
4045 if (PerlDir_close(dir) < 0) {
4046 SV_CWD_RETURN_UNDEF;
4052 SvCUR_set(sv, pathlen);
4056 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4057 SV_CWD_RETURN_UNDEF;
4060 if (PerlLIO_stat(".", &statbuf) < 0) {
4061 SV_CWD_RETURN_UNDEF;
4064 cdev = statbuf.st_dev;
4065 cino = statbuf.st_ino;
4067 if (cdev != orig_cdev || cino != orig_cino) {
4068 Perl_croak(aTHX_ "Unstable directory path, "
4069 "current directory changed unexpectedly");
4082 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4083 # define EMULATE_SOCKETPAIR_UDP
4086 #ifdef EMULATE_SOCKETPAIR_UDP
4088 S_socketpair_udp (int fd[2]) {
4090 /* Fake a datagram socketpair using UDP to localhost. */
4091 int sockets[2] = {-1, -1};
4092 struct sockaddr_in addresses[2];
4094 Sock_size_t size = sizeof(struct sockaddr_in);
4095 unsigned short port;
4098 memset(&addresses, 0, sizeof(addresses));
4101 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4102 if (sockets[i] == -1)
4103 goto tidy_up_and_fail;
4105 addresses[i].sin_family = AF_INET;
4106 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4107 addresses[i].sin_port = 0; /* kernel choses port. */
4108 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4109 sizeof(struct sockaddr_in)) == -1)
4110 goto tidy_up_and_fail;
4113 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4114 for each connect the other socket to it. */
4117 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4119 goto tidy_up_and_fail;
4120 if (size != sizeof(struct sockaddr_in))
4121 goto abort_tidy_up_and_fail;
4122 /* !1 is 0, !0 is 1 */
4123 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4124 sizeof(struct sockaddr_in)) == -1)
4125 goto tidy_up_and_fail;
4128 /* Now we have 2 sockets connected to each other. I don't trust some other
4129 process not to have already sent a packet to us (by random) so send
4130 a packet from each to the other. */
4133 /* I'm going to send my own port number. As a short.
4134 (Who knows if someone somewhere has sin_port as a bitfield and needs
4135 this routine. (I'm assuming crays have socketpair)) */
4136 port = addresses[i].sin_port;
4137 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4138 if (got != sizeof(port)) {
4140 goto tidy_up_and_fail;
4141 goto abort_tidy_up_and_fail;
4145 /* Packets sent. I don't trust them to have arrived though.
4146 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4147 connect to localhost will use a second kernel thread. In 2.6 the
4148 first thread running the connect() returns before the second completes,
4149 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4150 returns 0. Poor programs have tripped up. One poor program's authors'
4151 had a 50-1 reverse stock split. Not sure how connected these were.)
4152 So I don't trust someone not to have an unpredictable UDP stack.
4156 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4157 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4161 FD_SET((unsigned int)sockets[0], &rset);
4162 FD_SET((unsigned int)sockets[1], &rset);
4164 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4165 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4166 || !FD_ISSET(sockets[1], &rset)) {
4167 /* I hope this is portable and appropriate. */
4169 goto tidy_up_and_fail;
4170 goto abort_tidy_up_and_fail;
4174 /* And the paranoia department even now doesn't trust it to have arrive
4175 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4177 struct sockaddr_in readfrom;
4178 unsigned short buffer[2];
4183 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4184 sizeof(buffer), MSG_DONTWAIT,
4185 (struct sockaddr *) &readfrom, &size);
4187 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4189 (struct sockaddr *) &readfrom, &size);
4193 goto tidy_up_and_fail;
4194 if (got != sizeof(port)
4195 || size != sizeof(struct sockaddr_in)
4196 /* Check other socket sent us its port. */
4197 || buffer[0] != (unsigned short) addresses[!i].sin_port
4198 /* Check kernel says we got the datagram from that socket */
4199 || readfrom.sin_family != addresses[!i].sin_family
4200 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4201 || readfrom.sin_port != addresses[!i].sin_port)
4202 goto abort_tidy_up_and_fail;
4205 /* My caller (my_socketpair) has validated that this is non-NULL */
4208 /* I hereby declare this connection open. May God bless all who cross
4212 abort_tidy_up_and_fail:
4213 errno = ECONNABORTED;
4217 if (sockets[0] != -1)
4218 PerlLIO_close(sockets[0]);
4219 if (sockets[1] != -1)
4220 PerlLIO_close(sockets[1]);
4225 #endif /* EMULATE_SOCKETPAIR_UDP */
4227 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4229 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4230 /* Stevens says that family must be AF_LOCAL, protocol 0.
4231 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4236 struct sockaddr_in listen_addr;
4237 struct sockaddr_in connect_addr;
4242 || family != AF_UNIX
4245 errno = EAFNOSUPPORT;
4254 type &= ~SOCK_CLOEXEC;
4257 #ifdef EMULATE_SOCKETPAIR_UDP
4258 if (type == SOCK_DGRAM)
4259 return S_socketpair_udp(fd);
4262 aTHXa(PERL_GET_THX);
4263 listener = PerlSock_socket(AF_INET, type, 0);
4266 memset(&listen_addr, 0, sizeof(listen_addr));
4267 listen_addr.sin_family = AF_INET;
4268 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4269 listen_addr.sin_port = 0; /* kernel choses port. */
4270 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4271 sizeof(listen_addr)) == -1)
4272 goto tidy_up_and_fail;
4273 if (PerlSock_listen(listener, 1) == -1)
4274 goto tidy_up_and_fail;
4276 connector = PerlSock_socket(AF_INET, type, 0);
4277 if (connector == -1)
4278 goto tidy_up_and_fail;
4279 /* We want to find out the port number to connect to. */
4280 size = sizeof(connect_addr);
4281 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4283 goto tidy_up_and_fail;
4284 if (size != sizeof(connect_addr))
4285 goto abort_tidy_up_and_fail;
4286 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4287 sizeof(connect_addr)) == -1)
4288 goto tidy_up_and_fail;
4290 size = sizeof(listen_addr);
4291 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4294 goto tidy_up_and_fail;
4295 if (size != sizeof(listen_addr))
4296 goto abort_tidy_up_and_fail;
4297 PerlLIO_close(listener);
4298 /* Now check we are talking to ourself by matching port and host on the
4300 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4302 goto tidy_up_and_fail;
4303 if (size != sizeof(connect_addr)
4304 || listen_addr.sin_family != connect_addr.sin_family
4305 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4306 || listen_addr.sin_port != connect_addr.sin_port) {
4307 goto abort_tidy_up_and_fail;
4313 abort_tidy_up_and_fail:
4315 errno = ECONNABORTED; /* This would be the standard thing to do. */
4316 #elif defined(ECONNREFUSED)
4317 errno = ECONNREFUSED; /* some OSes might not have ECONNABORTED. */
4319 errno = ETIMEDOUT; /* Desperation time. */
4325 PerlLIO_close(listener);
4326 if (connector != -1)
4327 PerlLIO_close(connector);
4329 PerlLIO_close(acceptor);
4335 /* In any case have a stub so that there's code corresponding
4336 * to the my_socketpair in embed.fnc. */
4338 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4339 #ifdef HAS_SOCKETPAIR
4340 return socketpair(family, type, protocol, fd);
4349 =for apidoc sv_nosharing
4351 Dummy routine which "shares" an SV when there is no sharing module present.
4352 Or "locks" it. Or "unlocks" it. In other
4353 words, ignores its single SV argument.
4354 Exists to avoid test for a C<NULL> function pointer and because it could
4355 potentially warn under some level of strict-ness.
4361 Perl_sv_nosharing(pTHX_ SV *sv)
4363 PERL_UNUSED_CONTEXT;
4364 PERL_UNUSED_ARG(sv);
4369 =for apidoc sv_destroyable
4371 Dummy routine which reports that object can be destroyed when there is no
4372 sharing module present. It ignores its single SV argument, and returns
4373 'true'. Exists to avoid test for a C<NULL> function pointer and because it
4374 could potentially warn under some level of strict-ness.
4380 Perl_sv_destroyable(pTHX_ SV *sv)
4382 PERL_UNUSED_CONTEXT;
4383 PERL_UNUSED_ARG(sv);
4388 Perl_parse_unicode_opts(pTHX_ const char **popt)
4390 const char *p = *popt;
4393 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4397 const char* endptr = p + strlen(p);
4399 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4402 if (p && *p && *p != '\n' && *p != '\r') {
4404 goto the_end_of_the_opts_parser;
4406 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4410 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4416 case PERL_UNICODE_STDIN:
4417 opt |= PERL_UNICODE_STDIN_FLAG; break;
4418 case PERL_UNICODE_STDOUT:
4419 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4420 case PERL_UNICODE_STDERR:
4421 opt |= PERL_UNICODE_STDERR_FLAG; break;
4422 case PERL_UNICODE_STD:
4423 opt |= PERL_UNICODE_STD_FLAG; break;
4424 case PERL_UNICODE_IN:
4425 opt |= PERL_UNICODE_IN_FLAG; break;
4426 case PERL_UNICODE_OUT:
4427 opt |= PERL_UNICODE_OUT_FLAG; break;
4428 case PERL_UNICODE_INOUT:
4429 opt |= PERL_UNICODE_INOUT_FLAG; break;
4430 case PERL_UNICODE_LOCALE:
4431 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4432 case PERL_UNICODE_ARGV:
4433 opt |= PERL_UNICODE_ARGV_FLAG; break;
4434 case PERL_UNICODE_UTF8CACHEASSERT:
4435 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4437 if (*p != '\n' && *p != '\r') {
4438 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4441 "Unknown Unicode option letter '%c'", *p);
4448 opt = PERL_UNICODE_DEFAULT_FLAGS;
4450 the_end_of_the_opts_parser:
4452 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4453 Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4454 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4462 # include <starlet.h>
4469 * This is really just a quick hack which grabs various garbage
4470 * values. It really should be a real hash algorithm which
4471 * spreads the effect of every input bit onto every output bit,
4472 * if someone who knows about such things would bother to write it.
4473 * Might be a good idea to add that function to CORE as well.
4474 * No numbers below come from careful analysis or anything here,
4475 * except they are primes and SEED_C1 > 1E6 to get a full-width
4476 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4477 * probably be bigger too.
4480 # define SEED_C1 1000003
4481 #define SEED_C4 73819
4483 # define SEED_C1 25747
4484 #define SEED_C4 20639
4488 #define SEED_C5 26107
4490 #ifndef PERL_NO_DEV_RANDOM
4494 #ifdef HAS_GETTIMEOFDAY
4495 struct timeval when;
4500 /* This test is an escape hatch, this symbol isn't set by Configure. */
4501 #ifndef PERL_NO_DEV_RANDOM
4502 #ifndef PERL_RANDOM_DEVICE
4503 /* /dev/random isn't used by default because reads from it will block
4504 * if there isn't enough entropy available. You can compile with
4505 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4506 * is enough real entropy to fill the seed. */
4507 # ifdef __amigaos4__
4508 # define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4510 # define PERL_RANDOM_DEVICE "/dev/urandom"
4513 fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
4515 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4523 #ifdef HAS_GETTIMEOFDAY
4524 PerlProc_gettimeofday(&when,NULL);
4525 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4528 u = (U32)SEED_C1 * when;
4530 u += SEED_C3 * (U32)PerlProc_getpid();
4531 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4532 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4533 u += SEED_C5 * (U32)PTR2UV(&when);
4539 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4541 #ifndef NO_PERL_HASH_ENV
4546 PERL_ARGS_ASSERT_GET_HASH_SEED;
4548 #ifndef NO_PERL_HASH_ENV
4549 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4553 /* ignore leading spaces */
4554 while (isSPACE(*env_pv))
4556 # ifdef USE_PERL_PERTURB_KEYS
4557 /* if they set it to "0" we disable key traversal randomization completely */
4558 if (strEQ(env_pv,"0")) {
4559 PL_hash_rand_bits_enabled= 0;
4561 /* otherwise switch to deterministic mode */
4562 PL_hash_rand_bits_enabled= 2;
4565 /* ignore a leading 0x... if it is there */
4566 if (env_pv[0] == '0' && env_pv[1] == 'x')
4569 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4570 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4571 if ( isXDIGIT(*env_pv)) {
4572 seed_buffer[i] |= READ_XDIGIT(env_pv);
4575 while (isSPACE(*env_pv))
4578 if (*env_pv && !isXDIGIT(*env_pv)) {
4579 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4581 /* should we check for unparsed crap? */
4582 /* should we warn about unused hex? */
4583 /* should we warn about insufficient hex? */
4586 #endif /* NO_PERL_HASH_ENV */
4588 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4589 seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
4592 #ifdef USE_PERL_PERTURB_KEYS
4593 { /* initialize PL_hash_rand_bits from the hash seed.
4594 * This value is highly volatile, it is updated every
4595 * hash insert, and is used as part of hash bucket chain
4596 * randomization and hash iterator randomization. */
4597 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4598 for( i = 0; i < sizeof(UV) ; i++ ) {
4599 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4600 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4603 # ifndef NO_PERL_HASH_ENV
4604 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4606 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4607 PL_hash_rand_bits_enabled= 0;
4608 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4609 PL_hash_rand_bits_enabled= 1;
4610 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4611 PL_hash_rand_bits_enabled= 2;
4613 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4622 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4623 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4624 * given, and you supply your own implementation.
4626 * The default implementation reads a single env var, PERL_MEM_LOG,
4627 * expecting one or more of the following:
4629 * \d+ - fd fd to write to : must be 1st (grok_atoUV)
4630 * 'm' - memlog was PERL_MEM_LOG=1
4631 * 's' - svlog was PERL_SV_LOG=1
4632 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
4634 * This makes the logger controllable enough that it can reasonably be
4635 * added to the system perl.
4638 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4639 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4641 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4643 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4644 * writes to. In the default logger, this is settable at runtime.
4646 #ifndef PERL_MEM_LOG_FD
4647 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4650 #ifndef PERL_MEM_LOG_NOIMPL
4652 # ifdef DEBUG_LEAKING_SCALARS
4653 # define SV_LOG_SERIAL_FMT " [%lu]"
4654 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
4656 # define SV_LOG_SERIAL_FMT
4657 # define _SV_LOG_SERIAL_ARG(sv)
4661 S_mem_log_common(enum mem_log_type mlt, const UV n,
4662 const UV typesize, const char *type_name, const SV *sv,
4663 Malloc_t oldalloc, Malloc_t newalloc,
4664 const char *filename, const int linenumber,
4665 const char *funcname)
4669 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4671 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4674 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4676 /* We can't use SVs or PerlIO for obvious reasons,
4677 * so we'll use stdio and low-level IO instead. */
4678 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4680 # ifdef HAS_GETTIMEOFDAY
4681 # define MEM_LOG_TIME_FMT "%10d.%06d: "
4682 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
4684 gettimeofday(&tv, 0);
4686 # define MEM_LOG_TIME_FMT "%10d: "
4687 # define MEM_LOG_TIME_ARG (int)when
4691 /* If there are other OS specific ways of hires time than
4692 * gettimeofday() (see dist/Time-HiRes), the easiest way is
4693 * probably that they would be used to fill in the struct
4697 const char* endptr = pmlenv + strlen(pmlenv);
4700 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4701 && uv && uv <= PERL_INT_MAX
4705 fd = PERL_MEM_LOG_FD;
4708 if (strchr(pmlenv, 't')) {
4709 len = my_snprintf(buf, sizeof(buf),
4710 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4711 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4715 len = my_snprintf(buf, sizeof(buf),
4716 "alloc: %s:%d:%s: %" IVdf " %" UVuf
4717 " %s = %" IVdf ": %" UVxf "\n",
4718 filename, linenumber, funcname, n, typesize,
4719 type_name, n * typesize, PTR2UV(newalloc));
4722 len = my_snprintf(buf, sizeof(buf),
4723 "realloc: %s:%d:%s: %" IVdf " %" UVuf
4724 " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
4725 filename, linenumber, funcname, n, typesize,
4726 type_name, n * typesize, PTR2UV(oldalloc),
4730 len = my_snprintf(buf, sizeof(buf),
4731 "free: %s:%d:%s: %" UVxf "\n",
4732 filename, linenumber, funcname,
4737 len = my_snprintf(buf, sizeof(buf),
4738 "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
4739 mlt == MLT_NEW_SV ? "new" : "del",
4740 filename, linenumber, funcname,
4741 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4746 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4750 #endif /* !PERL_MEM_LOG_NOIMPL */
4752 #ifndef PERL_MEM_LOG_NOIMPL
4754 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
4755 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
4757 /* this is suboptimal, but bug compatible. User is providing their
4758 own implementation, but is getting these functions anyway, and they
4759 do nothing. But _NOIMPL users should be able to cope or fix */
4761 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
4762 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
4766 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
4768 const char *filename, const int linenumber,
4769 const char *funcname)
4771 PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
4773 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
4774 NULL, NULL, newalloc,
4775 filename, linenumber, funcname);
4780 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
4781 Malloc_t oldalloc, Malloc_t newalloc,
4782 const char *filename, const int linenumber,
4783 const char *funcname)
4785 PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
4787 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
4788 NULL, oldalloc, newalloc,
4789 filename, linenumber, funcname);
4794 Perl_mem_log_free(Malloc_t oldalloc,
4795 const char *filename, const int linenumber,
4796 const char *funcname)
4798 PERL_ARGS_ASSERT_MEM_LOG_FREE;
4800 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
4801 filename, linenumber, funcname);
4806 Perl_mem_log_new_sv(const SV *sv,
4807 const char *filename, const int linenumber,
4808 const char *funcname)
4810 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
4811 filename, linenumber, funcname);
4815 Perl_mem_log_del_sv(const SV *sv,
4816 const char *filename, const int linenumber,
4817 const char *funcname)
4819 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
4820 filename, linenumber, funcname);
4823 #endif /* PERL_MEM_LOG */
4826 =for apidoc quadmath_format_valid
4828 C<quadmath_snprintf()> is very strict about its C<format> string and will
4829 fail, returning -1, if the format is invalid. It accepts exactly
4832 C<quadmath_format_valid()> checks that the intended single spec looks
4833 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
4834 and has C<Q> before it. This is not a full "printf syntax check",
4837 Returns true if it is valid, false if not.
4839 See also L</quadmath_format_needed>.
4845 Perl_quadmath_format_valid(const char* format)
4849 PERL_ARGS_ASSERT_QUADMATH_FORMAT_VALID;
4851 if (format[0] != '%' || strchr(format + 1, '%'))
4853 len = strlen(format);
4854 /* minimum length three: %Qg */
4855 if (len < 3 || memCHRs("efgaEFGA", format[len - 1]) == NULL)
4857 if (format[len - 2] != 'Q')
4864 =for apidoc quadmath_format_needed
4866 C<quadmath_format_needed()> returns true if the C<format> string seems to
4867 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
4868 or returns false otherwise.
4870 The format specifier detection is not complete printf-syntax detection,
4871 but it should catch most common cases.
4873 If true is returned, those arguments B<should> in theory be processed
4874 with C<quadmath_snprintf()>, but in case there is more than one such
4875 format specifier (see L</quadmath_format_valid>), and if there is
4876 anything else beyond that one (even just a single byte), they
4877 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
4878 accepting only one format spec, and nothing else.
4879 In this case, the code should probably fail.
4885 Perl_quadmath_format_needed(const char* format)
4887 const char *p = format;
4890 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
4892 while ((q = strchr(p, '%'))) {
4894 if (*q == '+') /* plus */
4896 if (*q == '#') /* alt */
4898 if (*q == '*') /* width */
4902 while (isDIGIT(*q)) q++;
4905 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
4910 while (isDIGIT(*q)) q++;
4912 if (memCHRs("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
4921 =for apidoc my_snprintf
4923 The C library C<snprintf> functionality, if available and
4924 standards-compliant (uses C<vsnprintf>, actually). However, if the
4925 C<vsnprintf> is not available, will unfortunately use the unsafe
4926 C<vsprintf> which can overrun the buffer (there is an overrun check,
4927 but that may be too late). Consider using C<sv_vcatpvf> instead, or
4928 getting C<vsnprintf>.
4933 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
4937 PERL_ARGS_ASSERT_MY_SNPRINTF;
4938 #ifndef HAS_VSNPRINTF
4939 PERL_UNUSED_VAR(len);
4941 va_start(ap, format);
4944 bool quadmath_valid = FALSE;
4945 if (quadmath_format_valid(format)) {
4946 /* If the format looked promising, use it as quadmath. */
4947 retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
4949 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
4951 quadmath_valid = TRUE;
4953 /* quadmath_format_single() will return false for example for
4954 * "foo = %g", or simply "%g". We could handle the %g by
4955 * using quadmath for the NV args. More complex cases of
4956 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
4957 * quadmath-valid but has stuff in front).
4959 * Handling the "Q-less" cases right would require walking
4960 * through the va_list and rewriting the format, calling
4961 * quadmath for the NVs, building a new va_list, and then
4962 * letting vsnprintf/vsprintf to take care of the other
4963 * arguments. This may be doable.
4965 * We do not attempt that now. But for paranoia, we here try
4966 * to detect some common (but not all) cases where the
4967 * "Q-less" %[efgaEFGA] formats are present, and die if
4968 * detected. This doesn't fix the problem, but it stops the
4969 * vsnprintf/vsprintf pulling doubles off the va_list when
4970 * __float128 NVs should be pulled off instead.
4972 * If quadmath_format_needed() returns false, we are reasonably
4973 * certain that we can call vnsprintf() or vsprintf() safely. */
4974 if (!quadmath_valid && quadmath_format_needed(format))
4975 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
4980 #ifdef HAS_VSNPRINTF
4981 retval = vsnprintf(buffer, len, format, ap);
4983 retval = vsprintf(buffer, format, ap);
4986 /* vsprintf() shows failure with < 0 */
4988 #ifdef HAS_VSNPRINTF
4989 /* vsnprintf() shows failure with >= len */
4991 (len > 0 && (Size_t)retval >= len)
4994 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
4999 =for apidoc my_vsnprintf
5001 The C library C<vsnprintf> if available and standards-compliant.
5002 However, if the C<vsnprintf> is not available, will unfortunately
5003 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5004 overrun check, but that may be too late). Consider using
5005 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5010 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5013 PERL_UNUSED_ARG(buffer);
5014 PERL_UNUSED_ARG(len);
5015 PERL_UNUSED_ARG(format);
5016 /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
5017 PERL_UNUSED_ARG((void*)ap);
5018 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5025 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5026 Perl_va_copy(ap, apc);
5027 # ifdef HAS_VSNPRINTF
5028 retval = vsnprintf(buffer, len, format, apc);
5030 PERL_UNUSED_ARG(len);
5031 retval = vsprintf(buffer, format, apc);
5035 # ifdef HAS_VSNPRINTF
5036 retval = vsnprintf(buffer, len, format, ap);
5038 PERL_UNUSED_ARG(len);
5039 retval = vsprintf(buffer, format, ap);
5041 #endif /* #ifdef NEED_VA_COPY */
5042 /* vsprintf() shows failure with < 0 */
5044 #ifdef HAS_VSNPRINTF
5045 /* vsnprintf() shows failure with >= len */
5047 (len > 0 && (Size_t)retval >= len)
5050 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5056 Perl_my_clearenv(pTHX)
5058 #if ! defined(PERL_MICRO)
5059 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5061 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5062 # if defined(USE_ENVIRON_ARRAY)
5063 # if defined(USE_ITHREADS)
5064 /* only the parent thread can clobber the process environment, so no need
5066 if (PL_curinterp == aTHX)
5067 # endif /* USE_ITHREADS */
5069 # if ! defined(PERL_USE_SAFE_PUTENV)
5070 if ( !PL_use_safe_putenv) {
5072 if (environ == PL_origenviron)
5073 environ = (char**)safesysmalloc(sizeof(char*));
5075 for (i = 0; environ[i]; i++)
5076 (void)safesysfree(environ[i]);
5079 # else /* PERL_USE_SAFE_PUTENV */
5080 # if defined(HAS_CLEARENV)
5082 # elif defined(HAS_UNSETENV)
5083 int bsiz = 80; /* Most envvar names will be shorter than this. */
5084 char *buf = (char*)safesysmalloc(bsiz);
5085 while (*environ != NULL) {
5086 char *e = strchr(*environ, '=');
5087 int l = e ? e - *environ : (int)strlen(*environ);
5089 (void)safesysfree(buf);
5090 bsiz = l + 1; /* + 1 for the \0. */
5091 buf = (char*)safesysmalloc(bsiz);
5093 memcpy(buf, *environ, l);
5095 (void)unsetenv(buf);
5097 (void)safesysfree(buf);
5098 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5099 /* Just null environ and accept the leakage. */
5101 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5102 # endif /* ! PERL_USE_SAFE_PUTENV */
5104 # endif /* USE_ENVIRON_ARRAY */
5105 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5106 #endif /* PERL_MICRO */
5109 #ifdef PERL_IMPLICIT_CONTEXT
5112 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5113 the global PL_my_cxt_index is incremented, and that value is assigned to
5114 that module's static my_cxt_index (who's address is passed as an arg).
5115 Then, for each interpreter this function is called for, it makes sure a
5116 void* slot is available to hang the static data off, by allocating or
5117 extending the interpreter's PL_my_cxt_list array */
5120 Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
5125 PERL_ARGS_ASSERT_MY_CXT_INIT;
5128 /* do initial check without locking.
5129 * -1: not allocated or another thread currently allocating
5130 * other: already allocated by another thread
5133 MUTEX_LOCK(&PL_my_ctx_mutex);
5134 /*now a stricter check with locking */
5137 /* this module hasn't been allocated an index yet */
5138 *indexp = PL_my_cxt_index++;
5140 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5143 /* make sure the array is big enough */
5144 if (PL_my_cxt_size <= index) {
5145 if (PL_my_cxt_size) {
5146 IV new_size = PL_my_cxt_size;
5147 while (new_size <= index)
5149 Renew(PL_my_cxt_list, new_size, void *);
5150 PL_my_cxt_size = new_size;
5153 PL_my_cxt_size = 16;
5154 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5157 /* newSV() allocates one more than needed */
5158 p = (void*)SvPVX(newSV(size-1));
5159 PL_my_cxt_list[index] = p;
5160 Zero(p, size, char);
5164 #endif /* PERL_IMPLICIT_CONTEXT */
5167 /* Perl_xs_handshake():
5168 implement the various XS_*_BOOTCHECK macros, which are added to .c
5169 files by ExtUtils::ParseXS, to check that the perl the module was built
5170 with is binary compatible with the running perl.
5173 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5174 [U32 items, U32 ax], [char * api_version], [char * xs_version])
5176 The meaning of the varargs is determined the U32 key arg (which is not
5177 a format string). The fields of key are assembled by using HS_KEY().
5179 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5180 "PerlInterpreter *" and represents the callers context; otherwise it is
5181 of type "CV *", and is the boot xsub's CV.
5183 v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5184 for example, and IO.dll was linked with threaded perl524.dll, and both
5185 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5186 successfully can load IO.dll into the process but simultaneously it
5187 loaded an interpreter of a different version into the process, and XS
5188 code will naturally pass SV*s created by perl524.dll for perl526.dll to
5189 use through perl526.dll's my_perl->Istack_base.
5191 v_my_perl cannot be the first arg, since then 'key' will be out of
5192 place in a threaded vs non-threaded mixup; and analyzing the key
5193 number's bitfields won't reveal the problem, since it will be a valid
5194 key (unthreaded perl) on interp side, but croak will report the XS mod's
5195 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5196 it's a threaded perl and an unthreaded XS module, threaded perl will
5197 look at an uninit C stack or an uninit register to get 'key'
5198 (remember that it assumes that the 1st arg is the interp cxt).
5200 'file' is the source filename of the caller.
5204 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
5210 #ifdef PERL_IMPLICIT_CONTEXT
5217 PERL_ARGS_ASSERT_XS_HANDSHAKE;
5218 va_start(args, file);
5220 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
5221 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
5222 if (UNLIKELY(got != need))
5224 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5225 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5226 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5227 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5228 passed to the XS DLL */
5229 #ifdef PERL_IMPLICIT_CONTEXT
5230 xs_interp = (tTHX)v_my_perl;
5234 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5235 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5236 but the DynaLoder/Perl that started the process and loaded the XS DLL is
5237 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5238 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5239 location in the unthreaded perl binary) stored in CV * to figure out if this
5240 Perl_xs_handshake was called by the same pp_entersub */
5241 cv = (CV*)v_my_perl;
5242 xs_spp = (SV***)CvHSCXT(cv);
5244 need = &PL_stack_sp;
5246 if(UNLIKELY(got != need)) {
5247 bad_handshake:/* recycle branch and string from above */
5248 if(got != (void *)HSf_NOCHK)
5249 noperl_die("%s: loadable library and perl binaries are mismatched"
5250 " (got handshake key %p, needed %p)\n",
5254 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
5255 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5256 PL_xsubfilename = file; /* so the old name must be restored for
5257 additional XSUBs to register themselves */
5258 /* XSUBs can't be perl lang/perl5db.pl debugged
5259 if (PERLDB_LINE_OR_SAVESRC)
5260 (void)gv_fetchfile(file); */
5263 if(key & HSf_POPMARK) {
5265 { SV **mark = PL_stack_base + ax++;
5267 items = (I32)(SP - MARK);
5271 items = va_arg(args, U32);
5272 ax = va_arg(args, U32);
5276 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
5277 if((apiverlen = HS_GETAPIVERLEN(key))) {
5278 char * api_p = va_arg(args, char*);
5279 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5280 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5281 sizeof("v" PERL_API_VERSION_STRING)-1))
5282 Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
5283 api_p, SVfARG(PL_stack_base[ax + 0]),
5284 "v" PERL_API_VERSION_STRING);
5289 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
5290 if((xsverlen = HS_GETXSVERLEN(key)))
5291 S_xs_version_bootcheck(aTHX_
5292 items, ax, va_arg(args, char*), xsverlen);
5300 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5304 const char *vn = NULL;
5305 SV *const module = PL_stack_base[ax];
5307 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5309 if (items >= 2) /* version supplied as bootstrap arg */
5310 sv = PL_stack_base[ax + 1];
5312 /* XXX GV_ADDWARN */
5314 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
5315 if (!sv || !SvOK(sv)) {
5317 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
5321 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5322 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5323 ? sv : sv_2mortal(new_version(sv));
5324 xssv = upg_version(xssv, 0);
5325 if ( vcmp(pmsv,xssv) ) {
5326 SV *string = vstringify(xssv);
5327 SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf
5328 " does not match ", SVfARG(module), SVfARG(string));
5330 SvREFCNT_dec(string);
5331 string = vstringify(pmsv);
5334 Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
5337 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
5339 SvREFCNT_dec(string);
5341 Perl_sv_2mortal(aTHX_ xpt);
5342 Perl_croak_sv(aTHX_ xpt);
5348 =for apidoc my_strlcat
5350 The C library C<strlcat> if available, or a Perl implementation of it.
5351 This operates on C C<NUL>-terminated strings.
5353 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
5354 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
5355 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5356 practice this should not happen as it means that either C<size> is incorrect or
5357 that C<dst> is not a proper C<NUL>-terminated string).
5359 Note that C<size> is the full size of the destination buffer and
5360 the result is guaranteed to be C<NUL>-terminated if there is room. Note that
5361 room for the C<NUL> should be included in C<size>.
5363 The return value is the total length that C<dst> would have if C<size> is
5364 sufficiently large. Thus it is the initial length of C<dst> plus the length of
5365 C<src>. If C<size> is smaller than the return, the excess was not appended.
5369 Description stolen from http://man.openbsd.org/strlcat.3
5373 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5375 Size_t used, length, copy;
5378 length = strlen(src);
5379 if (size > 0 && used < size - 1) {
5380 copy = (length >= size - used) ? size - used - 1 : length;
5381 memcpy(dst + used, src, copy);
5382 dst[used + copy] = '\0';
5384 return used + length;
5390 =for apidoc my_strlcpy
5392 The C library C<strlcpy> if available, or a Perl implementation of it.
5393 This operates on C C<NUL>-terminated strings.
5395 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5396 to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
5398 The return value is the total length C<src> would be if the copy completely
5399 succeeded. If it is larger than C<size>, the excess was not copied.
5403 Description stolen from http://man.openbsd.org/strlcpy.3
5407 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5409 Size_t length, copy;
5411 length = strlen(src);
5413 copy = (length >= size) ? size - 1 : length;
5414 memcpy(dst, src, copy);
5421 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5422 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5423 long _ftol( double ); /* Defined by VC6 C libs. */
5424 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5427 PERL_STATIC_INLINE bool
5428 S_gv_has_usable_name(pTHX_ GV *gv)
5432 && HvENAME(GvSTASH(gv))
5433 && (gvp = (GV **)hv_fetchhek(
5434 GvSTASH(gv), GvNAME_HEK(gv), 0
5440 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5442 SV * const dbsv = GvSVn(PL_DBsub);
5443 const bool save_taint = TAINT_get;
5445 /* When we are called from pp_goto (svp is null),
5446 * we do not care about using dbsv to call CV;
5447 * it's for informational purposes only.
5450 PERL_ARGS_ASSERT_GET_DB_SUB;
5454 if (!PERLDB_SUB_NN) {
5457 if (!svp && !CvLEXICAL(cv)) {
5458 gv_efullname3(dbsv, gv, NULL);
5460 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
5461 || strEQ(GvNAME(gv), "END")
5462 || ( /* Could be imported, and old sub redefined. */
5463 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5465 !( (SvTYPE(*svp) == SVt_PVGV)
5466 && (GvCV((const GV *)*svp) == cv)
5467 /* Use GV from the stack as a fallback. */
5468 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
5472 /* GV is potentially non-unique, or contain different CV. */
5473 SV * const tmp = newRV(MUTABLE_SV(cv));
5474 sv_setsv(dbsv, tmp);
5478 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5479 sv_catpvs(dbsv, "::");
5480 sv_cathek(dbsv, GvNAME_HEK(gv));
5484 const int type = SvTYPE(dbsv);
5485 if (type < SVt_PVIV && type != SVt_IV)
5486 sv_upgrade(dbsv, SVt_PVIV);
5487 (void)SvIOK_on(dbsv);
5488 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5491 TAINT_IF(save_taint);
5492 #ifdef NO_TAINT_SUPPORT
5493 PERL_UNUSED_VAR(save_taint);
5498 Perl_my_dirfd(DIR * dir) {
5500 /* Most dirfd implementations have problems when passed NULL. */
5505 #elif defined(HAS_DIR_DD_FD)
5508 Perl_croak_nocontext(PL_no_func, "dirfd");
5509 NOT_REACHED; /* NOTREACHED */
5514 #if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP)
5516 #define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789"
5517 #define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1)
5520 S_my_mkostemp(char *templte, int flags) {
5522 STRLEN len = strlen(templte);
5526 int delete_on_close = flags & O_VMS_DELETEONCLOSE;
5528 flags &= ~O_VMS_DELETEONCLOSE;
5532 templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
5533 templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') {
5534 SETERRNO(EINVAL, LIB_INVARG);
5540 for (i = 1; i <= 6; ++i) {
5541 templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
5544 if (delete_on_close) {
5545 fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
5550 fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
5552 } while (fd == -1 && errno == EEXIST && ++attempts <= 100);
5559 #ifndef HAS_MKOSTEMP
5561 Perl_my_mkostemp(char *templte, int flags)
5563 PERL_ARGS_ASSERT_MY_MKOSTEMP;
5564 return S_my_mkostemp(templte, flags);
5570 Perl_my_mkstemp(char *templte)
5572 PERL_ARGS_ASSERT_MY_MKSTEMP;
5573 return S_my_mkostemp(templte, 0);
5578 Perl_get_re_arg(pTHX_ SV *sv) {
5584 sv = MUTABLE_SV(SvRV(sv));
5585 if (SvTYPE(sv) == SVt_REGEXP)
5586 return (REGEXP*) sv;
5593 * This code is derived from drand48() implementation from FreeBSD,
5594 * found in lib/libc/gen/_rand48.c.
5596 * The U64 implementation is original, based on the POSIX
5597 * specification for drand48().
5601 * Copyright (c) 1993 Martin Birgmeier
5602 * All rights reserved.
5604 * You may redistribute unmodified or modified versions of this source
5605 * code provided that the above copyright notice and this and the
5606 * following conditions are retained.
5608 * This software is provided ``as is'', and comes with no warranties
5609 * of any kind. I shall in no event be liable for anything that happens
5610 * to anyone/anything when using this software.
5613 #define FREEBSD_DRAND48_SEED_0 (0x330e)
5615 #ifdef PERL_DRAND48_QUAD
5617 #define DRAND48_MULT UINT64_C(0x5deece66d)
5618 #define DRAND48_ADD 0xb
5619 #define DRAND48_MASK UINT64_C(0xffffffffffff)
5623 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
5624 #define FREEBSD_DRAND48_SEED_2 (0x1234)
5625 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
5626 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
5627 #define FREEBSD_DRAND48_MULT_2 (0x0005)
5628 #define FREEBSD_DRAND48_ADD (0x000b)
5630 const unsigned short _rand48_mult[3] = {
5631 FREEBSD_DRAND48_MULT_0,
5632 FREEBSD_DRAND48_MULT_1,
5633 FREEBSD_DRAND48_MULT_2
5635 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5640 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5642 PERL_ARGS_ASSERT_DRAND48_INIT_R;
5644 #ifdef PERL_DRAND48_QUAD
5645 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
5647 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5648 random_state->seed[1] = (U16) seed;
5649 random_state->seed[2] = (U16) (seed >> 16);
5654 Perl_drand48_r(perl_drand48_t *random_state)
5656 PERL_ARGS_ASSERT_DRAND48_R;
5658 #ifdef PERL_DRAND48_QUAD
5659 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5662 return ldexp((double)*random_state, -48);
5668 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5669 + (U32) _rand48_add;
5670 temp[0] = (U16) accu; /* lower 16 bits */
5671 accu >>= sizeof(U16) * 8;
5672 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5673 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5674 temp[1] = (U16) accu; /* middle 16 bits */
5675 accu >>= sizeof(U16) * 8;
5676 accu += _rand48_mult[0] * random_state->seed[2]
5677 + _rand48_mult[1] * random_state->seed[1]
5678 + _rand48_mult[2] * random_state->seed[0];
5679 random_state->seed[0] = temp[0];
5680 random_state->seed[1] = temp[1];
5681 random_state->seed[2] = (U16) accu;
5683 return ldexp((double) random_state->seed[0], -48) +
5684 ldexp((double) random_state->seed[1], -32) +
5685 ldexp((double) random_state->seed[2], -16);
5690 #ifdef USE_C_BACKTRACE
5692 /* Possibly move all this USE_C_BACKTRACE code into a new file. */
5697 /* abfd is the BFD handle. */
5699 /* bfd_syms is the BFD symbol table. */
5701 /* bfd_text is handle to the the ".text" section of the object file. */
5703 /* Since opening the executable and scanning its symbols is quite
5704 * heavy operation, we remember the filename we used the last time,
5705 * and do the opening and scanning only if the filename changes.
5706 * This removes most (but not all) open+scan cycles. */
5707 const char* fname_prev;
5710 /* Given a dl_info, update the BFD context if necessary. */
5711 static void bfd_update(bfd_context* ctx, Dl_info* dl_info)
5713 /* BFD open and scan only if the filename changed. */
5714 if (ctx->fname_prev == NULL ||
5715 strNE(dl_info->dli_fname, ctx->fname_prev)) {
5717 bfd_close(ctx->abfd);
5719 ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
5721 if (bfd_check_format(ctx->abfd, bfd_object)) {
5722 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd);
5723 if (symbol_size > 0) {
5724 Safefree(ctx->bfd_syms);
5725 Newx(ctx->bfd_syms, symbol_size, asymbol*);
5727 bfd_get_section_by_name(ctx->abfd, ".text");
5735 ctx->fname_prev = dl_info->dli_fname;
5739 /* Given a raw frame, try to symbolize it and store
5740 * symbol information (source file, line number) away. */
5741 static void bfd_symbolize(bfd_context* ctx,
5744 STRLEN* symbol_name_size,
5746 STRLEN* source_name_size,
5747 STRLEN* source_line)
5749 *symbol_name = NULL;
5750 *symbol_name_size = 0;
5752 IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma);
5754 bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) {
5757 unsigned int line = 0;
5758 if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text,
5759 ctx->bfd_syms, offset,
5760 &file, &func, &line) &&
5761 file && func && line > 0) {
5762 /* Size and copy the source file, use only
5763 * the basename of the source file.
5765 * NOTE: the basenames are fine for the
5766 * Perl source files, but may not always
5767 * be the best idea for XS files. */
5768 const char *p, *b = NULL;
5769 /* Look for the last slash. */
5770 for (p = file; *p; p++) {
5774 if (b == NULL || *b == 0) {
5777 *source_name_size = p - b + 1;
5778 Newx(*source_name, *source_name_size + 1, char);
5779 Copy(b, *source_name, *source_name_size + 1, char);
5781 *symbol_name_size = strlen(func);
5782 Newx(*symbol_name, *symbol_name_size + 1, char);
5783 Copy(func, *symbol_name, *symbol_name_size + 1, char);
5785 *source_line = line;
5791 #endif /* #ifdef USE_BFD */
5795 /* OS X has no public API for for 'symbolicating' (Apple official term)
5796 * stack addresses to {function_name, source_file, line_number}.
5797 * Good news: there is command line utility atos(1) which does that.
5798 * Bad news 1: it's a command line utility.
5799 * Bad news 2: one needs to have the Developer Tools installed.
5800 * Bad news 3: in newer releases it needs to be run as 'xcrun atos'.
5802 * To recap: we need to open a pipe for reading for a utility which
5803 * might not exist, or exists in different locations, and then parse
5804 * the output. And since this is all for a low-level API, we cannot
5805 * use high-level stuff. Thanks, Apple. */
5808 /* tool is set to the absolute pathname of the tool to use:
5811 /* format is set to a printf format string used for building
5812 * the external command to run. */
5814 /* unavail is set if e.g. xcrun cannot be found, or something
5815 * else happens that makes getting the backtrace dubious. Note,
5816 * however, that the context isn't persistent, the next call to
5817 * get_c_backtrace() will start from scratch. */
5819 /* fname is the current object file name. */
5821 /* object_base_addr is the base address of the shared object. */
5822 void* object_base_addr;
5825 /* Given |dl_info|, updates the context. If the context has been
5826 * marked unavailable, return immediately. If not but the tool has
5827 * not been set, set it to either "xcrun atos" or "atos" (also set the
5828 * format to use for creating commands for piping), or if neither is
5829 * unavailable (one needs the Developer Tools installed), mark the context
5830 * an unavailable. Finally, update the filename (object name),
5831 * and its base address. */
5833 static void atos_update(atos_context* ctx,
5838 if (ctx->tool == NULL) {
5839 const char* tools[] = {
5843 const char* formats[] = {
5844 "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1",
5845 "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1"
5849 for (i = 0; i < C_ARRAY_LENGTH(tools); i++) {
5850 if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) {
5851 ctx->tool = tools[i];
5852 ctx->format = formats[i];
5856 if (ctx->tool == NULL) {
5857 ctx->unavail = TRUE;
5861 if (ctx->fname == NULL ||
5862 strNE(dl_info->dli_fname, ctx->fname)) {
5863 ctx->fname = dl_info->dli_fname;
5864 ctx->object_base_addr = dl_info->dli_fbase;
5868 /* Given an output buffer end |p| and its |start|, matches
5869 * for the atos output, extracting the source code location
5870 * and returning non-NULL if possible, returning NULL otherwise. */
5871 static const char* atos_parse(const char* p,
5873 STRLEN* source_name_size,
5874 STRLEN* source_line) {
5875 /* atos() output is something like:
5876 * perl_parse (in miniperl) (perl.c:2314)\n\n".
5877 * We cannot use Perl regular expressions, because we need to
5878 * stay low-level. Therefore here we have a rolled-out version
5879 * of a state machine which matches _backwards_from_the_end_ and
5880 * if there's a success, returns the starts of the filename,
5881 * also setting the filename size and the source line number.
5882 * The matched regular expression is roughly "\(.*:\d+\)\s*$" */
5883 const char* source_number_start;
5884 const char* source_name_end;
5885 const char* source_line_end = start;
5886 const char* close_paren;
5889 /* Skip trailing whitespace. */
5890 while (p > start && isSPACE(*p)) p--;
5891 /* Now we should be at the close paren. */
5892 if (p == start || *p != ')')
5896 /* Now we should be in the line number. */
5897 if (p == start || !isDIGIT(*p))
5899 /* Skip over the digits. */
5900 while (p > start && isDIGIT(*p))
5902 /* Now we should be at the colon. */
5903 if (p == start || *p != ':')
5905 source_number_start = p + 1;
5906 source_name_end = p; /* Just beyond the end. */
5908 /* Look for the open paren. */
5909 while (p > start && *p != '(')
5914 *source_name_size = source_name_end - p;
5915 if (grok_atoUV(source_number_start, &uv, &source_line_end)
5916 && source_line_end == close_paren
5917 && uv <= PERL_INT_MAX
5919 *source_line = (STRLEN)uv;
5925 /* Given a raw frame, read a pipe from the symbolicator (that's the
5926 * technical term) atos, reads the result, and parses the source code
5927 * location. We must stay low-level, so we use snprintf(), pipe(),
5928 * and fread(), and then also parse the output ourselves. */
5929 static void atos_symbolize(atos_context* ctx,
5932 STRLEN* source_name_size,
5933 STRLEN* source_line)
5941 /* Simple security measure: if there's any funny business with
5942 * the object name (used as "-o '%s'" ), leave since at least
5943 * partially the user controls it. */
5944 for (p = ctx->fname; *p; p++) {
5945 if (*p == '\'' || isCNTRL(*p)) {
5946 ctx->unavail = TRUE;
5950 cnt = snprintf(cmd, sizeof(cmd), ctx->format,
5951 ctx->fname, ctx->object_base_addr, raw_frame);
5952 if (cnt < sizeof(cmd)) {
5953 /* Undo nostdio.h #defines that disable stdio.
5954 * This is somewhat naughty, but is used elsewhere
5955 * in the core, and affects only OS X. */
5960 FILE* fp = popen(cmd, "r");
5961 /* At the moment we open a new pipe for each stack frame.
5962 * This is naturally somewhat slow, but hopefully generating
5963 * stack traces is never going to in a performance critical path.
5965 * We could play tricks with atos by batching the stack
5966 * addresses to be resolved: atos can either take multiple
5967 * addresses from the command line, or read addresses from
5968 * a file (though the mess of creating temporary files would
5969 * probably negate much of any possible speedup).
5971 * Normally there are only two objects present in the backtrace:
5972 * perl itself, and the libdyld.dylib. (Note that the object
5973 * filenames contain the full pathname, so perl may not always
5974 * be in the same place.) Whenever the object in the
5975 * backtrace changes, the base address also changes.
5977 * The problem with batching the addresses, though, would be
5978 * matching the results with the addresses: the parsing of
5979 * the results is already painful enough with a single address. */
5982 UV cnt = fread(out, 1, sizeof(out), fp);
5983 if (cnt < sizeof(out)) {
5984 const char* p = atos_parse(out + cnt - 1, out,
5989 *source_name_size, char);
5990 Copy(p, *source_name,
5991 *source_name_size, char);
5999 #endif /* #ifdef PERL_DARWIN */
6002 =for apidoc get_c_backtrace
6004 Collects the backtrace (aka "stacktrace") into a single linear
6005 malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
6007 Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
6008 returning at most C<depth> frames.
6014 Perl_get_c_backtrace(pTHX_ int depth, int skip)
6016 /* Note that here we must stay as low-level as possible: Newx(),
6017 * Copy(), Safefree(); since we may be called from anywhere,
6018 * so we should avoid higher level constructs like SVs or AVs.
6020 * Since we are using safesysmalloc() via Newx(), don't try
6021 * getting backtrace() there, unless you like deep recursion. */
6023 /* Currently only implemented with backtrace() and dladdr(),
6024 * for other platforms NULL is returned. */
6026 #if defined(HAS_BACKTRACE) && defined(HAS_DLADDR)
6027 /* backtrace() is available via <execinfo.h> in glibc and in most
6028 * modern BSDs; dladdr() is available via <dlfcn.h>. */
6030 /* We try fetching this many frames total, but then discard
6031 * the |skip| first ones. For the remaining ones we will try
6032 * retrieving more information with dladdr(). */
6033 int try_depth = skip + depth;
6035 /* The addresses (program counters) returned by backtrace(). */
6038 /* Retrieved with dladdr() from the addresses returned by backtrace(). */
6041 /* Sizes _including_ the terminating \0 of the object name
6042 * and symbol name strings. */
6043 STRLEN* object_name_sizes;
6044 STRLEN* symbol_name_sizes;
6047 /* The symbol names comes either from dli_sname,
6048 * or if using BFD, they can come from BFD. */
6049 char** symbol_names;
6052 /* The source code location information. Dug out with e.g. BFD. */
6053 char** source_names;
6054 STRLEN* source_name_sizes;
6055 STRLEN* source_lines;
6057 Perl_c_backtrace* bt = NULL; /* This is what will be returned. */
6058 int got_depth; /* How many frames were returned from backtrace(). */
6059 UV frame_count = 0; /* How many frames we return. */
6060 UV total_bytes = 0; /* The size of the whole returned backtrace. */
6063 bfd_context bfd_ctx;
6066 atos_context atos_ctx;
6069 /* Here are probably possibilities for optimizing. We could for
6070 * example have a struct that contains most of these and then
6071 * allocate |try_depth| of them, saving a bunch of malloc calls.
6072 * Note, however, that |frames| could not be part of that struct
6073 * because backtrace() will want an array of just them. Also be
6074 * careful about the name strings. */
6075 Newx(raw_frames, try_depth, void*);
6076 Newx(dl_infos, try_depth, Dl_info);
6077 Newx(object_name_sizes, try_depth, STRLEN);
6078 Newx(symbol_name_sizes, try_depth, STRLEN);
6079 Newx(source_names, try_depth, char*);
6080 Newx(source_name_sizes, try_depth, STRLEN);
6081 Newx(source_lines, try_depth, STRLEN);
6083 Newx(symbol_names, try_depth, char*);
6086 /* Get the raw frames. */
6087 got_depth = (int)backtrace(raw_frames, try_depth);
6089 /* We use dladdr() instead of backtrace_symbols() because we want
6090 * the full details instead of opaque strings. This is useful for
6091 * two reasons: () the details are needed for further symbolic
6092 * digging, for example in OS X (2) by having the details we fully
6093 * control the output, which in turn is useful when more platforms
6094 * are added: we can keep out output "portable". */
6096 /* We want a single linear allocation, which can then be freed
6097 * with a single swoop. We will do the usual trick of first
6098 * walking over the structure and seeing how much we need to
6099 * allocate, then allocating, and then walking over the structure
6100 * the second time and populating it. */
6102 /* First we must compute the total size of the buffer. */
6103 total_bytes = sizeof(Perl_c_backtrace_header);
6104 if (got_depth > skip) {
6107 bfd_init(); /* Is this safe to call multiple times? */
6108 Zero(&bfd_ctx, 1, bfd_context);
6111 Zero(&atos_ctx, 1, atos_context);
6113 for (i = skip; i < try_depth; i++) {
6114 Dl_info* dl_info = &dl_infos[i];
6116 object_name_sizes[i] = 0;
6117 source_names[i] = NULL;
6118 source_name_sizes[i] = 0;
6119 source_lines[i] = 0;
6121 /* Yes, zero from dladdr() is failure. */
6122 if (dladdr(raw_frames[i], dl_info)) {
6123 total_bytes += sizeof(Perl_c_backtrace_frame);
6125 object_name_sizes[i] =
6126 dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
6127 symbol_name_sizes[i] =
6128 dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0;
6130 bfd_update(&bfd_ctx, dl_info);
6131 bfd_symbolize(&bfd_ctx, raw_frames[i],
6133 &symbol_name_sizes[i],
6135 &source_name_sizes[i],
6139 atos_update(&atos_ctx, dl_info);
6140 atos_symbolize(&atos_ctx,
6143 &source_name_sizes[i],
6147 /* Plus ones for the terminating \0. */
6148 total_bytes += object_name_sizes[i] + 1;
6149 total_bytes += symbol_name_sizes[i] + 1;
6150 total_bytes += source_name_sizes[i] + 1;
6158 Safefree(bfd_ctx.bfd_syms);
6162 /* Now we can allocate and populate the result buffer. */
6163 Newxc(bt, total_bytes, char, Perl_c_backtrace);
6164 Zero(bt, total_bytes, char);
6165 bt->header.frame_count = frame_count;
6166 bt->header.total_bytes = total_bytes;
6167 if (frame_count > 0) {
6168 Perl_c_backtrace_frame* frame = bt->frame_info;
6169 char* name_base = (char *)(frame + frame_count);
6170 char* name_curr = name_base; /* Outputting the name strings here. */
6172 for (i = skip; i < skip + frame_count; i++) {
6173 Dl_info* dl_info = &dl_infos[i];
6175 frame->addr = raw_frames[i];
6176 frame->object_base_addr = dl_info->dli_fbase;
6177 frame->symbol_addr = dl_info->dli_saddr;
6179 /* Copies a string, including the \0, and advances the name_curr.
6180 * Also copies the start and the size to the frame. */
6181 #define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \
6183 Copy(src, name_curr, size, char); \
6184 frame->doffset = name_curr - (char*)bt; \
6185 frame->dsize = size; \
6186 name_curr += size; \
6189 PERL_C_BACKTRACE_STRCPY(frame, object_name_offset,
6191 object_name_size, object_name_sizes[i]);
6194 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6196 symbol_name_size, symbol_name_sizes[i]);
6197 Safefree(symbol_names[i]);
6199 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6201 symbol_name_size, symbol_name_sizes[i]);
6204 PERL_C_BACKTRACE_STRCPY(frame, source_name_offset,
6206 source_name_size, source_name_sizes[i]);
6207 Safefree(source_names[i]);
6209 #undef PERL_C_BACKTRACE_STRCPY
6211 frame->source_line_number = source_lines[i];
6215 assert(total_bytes ==
6216 (UV)(sizeof(Perl_c_backtrace_header) +
6217 frame_count * sizeof(Perl_c_backtrace_frame) +
6218 name_curr - name_base));
6221 Safefree(symbol_names);
6223 bfd_close(bfd_ctx.abfd);
6226 Safefree(source_lines);
6227 Safefree(source_name_sizes);
6228 Safefree(source_names);
6229 Safefree(symbol_name_sizes);
6230 Safefree(object_name_sizes);
6231 /* Assuming the strings returned by dladdr() are pointers
6232 * to read-only static memory (the object file), so that
6233 * they do not need freeing (and cannot be). */
6235 Safefree(raw_frames);
6238 PERL_UNUSED_ARG(depth);
6239 PERL_UNUSED_ARG(skip);
6245 =for apidoc free_c_backtrace
6247 Deallocates a backtrace received from get_c_bracktrace.
6253 =for apidoc get_c_backtrace_dump
6255 Returns a SV containing a dump of C<depth> frames of the call stack, skipping
6256 the C<skip> innermost ones. C<depth> of 20 is usually enough.
6258 The appended output looks like:
6261 1 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl
6262 2 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl
6265 The fields are tab-separated. The first column is the depth (zero
6266 being the innermost non-skipped frame). In the hex:offset, the hex is
6267 where the program counter was in C<S_parse_body>, and the :offset (might
6268 be missing) tells how much inside the C<S_parse_body> the program counter was.
6270 The C<util.c:1716> is the source code file and line number.
6272 The F</usr/bin/perl> is obvious (hopefully).
6274 Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
6275 if the platform doesn't support retrieving the information;
6276 if the binary is missing the debug information;
6277 if the optimizer has transformed the code by for example inlining.
6283 Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
6285 Perl_c_backtrace* bt;
6287 bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */);
6289 Perl_c_backtrace_frame* frame;
6290 SV* dsv = newSVpvs("");
6292 for (i = 0, frame = bt->frame_info;
6293 i < bt->header.frame_count; i++, frame++) {
6294 Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i);
6295 Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-");
6296 /* Symbol (function) names might disappear without debug info.
6298 * The source code location might disappear in case of the
6299 * optimizer inlining or otherwise rearranging the code. */
6300 if (frame->symbol_addr) {
6301 Perl_sv_catpvf(aTHX_ dsv, ":%04x",
6303 ((char*)frame->addr - (char*)frame->symbol_addr));
6305 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6306 frame->symbol_name_size &&
6307 frame->symbol_name_offset ?
6308 (char*)bt + frame->symbol_name_offset : "-");
6309 if (frame->source_name_size &&
6310 frame->source_name_offset &&
6311 frame->source_line_number) {
6312 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf,
6313 (char*)bt + frame->source_name_offset,
6314 (UV)frame->source_line_number);
6316 Perl_sv_catpvf(aTHX_ dsv, "\t-");
6318 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6319 frame->object_name_size &&
6320 frame->object_name_offset ?
6321 (char*)bt + frame->object_name_offset : "-");
6322 /* The frame->object_base_addr is not output,
6323 * but it is used for symbolizing/symbolicating. */
6324 sv_catpvs(dsv, "\n");
6327 Perl_free_c_backtrace(bt);
6336 =for apidoc dump_c_backtrace
6338 Dumps the C backtrace to the given C<fp>.
6340 Returns true if a backtrace could be retrieved, false if not.
6346 Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
6350 PERL_ARGS_ASSERT_DUMP_C_BACKTRACE;
6352 sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip);
6355 PerlIO_printf(fp, "%s", SvPV_nolen(sv));
6361 #endif /* #ifdef USE_C_BACKTRACE */
6363 #ifdef PERL_TSA_ACTIVE
6365 /* pthread_mutex_t and perl_mutex are typedef equivalent
6366 * so casting the pointers is fine. */
6368 int perl_tsa_mutex_lock(perl_mutex* mutex)
6370 return pthread_mutex_lock((pthread_mutex_t *) mutex);
6373 int perl_tsa_mutex_unlock(perl_mutex* mutex)
6375 return pthread_mutex_unlock((pthread_mutex_t *) mutex);
6378 int perl_tsa_mutex_destroy(perl_mutex* mutex)
6380 return pthread_mutex_destroy((pthread_mutex_t *) mutex);
6388 /* log a sub call or return */
6391 Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call)
6399 PERL_ARGS_ASSERT_DTRACE_PROBE_CALL;
6402 HEK *hek = CvNAME_HEK(cv);
6403 func = HEK_KEY(hek);
6409 start = (const COP *)CvSTART(cv);
6410 file = CopFILE(start);
6411 line = CopLINE(start);
6412 stash = CopSTASHPV(start);
6415 PERL_SUB_ENTRY(func, file, line, stash);
6418 PERL_SUB_RETURN(func, file, line, stash);
6423 /* log a require file loading/loaded */
6426 Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading)
6428 PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
6431 PERL_LOADING_FILE(name);
6434 PERL_LOADED_FILE(name);
6439 /* log an op execution */
6442 Perl_dtrace_probe_op(pTHX_ const OP *op)
6444 PERL_ARGS_ASSERT_DTRACE_PROBE_OP;
6446 PERL_OP_ENTRY(OP_NAME(op));
6450 /* log a compile/run phase change */
6453 Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase)
6455 const char *ph_old = PL_phase_names[PL_phase];
6456 const char *ph_new = PL_phase_names[phase];
6458 PERL_PHASE_CHANGE(ph_new, ph_old);
6464 * ex: set ts=8 sts=4 sw=4 et: