3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
15 * [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
18 /* This file contains assorted utility routines.
19 * Which is a polite way of saying any stuff that people couldn't think of
20 * a better place for. Amongst other things, it includes the warning and
21 * dieing stuff, plus wrappers for malloc code.
25 #define PERL_IN_UTIL_C
29 #if defined(USE_PERLIO)
30 #include "perliol.h" /* For PerlIOUnix_refcnt */
36 # define SIG_ERR ((Sighandler_t) -1)
44 /* Missing protos on LynxOS */
49 # include "amigaos4/amigaio.h"
54 # include <sys/select.h>
58 #ifdef USE_C_BACKTRACE
62 # undef USE_BFD /* BFD is useless in OS X. */
72 # include <execinfo.h>
76 #ifdef PERL_DEBUG_READONLY_COW
77 # include <sys/mman.h>
82 /* NOTE: Do not call the next three routines directly. Use the macros
83 * in handy.h, so that we can easily redefine everything to do tracking of
84 * allocated hunks back to the original New to track down any memory leaks.
85 * XXX This advice seems to be widely ignored :-( --AD August 1996.
88 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
89 # define ALWAYS_NEED_THX
92 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
94 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
97 && mprotect(header, header->size, PROT_READ|PROT_WRITE))
98 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
99 header, header->size, errno);
103 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
106 && mprotect(header, header->size, PROT_READ))
107 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
108 header, header->size, errno);
110 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
111 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
113 # define maybe_protect_rw(foo) NOOP
114 # define maybe_protect_ro(foo) NOOP
117 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
118 /* Use memory_debug_header */
120 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
121 || defined(PERL_DEBUG_READONLY_COW)
122 # define MDH_HAS_SIZE
126 /* paranoid version of system's malloc() */
129 Perl_safesysmalloc(MEM_SIZE size)
131 #ifdef ALWAYS_NEED_THX
137 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
139 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
142 if ((SSize_t)size < 0)
143 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
145 if (!size) size = 1; /* malloc(0) is NASTY on our system */
146 #ifdef PERL_DEBUG_READONLY_COW
147 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
148 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
149 perror("mmap failed");
153 ptr = (Malloc_t)PerlMem_malloc(size?size:1);
155 PERL_ALLOC_CHECK(ptr);
158 struct perl_memory_debug_header *const header
159 = (struct perl_memory_debug_header *)ptr;
163 PoisonNew(((char *)ptr), size, char);
166 #ifdef PERL_TRACK_MEMPOOL
167 header->interpreter = aTHX;
168 /* Link us into the list. */
169 header->prev = &PL_memory_debug_header;
170 header->next = PL_memory_debug_header.next;
171 PL_memory_debug_header.next = header;
172 maybe_protect_rw(header->next);
173 header->next->prev = header;
174 maybe_protect_ro(header->next);
175 # ifdef PERL_DEBUG_READONLY_COW
176 header->readonly = 0;
182 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
183 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
191 #ifndef ALWAYS_NEED_THX
203 /* paranoid version of system's realloc() */
206 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
208 #ifdef ALWAYS_NEED_THX
212 #ifdef PERL_DEBUG_READONLY_COW
213 const MEM_SIZE oldsize = where
214 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
217 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
218 Malloc_t PerlMem_realloc();
219 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
226 ptr = safesysmalloc(size);
230 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
231 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
233 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
235 struct perl_memory_debug_header *const header
236 = (struct perl_memory_debug_header *)where;
238 # ifdef PERL_TRACK_MEMPOOL
239 if (header->interpreter != aTHX) {
240 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
241 header->interpreter, aTHX);
243 assert(header->next->prev == header);
244 assert(header->prev->next == header);
246 if (header->size > size) {
247 const MEM_SIZE freed_up = header->size - size;
248 char *start_of_freed = ((char *)where) + size;
249 PoisonFree(start_of_freed, freed_up, char);
259 if ((SSize_t)size < 0)
260 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
262 #ifdef PERL_DEBUG_READONLY_COW
263 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
264 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
265 perror("mmap failed");
268 Copy(where,ptr,oldsize < size ? oldsize : size,char);
269 if (munmap(where, oldsize)) {
270 perror("munmap failed");
274 ptr = (Malloc_t)PerlMem_realloc(where,size);
276 PERL_ALLOC_CHECK(ptr);
278 /* MUST do this fixup first, before doing ANYTHING else, as anything else
279 might allocate memory/free/move memory, and until we do the fixup, it
280 may well be chasing (and writing to) free memory. */
282 #ifdef PERL_TRACK_MEMPOOL
283 struct perl_memory_debug_header *const header
284 = (struct perl_memory_debug_header *)ptr;
287 if (header->size < size) {
288 const MEM_SIZE fresh = size - header->size;
289 char *start_of_fresh = ((char *)ptr) + size;
290 PoisonNew(start_of_fresh, fresh, char);
294 maybe_protect_rw(header->next);
295 header->next->prev = header;
296 maybe_protect_ro(header->next);
297 maybe_protect_rw(header->prev);
298 header->prev->next = header;
299 maybe_protect_ro(header->prev);
301 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
304 /* In particular, must do that fixup above before logging anything via
305 *printf(), as it can reallocate memory, which can cause SEGVs. */
307 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
308 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
315 #ifndef ALWAYS_NEED_THX
328 /* safe version of system's free() */
331 Perl_safesysfree(Malloc_t where)
333 #ifdef ALWAYS_NEED_THX
336 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
339 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
341 struct perl_memory_debug_header *const header
342 = (struct perl_memory_debug_header *)where_intrn;
345 const MEM_SIZE size = header->size;
347 # ifdef PERL_TRACK_MEMPOOL
348 if (header->interpreter != aTHX) {
349 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
350 header->interpreter, aTHX);
353 Perl_croak_nocontext("panic: duplicate free");
356 Perl_croak_nocontext("panic: bad free, header->next==NULL");
357 if (header->next->prev != header || header->prev->next != header) {
358 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
359 "header=%p, ->prev->next=%p",
360 header->next->prev, header,
363 /* Unlink us from the chain. */
364 maybe_protect_rw(header->next);
365 header->next->prev = header->prev;
366 maybe_protect_ro(header->next);
367 maybe_protect_rw(header->prev);
368 header->prev->next = header->next;
369 maybe_protect_ro(header->prev);
370 maybe_protect_rw(header);
372 PoisonNew(where_intrn, size, char);
374 /* Trigger the duplicate free warning. */
377 # ifdef PERL_DEBUG_READONLY_COW
378 if (munmap(where_intrn, size)) {
379 perror("munmap failed");
385 Malloc_t where_intrn = where;
387 #ifndef PERL_DEBUG_READONLY_COW
388 PerlMem_free(where_intrn);
393 /* safe version of system's calloc() */
396 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
398 #ifdef ALWAYS_NEED_THX
402 #if defined(USE_MDH) || defined(DEBUGGING)
403 MEM_SIZE total_size = 0;
406 /* Even though calloc() for zero bytes is strange, be robust. */
407 if (size && (count <= MEM_SIZE_MAX / size)) {
408 #if defined(USE_MDH) || defined(DEBUGGING)
409 total_size = size * count;
415 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
416 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
421 if ((SSize_t)size < 0 || (SSize_t)count < 0)
422 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
423 (UV)size, (UV)count);
425 #ifdef PERL_DEBUG_READONLY_COW
426 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
427 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
428 perror("mmap failed");
431 #elif defined(PERL_TRACK_MEMPOOL)
432 /* Have to use malloc() because we've added some space for our tracking
434 /* malloc(0) is non-portable. */
435 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
437 /* Use calloc() because it might save a memset() if the memory is fresh
438 and clean from the OS. */
440 ptr = (Malloc_t)PerlMem_calloc(count, size);
441 else /* calloc(0) is non-portable. */
442 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
444 PERL_ALLOC_CHECK(ptr);
445 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
449 struct perl_memory_debug_header *const header
450 = (struct perl_memory_debug_header *)ptr;
452 # ifndef PERL_DEBUG_READONLY_COW
453 memset((void*)ptr, 0, total_size);
455 # ifdef PERL_TRACK_MEMPOOL
456 header->interpreter = aTHX;
457 /* Link us into the list. */
458 header->prev = &PL_memory_debug_header;
459 header->next = PL_memory_debug_header.next;
460 PL_memory_debug_header.next = header;
461 maybe_protect_rw(header->next);
462 header->next->prev = header;
463 maybe_protect_ro(header->next);
464 # ifdef PERL_DEBUG_READONLY_COW
465 header->readonly = 0;
469 header->size = total_size;
471 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
477 #ifndef ALWAYS_NEED_THX
486 /* These must be defined when not using Perl's malloc for binary
491 Malloc_t Perl_malloc (MEM_SIZE nbytes)
493 #ifdef PERL_IMPLICIT_SYS
496 return (Malloc_t)PerlMem_malloc(nbytes);
499 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
501 #ifdef PERL_IMPLICIT_SYS
504 return (Malloc_t)PerlMem_calloc(elements, size);
507 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
509 #ifdef PERL_IMPLICIT_SYS
512 return (Malloc_t)PerlMem_realloc(where, nbytes);
515 Free_t Perl_mfree (Malloc_t where)
517 #ifdef PERL_IMPLICIT_SYS
525 /* copy a string up to some (non-backslashed) delimiter, if any.
526 * With allow_escape, converts \<delimiter> to <delimiter>, while leaves
527 * \<non-delimiter> as-is.
528 * Returns the position in the src string of the closing delimiter, if
529 * any, or returns fromend otherwise.
530 * This is the internal implementation for Perl_delimcpy and
531 * Perl_delimcpy_no_escape.
535 S_delimcpy_intern(char *to, const char *toend, const char *from,
536 const char *fromend, int delim, I32 *retlen,
537 const bool allow_escape)
541 PERL_ARGS_ASSERT_DELIMCPY;
543 for (tolen = 0; from < fromend; from++, tolen++) {
544 if (allow_escape && *from == '\\' && from + 1 < fromend) {
545 if (from[1] != delim) {
552 else if (*from == delim)
564 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
566 PERL_ARGS_ASSERT_DELIMCPY;
568 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
572 Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
573 const char *fromend, int delim, I32 *retlen)
575 PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
577 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
581 =head1 Miscellaneous Functions
583 =for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
585 Find the first (leftmost) occurrence of a sequence of bytes within another
586 sequence. This is the Perl version of C<strstr()>, extended to handle
587 arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
588 is what the initial C<n> in the function name stands for; some systems have an
589 equivalent, C<memmem()>, but with a somewhat different API).
591 Another way of thinking about this function is finding a needle in a haystack.
592 C<big> points to the first byte in the haystack. C<big_end> points to one byte
593 beyond the final byte in the haystack. C<little> points to the first byte in
594 the needle. C<little_end> points to one byte beyond the final byte in the
595 needle. All the parameters must be non-C<NULL>.
597 The function returns C<NULL> if there is no occurrence of C<little> within
598 C<big>. If C<little> is the empty string, C<big> is returned.
600 Because this function operates at the byte level, and because of the inherent
601 characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
602 needle and the haystack are strings with the same UTF-8ness, but not if the
610 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
612 PERL_ARGS_ASSERT_NINSTR;
615 return ninstr(big, bigend, little, lend);
621 const char first = *little;
623 bigend -= lend - little++;
625 while (big <= bigend) {
626 if (*big++ == first) {
627 for (x=big,s=little; s < lend; x++,s++) {
631 return (char*)(big-1);
642 =head1 Miscellaneous Functions
644 =for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
646 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
647 sequence of bytes within another sequence, returning C<NULL> if there is no
655 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
658 const I32 first = *little;
659 const char * const littleend = lend;
661 PERL_ARGS_ASSERT_RNINSTR;
663 if (little >= littleend)
664 return (char*)bigend;
666 big = bigend - (littleend - little++);
667 while (big >= bigbeg) {
671 for (x=big+2,s=little; s < littleend; /**/ ) {
680 return (char*)(big+1);
685 /* As a space optimization, we do not compile tables for strings of length
686 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
687 special-cased in fbm_instr().
689 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
692 =head1 Miscellaneous Functions
694 =for apidoc fbm_compile
696 Analyses the string in order to make fast searches on it using C<fbm_instr()>
697 -- the Boyer-Moore algorithm.
703 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
710 PERL_DEB( STRLEN rarest = 0 );
712 PERL_ARGS_ASSERT_FBM_COMPILE;
714 if (isGV_with_GP(sv) || SvROK(sv))
720 if (flags & FBMcf_TAIL) {
721 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
722 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
723 if (mg && mg->mg_len >= 0)
726 if (!SvPOK(sv) || SvNIOKp(sv))
727 s = (U8*)SvPV_force_mutable(sv, len);
728 else s = (U8 *)SvPV_mutable(sv, len);
729 if (len == 0) /* TAIL might be on a zero-length string. */
731 SvUPGRADE(sv, SVt_PVMG);
736 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
737 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
738 to call SvVALID_off() if the scalar was assigned to.
740 The comment itself (and "deeper magic" below) date back to
741 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
743 where the magic (presumably) was that the scalar had a BM table hidden
746 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
747 the table instead of the previous (somewhat hacky) approach of co-opting
748 the string buffer and storing it after the string. */
750 assert(!mg_find(sv, PERL_MAGIC_bm));
751 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
755 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
757 const U8 mlen = (len>255) ? 255 : (U8)len;
758 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
761 Newx(table, 256, U8);
762 memset((void*)table, mlen, 256);
763 mg->mg_ptr = (char *)table;
766 s += len - 1; /* last char */
769 if (table[*s] == mlen)
775 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
776 for (i = 0; i < len; i++) {
777 if (PL_freq[s[i]] < frequency) {
778 PERL_DEB( rarest = i );
779 frequency = PL_freq[s[i]];
782 BmUSEFUL(sv) = 100; /* Initial value */
783 if (flags & FBMcf_TAIL)
785 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
786 s[rarest], (UV)rarest));
791 =for apidoc fbm_instr
793 Returns the location of the SV in the string delimited by C<big> and
794 C<bigend> (C<bigend>) is the char following the last char).
795 It returns C<NULL> if the string can't be found. The C<sv>
796 does not have to be C<fbm_compiled>, but the search will not be as fast
801 If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
802 during FBM compilation due to FBMcf_TAIL in flags. It indicates that
803 the littlestr must be anchored to the end of bigstr (or to any \n if
806 E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
807 while /abc$/ compiles to "abc\n" with SvTAIL() true.
809 A littlestr of "abc", !SvTAIL matches as /abc/;
810 a littlestr of "ab\n", SvTAIL matches as:
811 without FBMrf_MULTILINE: /ab\n?\z/
812 with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
814 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
815 "If SvTAIL is actually due to \Z or \z, this gives false positives
821 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
825 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
826 STRLEN littlelen = l;
827 const I32 multiline = flags & FBMrf_MULTILINE;
829 PERL_ARGS_ASSERT_FBM_INSTR;
831 if ((STRLEN)(bigend - big) < littlelen) {
832 if ( SvTAIL(littlestr)
833 && ((STRLEN)(bigend - big) == littlelen - 1)
835 || (*big == *little &&
836 memEQ((char *)big, (char *)little, littlelen - 1))))
841 switch (littlelen) { /* Special cases for 0, 1 and 2 */
843 return (char*)big; /* Cannot be SvTAIL! */
846 if (SvTAIL(littlestr) && !multiline) /* Anchor only! */
847 /* [-1] is safe because we know that bigend != big. */
848 return (char *) (bigend - (bigend[-1] == '\n'));
850 s = (unsigned char *)memchr((void*)big, *little, bigend-big);
853 if (SvTAIL(littlestr))
854 return (char *) bigend;
858 if (SvTAIL(littlestr) && !multiline) {
859 /* a littlestr with SvTAIL must be of the form "X\n" (where X
860 * is a single char). It is anchored, and can only match
861 * "....X\n" or "....X" */
862 if (bigend[-2] == *little && bigend[-1] == '\n')
863 return (char*)bigend - 2;
864 if (bigend[-1] == *little)
865 return (char*)bigend - 1;
870 /* memchr() is likely to be very fast, possibly using whatever
871 * hardware support is available, such as checking a whole
872 * cache line in one instruction.
873 * So for a 2 char pattern, calling memchr() is likely to be
874 * faster than running FBM, or rolling our own. The previous
875 * version of this code was roll-your-own which typically
876 * only needed to read every 2nd char, which was good back in
877 * the day, but no longer.
879 unsigned char c1 = little[0];
880 unsigned char c2 = little[1];
882 /* *** for all this case, bigend points to the last char,
883 * not the trailing \0: this makes the conditions slightly
889 /* do a quick test for c1 before calling memchr();
890 * this avoids the expensive fn call overhead when
891 * there are lots of c1's */
892 if (LIKELY(*s != c1)) {
894 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
901 /* failed; try searching for c2 this time; that way
902 * we don't go pathologically slow when the string
903 * consists mostly of c1's or vice versa.
908 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
916 /* c1, c2 the same */
926 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
927 if (!s || s >= bigend)
934 /* failed to find 2 chars; try anchored match at end without
936 if (SvTAIL(littlestr) && bigend[0] == little[0])
937 return (char *)bigend;
942 break; /* Only lengths 0 1 and 2 have special-case code. */
945 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
946 s = bigend - littlelen;
947 if (s >= big && bigend[-1] == '\n' && *s == *little
948 /* Automatically of length > 2 */
949 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
951 return (char*)s; /* how sweet it is */
954 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
956 return (char*)s + 1; /* how sweet it is */
961 if (!SvVALID(littlestr)) {
962 /* not compiled; use Perl_ninstr() instead */
963 char * const b = ninstr((char*)big,(char*)bigend,
964 (char*)little, (char*)little + littlelen);
966 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
967 /* Chop \n from littlestr: */
968 s = bigend - littlelen + 1;
970 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
980 if (littlelen > (STRLEN)(bigend - big))
984 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
985 const unsigned char *oldlittle;
989 --littlelen; /* Last char found by table lookup */
992 little += littlelen; /* last char */
995 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
996 const unsigned char lastc = *little;
1000 if ((tmp = table[*s])) {
1001 /* *s != lastc; earliest position it could match now is
1002 * tmp slots further on */
1003 if ((s += tmp) >= bigend)
1005 if (LIKELY(*s != lastc)) {
1007 s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
1017 /* hand-rolled strncmp(): less expensive than calling the
1018 * real function (maybe???) */
1020 unsigned char * const olds = s;
1025 if (*--s == *--little)
1027 s = olds + 1; /* here we pay the price for failure */
1029 if (s < bigend) /* fake up continue to outer loop */
1038 && SvTAIL(littlestr)
1039 && memEQ((char *)(bigend - littlelen),
1040 (char *)(oldlittle - littlelen), littlelen) )
1041 return (char*)bigend - littlelen;
1050 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1052 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1053 match themselves and their opposite case counterparts. Non-cased and non-ASCII
1054 range bytes match only themselves.
1061 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1063 const U8 *a = (const U8 *)s1;
1064 const U8 *b = (const U8 *)s2;
1066 PERL_ARGS_ASSERT_FOLDEQ;
1071 if (*a != *b && *a != PL_fold[*b])
1078 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1080 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1081 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1082 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1083 * does it check that the strings each have at least 'len' characters */
1085 const U8 *a = (const U8 *)s1;
1086 const U8 *b = (const U8 *)s2;
1088 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1093 if (*a != *b && *a != PL_fold_latin1[*b]) {
1102 =for apidoc foldEQ_locale
1104 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1105 same case-insensitively in the current locale; false otherwise.
1111 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1114 const U8 *a = (const U8 *)s1;
1115 const U8 *b = (const U8 *)s2;
1117 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1122 if (*a != *b && *a != PL_fold_locale[*b])
1129 /* copy a string to a safe spot */
1132 =head1 Memory Management
1136 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1137 string which is a duplicate of C<pv>. The size of the string is
1138 determined by C<strlen()>, which means it may not contain embedded C<NUL>
1139 characters and must have a trailing C<NUL>. The memory allocated for the new
1140 string can be freed with the C<Safefree()> function.
1142 On some platforms, Windows for example, all allocated memory owned by a thread
1143 is deallocated when that thread ends. So if you need that not to happen, you
1144 need to use the shared memory functions, such as C<L</savesharedpv>>.
1150 Perl_savepv(pTHX_ const char *pv)
1152 PERL_UNUSED_CONTEXT;
1157 const STRLEN pvlen = strlen(pv)+1;
1158 Newx(newaddr, pvlen, char);
1159 return (char*)memcpy(newaddr, pv, pvlen);
1163 /* same thing but with a known length */
1168 Perl's version of what C<strndup()> would be if it existed. Returns a
1169 pointer to a newly allocated string which is a duplicate of the first
1170 C<len> bytes from C<pv>, plus a trailing
1171 C<NUL> byte. The memory allocated for
1172 the new string can be freed with the C<Safefree()> function.
1174 On some platforms, Windows for example, all allocated memory owned by a thread
1175 is deallocated when that thread ends. So if you need that not to happen, you
1176 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1182 Perl_savepvn(pTHX_ const char *pv, I32 len)
1185 PERL_UNUSED_CONTEXT;
1189 Newx(newaddr,len+1,char);
1190 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1192 /* might not be null terminated */
1193 newaddr[len] = '\0';
1194 return (char *) CopyD(pv,newaddr,len,char);
1197 return (char *) ZeroD(newaddr,len+1,char);
1202 =for apidoc savesharedpv
1204 A version of C<savepv()> which allocates the duplicate string in memory
1205 which is shared between threads.
1210 Perl_savesharedpv(pTHX_ const char *pv)
1215 PERL_UNUSED_CONTEXT;
1220 pvlen = strlen(pv)+1;
1221 newaddr = (char*)PerlMemShared_malloc(pvlen);
1225 return (char*)memcpy(newaddr, pv, pvlen);
1229 =for apidoc savesharedpvn
1231 A version of C<savepvn()> which allocates the duplicate string in memory
1232 which is shared between threads. (With the specific difference that a C<NULL>
1233 pointer is not acceptable)
1238 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1240 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1242 PERL_UNUSED_CONTEXT;
1243 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1248 newaddr[len] = '\0';
1249 return (char*)memcpy(newaddr, pv, len);
1253 =for apidoc savesvpv
1255 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1256 the passed in SV using C<SvPV()>
1258 On some platforms, Windows for example, all allocated memory owned by a thread
1259 is deallocated when that thread ends. So if you need that not to happen, you
1260 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1266 Perl_savesvpv(pTHX_ SV *sv)
1269 const char * const pv = SvPV_const(sv, len);
1272 PERL_ARGS_ASSERT_SAVESVPV;
1275 Newx(newaddr,len,char);
1276 return (char *) CopyD(pv,newaddr,len,char);
1280 =for apidoc savesharedsvpv
1282 A version of C<savesharedpv()> which allocates the duplicate string in
1283 memory which is shared between threads.
1289 Perl_savesharedsvpv(pTHX_ SV *sv)
1292 const char * const pv = SvPV_const(sv, len);
1294 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1296 return savesharedpvn(pv, len);
1299 /* the SV for Perl_form() and mess() is not kept in an arena */
1307 if (PL_phase != PERL_PHASE_DESTRUCT)
1308 return newSVpvs_flags("", SVs_TEMP);
1313 /* Create as PVMG now, to avoid any upgrading later */
1315 Newxz(any, 1, XPVMG);
1316 SvFLAGS(sv) = SVt_PVMG;
1317 SvANY(sv) = (void*)any;
1319 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1324 #if defined(PERL_IMPLICIT_CONTEXT)
1326 Perl_form_nocontext(const char* pat, ...)
1331 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1332 va_start(args, pat);
1333 retval = vform(pat, &args);
1337 #endif /* PERL_IMPLICIT_CONTEXT */
1340 =head1 Miscellaneous Functions
1343 Takes a sprintf-style format pattern and conventional
1344 (non-SV) arguments and returns the formatted string.
1346 (char *) Perl_form(pTHX_ const char* pat, ...)
1348 can be used any place a string (char *) is required:
1350 char * s = Perl_form("%d.%d",major,minor);
1352 Uses a single private buffer so if you want to format several strings you
1353 must explicitly copy the earlier strings away (and free the copies when you
1360 Perl_form(pTHX_ const char* pat, ...)
1364 PERL_ARGS_ASSERT_FORM;
1365 va_start(args, pat);
1366 retval = vform(pat, &args);
1372 Perl_vform(pTHX_ const char *pat, va_list *args)
1374 SV * const sv = mess_alloc();
1375 PERL_ARGS_ASSERT_VFORM;
1376 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1381 =for apidoc Am|SV *|mess|const char *pat|...
1383 Take a sprintf-style format pattern and argument list. These are used to
1384 generate a string message. If the message does not end with a newline,
1385 then it will be extended with some indication of the current location
1386 in the code, as described for L</mess_sv>.
1388 Normally, the resulting message is returned in a new mortal SV.
1389 During global destruction a single SV may be shared between uses of
1395 #if defined(PERL_IMPLICIT_CONTEXT)
1397 Perl_mess_nocontext(const char *pat, ...)
1402 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1403 va_start(args, pat);
1404 retval = vmess(pat, &args);
1408 #endif /* PERL_IMPLICIT_CONTEXT */
1411 Perl_mess(pTHX_ const char *pat, ...)
1415 PERL_ARGS_ASSERT_MESS;
1416 va_start(args, pat);
1417 retval = vmess(pat, &args);
1423 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1426 /* Look for curop starting from o. cop is the last COP we've seen. */
1427 /* opnext means that curop is actually the ->op_next of the op we are
1430 PERL_ARGS_ASSERT_CLOSEST_COP;
1432 if (!o || !curop || (
1433 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1437 if (o->op_flags & OPf_KIDS) {
1439 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1442 /* If the OP_NEXTSTATE has been optimised away we can still use it
1443 * the get the file and line number. */
1445 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1446 cop = (const COP *)kid;
1448 /* Keep searching, and return when we've found something. */
1450 new_cop = closest_cop(cop, kid, curop, opnext);
1456 /* Nothing found. */
1462 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1464 Expands a message, intended for the user, to include an indication of
1465 the current location in the code, if the message does not already appear
1468 C<basemsg> is the initial message or object. If it is a reference, it
1469 will be used as-is and will be the result of this function. Otherwise it
1470 is used as a string, and if it already ends with a newline, it is taken
1471 to be complete, and the result of this function will be the same string.
1472 If the message does not end with a newline, then a segment such as C<at
1473 foo.pl line 37> will be appended, and possibly other clauses indicating
1474 the current state of execution. The resulting message will end with a
1477 Normally, the resulting message is returned in a new mortal SV.
1478 During global destruction a single SV may be shared between uses of this
1479 function. If C<consume> is true, then the function is permitted (but not
1480 required) to modify and return C<basemsg> instead of allocating a new SV.
1486 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1490 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1494 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1495 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1496 && grok_atoUV(ws, &wi, NULL)
1497 && wi <= PERL_INT_MAX
1499 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1504 PERL_ARGS_ASSERT_MESS_SV;
1506 if (SvROK(basemsg)) {
1512 sv_setsv(sv, basemsg);
1517 if (SvPOK(basemsg) && consume) {
1522 sv_copypv(sv, basemsg);
1525 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1527 * Try and find the file and line for PL_op. This will usually be
1528 * PL_curcop, but it might be a cop that has been optimised away. We
1529 * can try to find such a cop by searching through the optree starting
1530 * from the sibling of PL_curcop.
1534 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1539 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1540 OutCopFILE(cop), (IV)CopLINE(cop));
1541 /* Seems that GvIO() can be untrustworthy during global destruction. */
1542 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1543 && IoLINES(GvIOp(PL_last_in_gv)))
1546 const bool line_mode = (RsSIMPLE(PL_rs) &&
1547 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1548 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1549 SVfARG(PL_last_in_gv == PL_argvgv
1551 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1552 line_mode ? "line" : "chunk",
1553 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1555 if (PL_phase == PERL_PHASE_DESTRUCT)
1556 sv_catpvs(sv, " during global destruction");
1557 sv_catpvs(sv, ".\n");
1563 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1565 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1566 argument list, respectively. These are used to generate a string message. If
1568 message does not end with a newline, then it will be extended with
1569 some indication of the current location in the code, as described for
1572 Normally, the resulting message is returned in a new mortal SV.
1573 During global destruction a single SV may be shared between uses of
1580 Perl_vmess(pTHX_ const char *pat, va_list *args)
1582 SV * const sv = mess_alloc();
1584 PERL_ARGS_ASSERT_VMESS;
1586 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1587 return mess_sv(sv, 1);
1591 Perl_write_to_stderr(pTHX_ SV* msv)
1596 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1598 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1599 && (io = GvIO(PL_stderrgv))
1600 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1601 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1602 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1604 PerlIO * const serr = Perl_error_log;
1606 do_print(msv, serr);
1607 (void)PerlIO_flush(serr);
1612 =head1 Warning and Dieing
1615 /* Common code used in dieing and warning */
1618 S_with_queued_errors(pTHX_ SV *ex)
1620 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1621 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1622 sv_catsv(PL_errors, ex);
1623 ex = sv_mortalcopy(PL_errors);
1624 SvCUR_set(PL_errors, 0);
1630 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1635 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1636 /* sv_2cv might call Perl_croak() or Perl_warner() */
1637 SV * const oldhook = *hook;
1645 cv = sv_2cv(oldhook, &stash, &gv, 0);
1647 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1657 exarg = newSVsv(ex);
1658 SvREADONLY_on(exarg);
1661 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1665 call_sv(MUTABLE_SV(cv), G_DISCARD);
1674 =for apidoc Am|OP *|die_sv|SV *baseex
1676 Behaves the same as L</croak_sv>, except for the return type.
1677 It should be used only where the C<OP *> return type is required.
1678 The function never actually returns.
1684 # pragma warning( push )
1685 # pragma warning( disable : 4646 ) /* warning C4646: function declared with
1686 __declspec(noreturn) has non-void return type */
1687 # pragma warning( disable : 4645 ) /* warning C4645: function declared with
1688 __declspec(noreturn) has a return statement */
1691 Perl_die_sv(pTHX_ SV *baseex)
1693 PERL_ARGS_ASSERT_DIE_SV;
1696 NORETURN_FUNCTION_END;
1699 # pragma warning( pop )
1703 =for apidoc Am|OP *|die|const char *pat|...
1705 Behaves the same as L</croak>, except for the return type.
1706 It should be used only where the C<OP *> return type is required.
1707 The function never actually returns.
1712 #if defined(PERL_IMPLICIT_CONTEXT)
1714 # pragma warning( push )
1715 # pragma warning( disable : 4646 ) /* warning C4646: function declared with
1716 __declspec(noreturn) has non-void return type */
1717 # pragma warning( disable : 4645 ) /* warning C4645: function declared with
1718 __declspec(noreturn) has a return statement */
1721 Perl_die_nocontext(const char* pat, ...)
1725 va_start(args, pat);
1727 NOT_REACHED; /* NOTREACHED */
1729 NORETURN_FUNCTION_END;
1732 # pragma warning( pop )
1734 #endif /* PERL_IMPLICIT_CONTEXT */
1737 # pragma warning( push )
1738 # pragma warning( disable : 4646 ) /* warning C4646: function declared with
1739 __declspec(noreturn) has non-void return type */
1740 # pragma warning( disable : 4645 ) /* warning C4645: function declared with
1741 __declspec(noreturn) has a return statement */
1744 Perl_die(pTHX_ const char* pat, ...)
1747 va_start(args, pat);
1749 NOT_REACHED; /* NOTREACHED */
1751 NORETURN_FUNCTION_END;
1754 # pragma warning( pop )
1758 =for apidoc Am|void|croak_sv|SV *baseex
1760 This is an XS interface to Perl's C<die> function.
1762 C<baseex> is the error message or object. If it is a reference, it
1763 will be used as-is. Otherwise it is used as a string, and if it does
1764 not end with a newline then it will be extended with some indication of
1765 the current location in the code, as described for L</mess_sv>.
1767 The error message or object will be used as an exception, by default
1768 returning control to the nearest enclosing C<eval>, but subject to
1769 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1770 function never returns normally.
1772 To die with a simple string message, the L</croak> function may be
1779 Perl_croak_sv(pTHX_ SV *baseex)
1781 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1782 PERL_ARGS_ASSERT_CROAK_SV;
1783 invoke_exception_hook(ex, FALSE);
1788 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1790 This is an XS interface to Perl's C<die> function.
1792 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1793 argument list. These are used to generate a string message. If the
1794 message does not end with a newline, then it will be extended with
1795 some indication of the current location in the code, as described for
1798 The error message will be used as an exception, by default
1799 returning control to the nearest enclosing C<eval>, but subject to
1800 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1801 function never returns normally.
1803 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1804 (C<$@>) will be used as an error message or object instead of building an
1805 error message from arguments. If you want to throw a non-string object,
1806 or build an error message in an SV yourself, it is preferable to use
1807 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1813 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1815 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1816 invoke_exception_hook(ex, FALSE);
1821 =for apidoc Am|void|croak|const char *pat|...
1823 This is an XS interface to Perl's C<die> function.
1825 Take a sprintf-style format pattern and argument list. These are used to
1826 generate a string message. If the message does not end with a newline,
1827 then it will be extended with some indication of the current location
1828 in the code, as described for L</mess_sv>.
1830 The error message will be used as an exception, by default
1831 returning control to the nearest enclosing C<eval>, but subject to
1832 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1833 function never returns normally.
1835 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1836 (C<$@>) will be used as an error message or object instead of building an
1837 error message from arguments. If you want to throw a non-string object,
1838 or build an error message in an SV yourself, it is preferable to use
1839 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1844 #if defined(PERL_IMPLICIT_CONTEXT)
1846 Perl_croak_nocontext(const char *pat, ...)
1850 va_start(args, pat);
1852 NOT_REACHED; /* NOTREACHED */
1855 #endif /* PERL_IMPLICIT_CONTEXT */
1858 Perl_croak(pTHX_ const char *pat, ...)
1861 va_start(args, pat);
1863 NOT_REACHED; /* NOTREACHED */
1868 =for apidoc Am|void|croak_no_modify
1870 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1871 terser object code than using C<Perl_croak>. Less code used on exception code
1872 paths reduces CPU cache pressure.
1878 Perl_croak_no_modify(void)
1880 Perl_croak_nocontext( "%s", PL_no_modify);
1883 /* does not return, used in util.c perlio.c and win32.c
1884 This is typically called when malloc returns NULL.
1887 Perl_croak_no_mem(void)
1891 int fd = PerlIO_fileno(Perl_error_log);
1893 SETERRNO(EBADF,RMS_IFI);
1895 /* Can't use PerlIO to write as it allocates memory */
1896 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
1901 /* does not return, used only in POPSTACK */
1903 Perl_croak_popstack(void)
1906 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1911 =for apidoc Am|void|warn_sv|SV *baseex
1913 This is an XS interface to Perl's C<warn> function.
1915 C<baseex> is the error message or object. If it is a reference, it
1916 will be used as-is. Otherwise it is used as a string, and if it does
1917 not end with a newline then it will be extended with some indication of
1918 the current location in the code, as described for L</mess_sv>.
1920 The error message or object will by default be written to standard error,
1921 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1923 To warn with a simple string message, the L</warn> function may be
1930 Perl_warn_sv(pTHX_ SV *baseex)
1932 SV *ex = mess_sv(baseex, 0);
1933 PERL_ARGS_ASSERT_WARN_SV;
1934 if (!invoke_exception_hook(ex, TRUE))
1935 write_to_stderr(ex);
1939 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1941 This is an XS interface to Perl's C<warn> function.
1943 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1944 argument list. These are used to generate a string message. If the
1945 message does not end with a newline, then it will be extended with
1946 some indication of the current location in the code, as described for
1949 The error message or object will by default be written to standard error,
1950 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1952 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1958 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1960 SV *ex = vmess(pat, args);
1961 PERL_ARGS_ASSERT_VWARN;
1962 if (!invoke_exception_hook(ex, TRUE))
1963 write_to_stderr(ex);
1967 =for apidoc Am|void|warn|const char *pat|...
1969 This is an XS interface to Perl's C<warn> function.
1971 Take a sprintf-style format pattern and argument list. These are used to
1972 generate a string message. If the message does not end with a newline,
1973 then it will be extended with some indication of the current location
1974 in the code, as described for L</mess_sv>.
1976 The error message or object will by default be written to standard error,
1977 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1979 Unlike with L</croak>, C<pat> is not permitted to be null.
1984 #if defined(PERL_IMPLICIT_CONTEXT)
1986 Perl_warn_nocontext(const char *pat, ...)
1990 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1991 va_start(args, pat);
1995 #endif /* PERL_IMPLICIT_CONTEXT */
1998 Perl_warn(pTHX_ const char *pat, ...)
2001 PERL_ARGS_ASSERT_WARN;
2002 va_start(args, pat);
2007 #if defined(PERL_IMPLICIT_CONTEXT)
2009 Perl_warner_nocontext(U32 err, const char *pat, ...)
2013 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
2014 va_start(args, pat);
2015 vwarner(err, pat, &args);
2018 #endif /* PERL_IMPLICIT_CONTEXT */
2021 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2023 PERL_ARGS_ASSERT_CK_WARNER_D;
2025 if (Perl_ckwarn_d(aTHX_ err)) {
2027 va_start(args, pat);
2028 vwarner(err, pat, &args);
2034 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2036 PERL_ARGS_ASSERT_CK_WARNER;
2038 if (Perl_ckwarn(aTHX_ err)) {
2040 va_start(args, pat);
2041 vwarner(err, pat, &args);
2047 Perl_warner(pTHX_ U32 err, const char* pat,...)
2050 PERL_ARGS_ASSERT_WARNER;
2051 va_start(args, pat);
2052 vwarner(err, pat, &args);
2057 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
2060 PERL_ARGS_ASSERT_VWARNER;
2062 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2063 !(PL_in_eval & EVAL_KEEPERR)
2065 SV * const msv = vmess(pat, args);
2067 if (PL_parser && PL_parser->error_count) {
2071 invoke_exception_hook(msv, FALSE);
2076 Perl_vwarn(aTHX_ pat, args);
2080 /* implements the ckWARN? macros */
2083 Perl_ckwarn(pTHX_ U32 w)
2085 /* If lexical warnings have not been set, use $^W. */
2087 return PL_dowarn & G_WARN_ON;
2089 return ckwarn_common(w);
2092 /* implements the ckWARN?_d macro */
2095 Perl_ckwarn_d(pTHX_ U32 w)
2097 /* If lexical warnings have not been set then default classes warn. */
2101 return ckwarn_common(w);
2105 S_ckwarn_common(pTHX_ U32 w)
2107 if (PL_curcop->cop_warnings == pWARN_ALL)
2110 if (PL_curcop->cop_warnings == pWARN_NONE)
2113 /* Check the assumption that at least the first slot is non-zero. */
2114 assert(unpackWARN1(w));
2116 /* Check the assumption that it is valid to stop as soon as a zero slot is
2118 if (!unpackWARN2(w)) {
2119 assert(!unpackWARN3(w));
2120 assert(!unpackWARN4(w));
2121 } else if (!unpackWARN3(w)) {
2122 assert(!unpackWARN4(w));
2125 /* Right, dealt with all the special cases, which are implemented as non-
2126 pointers, so there is a pointer to a real warnings mask. */
2128 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2130 } while (w >>= WARNshift);
2135 /* Set buffer=NULL to get a new one. */
2137 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2139 const MEM_SIZE len_wanted =
2140 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2141 PERL_UNUSED_CONTEXT;
2142 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2145 (specialWARN(buffer) ?
2146 PerlMemShared_malloc(len_wanted) :
2147 PerlMemShared_realloc(buffer, len_wanted));
2149 Copy(bits, (buffer + 1), size, char);
2150 if (size < WARNsize)
2151 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2155 /* since we've already done strlen() for both nam and val
2156 * we can use that info to make things faster than
2157 * sprintf(s, "%s=%s", nam, val)
2159 #define my_setenv_format(s, nam, nlen, val, vlen) \
2160 Copy(nam, s, nlen, char); \
2162 Copy(val, s+(nlen+1), vlen, char); \
2163 *(s+(nlen+1+vlen)) = '\0'
2165 #ifdef USE_ENVIRON_ARRAY
2166 /* VMS' my_setenv() is in vms.c */
2167 #if !defined(WIN32) && !defined(NETWARE)
2169 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2173 amigaos4_obtain_environ(__FUNCTION__);
2176 /* only parent thread can modify process environment */
2177 if (PL_curinterp == aTHX)
2180 #ifndef PERL_USE_SAFE_PUTENV
2181 if (!PL_use_safe_putenv) {
2182 /* most putenv()s leak, so we manipulate environ directly */
2184 const I32 len = strlen(nam);
2187 /* where does it go? */
2188 for (i = 0; environ[i]; i++) {
2189 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2193 if (environ == PL_origenviron) { /* need we copy environment? */
2199 while (environ[max])
2201 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2202 for (j=0; j<max; j++) { /* copy environment */
2203 const int len = strlen(environ[j]);
2204 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2205 Copy(environ[j], tmpenv[j], len+1, char);
2208 environ = tmpenv; /* tell exec where it is now */
2211 safesysfree(environ[i]);
2212 while (environ[i]) {
2213 environ[i] = environ[i+1];
2222 if (!environ[i]) { /* does not exist yet */
2223 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2224 environ[i+1] = NULL; /* make sure it's null terminated */
2227 safesysfree(environ[i]);
2231 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2232 /* all that work just for this */
2233 my_setenv_format(environ[i], nam, nlen, val, vlen);
2236 /* This next branch should only be called #if defined(HAS_SETENV), but
2237 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
2238 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2240 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2241 # if defined(HAS_UNSETENV)
2243 (void)unsetenv(nam);
2245 (void)setenv(nam, val, 1);
2247 # else /* ! HAS_UNSETENV */
2248 (void)setenv(nam, val, 1);
2249 # endif /* HAS_UNSETENV */
2251 # if defined(HAS_UNSETENV)
2253 if (environ) /* old glibc can crash with null environ */
2254 (void)unsetenv(nam);
2256 const int nlen = strlen(nam);
2257 const int vlen = strlen(val);
2258 char * const new_env =
2259 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2260 my_setenv_format(new_env, nam, nlen, val, vlen);
2261 (void)putenv(new_env);
2263 # else /* ! HAS_UNSETENV */
2265 const int nlen = strlen(nam);
2271 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2272 /* all that work just for this */
2273 my_setenv_format(new_env, nam, nlen, val, vlen);
2274 (void)putenv(new_env);
2275 # endif /* HAS_UNSETENV */
2276 # endif /* __CYGWIN__ */
2277 #ifndef PERL_USE_SAFE_PUTENV
2283 amigaos4_release_environ(__FUNCTION__);
2287 #else /* WIN32 || NETWARE */
2290 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2294 const int nlen = strlen(nam);
2301 Newx(envstr, nlen+vlen+2, char);
2302 my_setenv_format(envstr, nam, nlen, val, vlen);
2303 (void)PerlEnv_putenv(envstr);
2307 #endif /* WIN32 || NETWARE */
2311 #ifdef UNLINK_ALL_VERSIONS
2313 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2317 PERL_ARGS_ASSERT_UNLNK;
2319 while (PerlLIO_unlink(f) >= 0)
2321 return retries ? 0 : -1;
2325 /* this is a drop-in replacement for bcopy(), except for the return
2326 * value, which we need to be able to emulate memcpy() */
2327 #if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
2329 Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
2331 #if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
2332 bcopy(vfrom, vto, len);
2334 const unsigned char *from = (const unsigned char *)vfrom;
2335 unsigned char *to = (unsigned char *)vto;
2337 PERL_ARGS_ASSERT_MY_BCOPY;
2339 if (from - to >= 0) {
2347 *(--to) = *(--from);
2355 /* this is a drop-in replacement for memset() */
2358 Perl_my_memset(void *vloc, int ch, size_t len)
2360 unsigned char *loc = (unsigned char *)vloc;
2362 PERL_ARGS_ASSERT_MY_MEMSET;
2370 /* this is a drop-in replacement for bzero() */
2371 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2373 Perl_my_bzero(void *vloc, size_t len)
2375 unsigned char *loc = (unsigned char *)vloc;
2377 PERL_ARGS_ASSERT_MY_BZERO;
2385 /* this is a drop-in replacement for memcmp() */
2386 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2388 Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
2390 const U8 *a = (const U8 *)vs1;
2391 const U8 *b = (const U8 *)vs2;
2394 PERL_ARGS_ASSERT_MY_MEMCMP;
2397 if ((tmp = *a++ - *b++))
2402 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2405 /* This vsprintf replacement should generally never get used, since
2406 vsprintf was available in both System V and BSD 2.11. (There may
2407 be some cross-compilation or embedded set-ups where it is needed,
2410 If you encounter a problem in this function, it's probably a symptom
2411 that Configure failed to detect your system's vprintf() function.
2412 See the section on "item vsprintf" in the INSTALL file.
2414 This version may compile on systems with BSD-ish <stdio.h>,
2415 but probably won't on others.
2418 #ifdef USE_CHAR_VSPRINTF
2423 vsprintf(char *dest, const char *pat, void *args)
2427 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2428 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2429 FILE_cnt(&fakebuf) = 32767;
2431 /* These probably won't compile -- If you really need
2432 this, you'll have to figure out some other method. */
2433 fakebuf._ptr = dest;
2434 fakebuf._cnt = 32767;
2439 fakebuf._flag = _IOWRT|_IOSTRG;
2440 _doprnt(pat, args, &fakebuf); /* what a kludge */
2441 #if defined(STDIO_PTR_LVALUE)
2442 *(FILE_ptr(&fakebuf)++) = '\0';
2444 /* PerlIO has probably #defined away fputc, but we want it here. */
2446 # undef fputc /* XXX Should really restore it later */
2448 (void)fputc('\0', &fakebuf);
2450 #ifdef USE_CHAR_VSPRINTF
2453 return 0; /* perl doesn't use return value */
2457 #endif /* HAS_VPRINTF */
2460 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2462 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2470 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2472 PERL_FLUSHALL_FOR_CHILD;
2473 This = (*mode == 'w');
2477 taint_proper("Insecure %s%s", "EXEC");
2479 if (PerlProc_pipe(p) < 0)
2481 /* Try for another pipe pair for error return */
2482 if (PerlProc_pipe(pp) >= 0)
2484 while ((pid = PerlProc_fork()) < 0) {
2485 if (errno != EAGAIN) {
2486 PerlLIO_close(p[This]);
2487 PerlLIO_close(p[that]);
2489 PerlLIO_close(pp[0]);
2490 PerlLIO_close(pp[1]);
2494 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2503 /* Close parent's end of error status pipe (if any) */
2505 PerlLIO_close(pp[0]);
2506 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2507 /* Close error pipe automatically if exec works */
2508 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2512 /* Now dup our end of _the_ pipe to right position */
2513 if (p[THIS] != (*mode == 'r')) {
2514 PerlLIO_dup2(p[THIS], *mode == 'r');
2515 PerlLIO_close(p[THIS]);
2516 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2517 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2520 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2521 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2522 /* No automatic close - do it by hand */
2529 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2535 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2541 do_execfree(); /* free any memory malloced by child on fork */
2543 PerlLIO_close(pp[1]);
2544 /* Keep the lower of the two fd numbers */
2545 if (p[that] < p[This]) {
2546 PerlLIO_dup2(p[This], p[that]);
2547 PerlLIO_close(p[This]);
2551 PerlLIO_close(p[that]); /* close child's end of pipe */
2553 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2554 SvUPGRADE(sv,SVt_IV);
2556 PL_forkprocess = pid;
2557 /* If we managed to get status pipe check for exec fail */
2558 if (did_pipes && pid > 0) {
2563 while (n < sizeof(int)) {
2564 n1 = PerlLIO_read(pp[0],
2565 (void*)(((char*)&errkid)+n),
2571 PerlLIO_close(pp[0]);
2573 if (n) { /* Error */
2575 PerlLIO_close(p[This]);
2576 if (n != sizeof(int))
2577 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2579 pid2 = wait4pid(pid, &status, 0);
2580 } while (pid2 == -1 && errno == EINTR);
2581 errno = errkid; /* Propagate errno from kid */
2586 PerlLIO_close(pp[0]);
2587 return PerlIO_fdopen(p[This], mode);
2589 # if defined(OS2) /* Same, without fork()ing and all extra overhead... */
2590 return my_syspopen4(aTHX_ NULL, mode, n, args);
2591 # elif defined(WIN32)
2592 return win32_popenlist(mode, n, args);
2594 Perl_croak(aTHX_ "List form of piped open not implemented");
2595 return (PerlIO *) NULL;
2600 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2601 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2603 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2609 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2613 PERL_ARGS_ASSERT_MY_POPEN;
2615 PERL_FLUSHALL_FOR_CHILD;
2618 return my_syspopen(aTHX_ cmd,mode);
2621 This = (*mode == 'w');
2623 if (doexec && TAINTING_get) {
2625 taint_proper("Insecure %s%s", "EXEC");
2627 if (PerlProc_pipe(p) < 0)
2629 if (doexec && PerlProc_pipe(pp) >= 0)
2631 while ((pid = PerlProc_fork()) < 0) {
2632 if (errno != EAGAIN) {
2633 PerlLIO_close(p[This]);
2634 PerlLIO_close(p[that]);
2636 PerlLIO_close(pp[0]);
2637 PerlLIO_close(pp[1]);
2640 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2643 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2653 PerlLIO_close(pp[0]);
2654 #if defined(HAS_FCNTL) && defined(F_SETFD)
2655 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2659 if (p[THIS] != (*mode == 'r')) {
2660 PerlLIO_dup2(p[THIS], *mode == 'r');
2661 PerlLIO_close(p[THIS]);
2662 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2663 PerlLIO_close(p[THAT]);
2666 PerlLIO_close(p[THAT]);
2669 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2676 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2681 /* may or may not use the shell */
2682 do_exec3(cmd, pp[1], did_pipes);
2685 #endif /* defined OS2 */
2687 #ifdef PERLIO_USING_CRLF
2688 /* Since we circumvent IO layers when we manipulate low-level
2689 filedescriptors directly, need to manually switch to the
2690 default, binary, low-level mode; see PerlIOBuf_open(). */
2691 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2694 #ifdef PERL_USES_PL_PIDSTATUS
2695 hv_clear(PL_pidstatus); /* we have no children */
2701 do_execfree(); /* free any memory malloced by child on vfork */
2703 PerlLIO_close(pp[1]);
2704 if (p[that] < p[This]) {
2705 PerlLIO_dup2(p[This], p[that]);
2706 PerlLIO_close(p[This]);
2710 PerlLIO_close(p[that]);
2712 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2713 SvUPGRADE(sv,SVt_IV);
2715 PL_forkprocess = pid;
2716 if (did_pipes && pid > 0) {
2721 while (n < sizeof(int)) {
2722 n1 = PerlLIO_read(pp[0],
2723 (void*)(((char*)&errkid)+n),
2729 PerlLIO_close(pp[0]);
2731 if (n) { /* Error */
2733 PerlLIO_close(p[This]);
2734 if (n != sizeof(int))
2735 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2737 pid2 = wait4pid(pid, &status, 0);
2738 } while (pid2 == -1 && errno == EINTR);
2739 errno = errkid; /* Propagate errno from kid */
2744 PerlLIO_close(pp[0]);
2745 return PerlIO_fdopen(p[This], mode);
2749 FILE *djgpp_popen();
2751 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2753 PERL_FLUSHALL_FOR_CHILD;
2754 /* Call system's popen() to get a FILE *, then import it.
2755 used 0 for 2nd parameter to PerlIO_importFILE;
2758 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2761 #if defined(__LIBCATAMOUNT__)
2763 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2770 #endif /* !DOSISH */
2772 /* this is called in parent before the fork() */
2774 Perl_atfork_lock(void)
2775 #if defined(USE_ITHREADS)
2777 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2780 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2782 PERL_TSA_ACQUIRE(PL_op_mutex)
2785 #if defined(USE_ITHREADS)
2787 /* locks must be held in locking order (if any) */
2789 MUTEX_LOCK(&PL_perlio_mutex);
2792 MUTEX_LOCK(&PL_malloc_mutex);
2798 /* this is called in both parent and child after the fork() */
2800 Perl_atfork_unlock(void)
2801 #if defined(USE_ITHREADS)
2803 PERL_TSA_RELEASE(PL_perlio_mutex)
2806 PERL_TSA_RELEASE(PL_malloc_mutex)
2808 PERL_TSA_RELEASE(PL_op_mutex)
2811 #if defined(USE_ITHREADS)
2813 /* locks must be released in same order as in atfork_lock() */
2815 MUTEX_UNLOCK(&PL_perlio_mutex);
2818 MUTEX_UNLOCK(&PL_malloc_mutex);
2827 #if defined(HAS_FORK)
2829 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2834 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2835 * handlers elsewhere in the code */
2839 #elif defined(__amigaos4__)
2840 return amigaos_fork();
2842 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2843 Perl_croak_nocontext("fork() not available");
2845 #endif /* HAS_FORK */
2850 dup2(int oldfd, int newfd)
2852 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2855 PerlLIO_close(newfd);
2856 return fcntl(oldfd, F_DUPFD, newfd);
2858 #define DUP2_MAX_FDS 256
2859 int fdtmp[DUP2_MAX_FDS];
2865 PerlLIO_close(newfd);
2866 /* good enough for low fd's... */
2867 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2868 if (fdx >= DUP2_MAX_FDS) {
2876 PerlLIO_close(fdtmp[--fdx]);
2883 #ifdef HAS_SIGACTION
2886 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2888 struct sigaction act, oact;
2892 /* only "parent" interpreter can diddle signals */
2893 if (PL_curinterp != aTHX)
2894 return (Sighandler_t) SIG_ERR;
2897 act.sa_handler = (void(*)(int))handler;
2898 sigemptyset(&act.sa_mask);
2901 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2902 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2904 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2905 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2906 act.sa_flags |= SA_NOCLDWAIT;
2908 if (sigaction(signo, &act, &oact) == -1)
2909 return (Sighandler_t) SIG_ERR;
2911 return (Sighandler_t) oact.sa_handler;
2915 Perl_rsignal_state(pTHX_ int signo)
2917 struct sigaction oact;
2918 PERL_UNUSED_CONTEXT;
2920 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2921 return (Sighandler_t) SIG_ERR;
2923 return (Sighandler_t) oact.sa_handler;
2927 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2932 struct sigaction act;
2934 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2937 /* only "parent" interpreter can diddle signals */
2938 if (PL_curinterp != aTHX)
2942 act.sa_handler = (void(*)(int))handler;
2943 sigemptyset(&act.sa_mask);
2946 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2947 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2949 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2950 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2951 act.sa_flags |= SA_NOCLDWAIT;
2953 return sigaction(signo, &act, save);
2957 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2962 PERL_UNUSED_CONTEXT;
2964 /* only "parent" interpreter can diddle signals */
2965 if (PL_curinterp != aTHX)
2969 return sigaction(signo, save, (struct sigaction *)NULL);
2972 #else /* !HAS_SIGACTION */
2975 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2977 #if defined(USE_ITHREADS) && !defined(WIN32)
2978 /* only "parent" interpreter can diddle signals */
2979 if (PL_curinterp != aTHX)
2980 return (Sighandler_t) SIG_ERR;
2983 return PerlProc_signal(signo, handler);
2994 Perl_rsignal_state(pTHX_ int signo)
2997 Sighandler_t oldsig;
2999 #if defined(USE_ITHREADS) && !defined(WIN32)
3000 /* only "parent" interpreter can diddle signals */
3001 if (PL_curinterp != aTHX)
3002 return (Sighandler_t) SIG_ERR;
3006 oldsig = PerlProc_signal(signo, sig_trap);
3007 PerlProc_signal(signo, oldsig);
3009 PerlProc_kill(PerlProc_getpid(), signo);
3014 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3016 #if defined(USE_ITHREADS) && !defined(WIN32)
3017 /* only "parent" interpreter can diddle signals */
3018 if (PL_curinterp != aTHX)
3021 *save = PerlProc_signal(signo, handler);
3022 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3026 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3028 #if defined(USE_ITHREADS) && !defined(WIN32)
3029 /* only "parent" interpreter can diddle signals */
3030 if (PL_curinterp != aTHX)
3033 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3036 #endif /* !HAS_SIGACTION */
3037 #endif /* !PERL_MICRO */
3039 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3040 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3042 Perl_my_pclose(pTHX_ PerlIO *ptr)
3050 const int fd = PerlIO_fileno(ptr);
3053 svp = av_fetch(PL_fdpid,fd,TRUE);
3054 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3058 #if defined(USE_PERLIO)
3059 /* Find out whether the refcount is low enough for us to wait for the
3060 child proc without blocking. */
3061 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3063 should_wait = pid > 0;
3067 if (pid == -1) { /* Opened by popen. */
3068 return my_syspclose(ptr);
3071 close_failed = (PerlIO_close(ptr) == EOF);
3073 if (should_wait) do {
3074 pid2 = wait4pid(pid, &status, 0);
3075 } while (pid2 == -1 && errno == EINTR);
3082 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3087 #if defined(__LIBCATAMOUNT__)
3089 Perl_my_pclose(pTHX_ PerlIO *ptr)
3094 #endif /* !DOSISH */
3096 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3098 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3101 PERL_ARGS_ASSERT_WAIT4PID;
3102 #ifdef PERL_USES_PL_PIDSTATUS
3104 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3105 waitpid() nor wait4() is available, or on OS/2, which
3106 doesn't appear to support waiting for a progress group
3107 member, so we can only treat a 0 pid as an unknown child.
3114 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3115 pid, rather than a string form. */
3116 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3117 if (svp && *svp != &PL_sv_undef) {
3118 *statusp = SvIVX(*svp);
3119 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3127 hv_iterinit(PL_pidstatus);
3128 if ((entry = hv_iternext(PL_pidstatus))) {
3129 SV * const sv = hv_iterval(PL_pidstatus,entry);
3131 const char * const spid = hv_iterkey(entry,&len);
3133 assert (len == sizeof(Pid_t));
3134 memcpy((char *)&pid, spid, len);
3135 *statusp = SvIVX(sv);
3136 /* The hash iterator is currently on this entry, so simply
3137 calling hv_delete would trigger the lazy delete, which on
3138 aggregate does more work, because next call to hv_iterinit()
3139 would spot the flag, and have to call the delete routine,
3140 while in the meantime any new entries can't re-use that
3142 hv_iterinit(PL_pidstatus);
3143 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3150 # ifdef HAS_WAITPID_RUNTIME
3151 if (!HAS_WAITPID_RUNTIME)
3154 result = PerlProc_waitpid(pid,statusp,flags);
3157 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3158 result = wait4(pid,statusp,flags,NULL);
3161 #ifdef PERL_USES_PL_PIDSTATUS
3162 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3167 Perl_croak(aTHX_ "Can't do waitpid with flags");
3169 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3170 pidgone(result,*statusp);
3176 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3179 if (result < 0 && errno == EINTR) {
3181 errno = EINTR; /* reset in case a signal handler changed $! */
3185 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3187 #ifdef PERL_USES_PL_PIDSTATUS
3189 S_pidgone(pTHX_ Pid_t pid, int status)
3193 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3194 SvUPGRADE(sv,SVt_IV);
3195 SvIV_set(sv, status);
3203 int /* Cannot prototype with I32
3205 my_syspclose(PerlIO *ptr)
3208 Perl_my_pclose(pTHX_ PerlIO *ptr)
3211 /* Needs work for PerlIO ! */
3212 FILE * const f = PerlIO_findFILE(ptr);
3213 const I32 result = pclose(f);
3214 PerlIO_releaseFILE(ptr,f);
3222 Perl_my_pclose(pTHX_ PerlIO *ptr)
3224 /* Needs work for PerlIO ! */
3225 FILE * const f = PerlIO_findFILE(ptr);
3226 I32 result = djgpp_pclose(f);
3227 result = (result << 8) & 0xff00;
3228 PerlIO_releaseFILE(ptr,f);
3233 #define PERL_REPEATCPY_LINEAR 4
3235 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3237 PERL_ARGS_ASSERT_REPEATCPY;
3242 croak_memory_wrap();
3245 memset(to, *from, count);
3248 IV items, linear, half;
3250 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3251 for (items = 0; items < linear; ++items) {
3252 const char *q = from;
3254 for (todo = len; todo > 0; todo--)
3259 while (items <= half) {
3260 IV size = items * len;
3261 memcpy(p, to, size);
3267 memcpy(p, to, (count - items) * len);
3273 Perl_same_dirent(pTHX_ const char *a, const char *b)
3275 char *fa = strrchr(a,'/');
3276 char *fb = strrchr(b,'/');
3279 SV * const tmpsv = sv_newmortal();
3281 PERL_ARGS_ASSERT_SAME_DIRENT;
3294 sv_setpvs(tmpsv, ".");
3296 sv_setpvn(tmpsv, a, fa - a);
3297 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3300 sv_setpvs(tmpsv, ".");
3302 sv_setpvn(tmpsv, b, fb - b);
3303 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3305 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3306 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3308 #endif /* !HAS_RENAME */
3311 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3312 const char *const *const search_ext, I32 flags)
3314 const char *xfound = NULL;
3315 char *xfailed = NULL;
3316 char tmpbuf[MAXPATHLEN];
3321 #if defined(DOSISH) && !defined(OS2)
3322 # define SEARCH_EXTS ".bat", ".cmd", NULL
3323 # define MAX_EXT_LEN 4
3326 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3327 # define MAX_EXT_LEN 4
3330 # define SEARCH_EXTS ".pl", ".com", NULL
3331 # define MAX_EXT_LEN 4
3333 /* additional extensions to try in each dir if scriptname not found */
3335 static const char *const exts[] = { SEARCH_EXTS };
3336 const char *const *const ext = search_ext ? search_ext : exts;
3337 int extidx = 0, i = 0;
3338 const char *curext = NULL;
3340 PERL_UNUSED_ARG(search_ext);
3341 # define MAX_EXT_LEN 0
3344 PERL_ARGS_ASSERT_FIND_SCRIPT;
3347 * If dosearch is true and if scriptname does not contain path
3348 * delimiters, search the PATH for scriptname.
3350 * If SEARCH_EXTS is also defined, will look for each
3351 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3352 * while searching the PATH.
3354 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3355 * proceeds as follows:
3356 * If DOSISH or VMSISH:
3357 * + look for ./scriptname{,.foo,.bar}
3358 * + search the PATH for scriptname{,.foo,.bar}
3361 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3362 * this will not look in '.' if it's not in the PATH)
3367 # ifdef ALWAYS_DEFTYPES
3368 len = strlen(scriptname);
3369 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3370 int idx = 0, deftypes = 1;
3373 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3376 int idx = 0, deftypes = 1;
3379 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3381 /* The first time through, just add SEARCH_EXTS to whatever we
3382 * already have, so we can check for default file types. */
3384 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3391 if ((strlen(tmpbuf) + strlen(scriptname)
3392 + MAX_EXT_LEN) >= sizeof tmpbuf)
3393 continue; /* don't search dir with too-long name */
3394 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3398 if (strEQ(scriptname, "-"))
3400 if (dosearch) { /* Look in '.' first. */
3401 const char *cur = scriptname;
3403 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3405 if (strEQ(ext[i++],curext)) {
3406 extidx = -1; /* already has an ext */
3411 DEBUG_p(PerlIO_printf(Perl_debug_log,
3412 "Looking for %s\n",cur));
3415 if (PerlLIO_stat(cur,&statbuf) >= 0
3416 && !S_ISDIR(statbuf.st_mode)) {
3425 if (cur == scriptname) {
3426 len = strlen(scriptname);
3427 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3429 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3432 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3433 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3438 if (dosearch && !strchr(scriptname, '/')
3440 && !strchr(scriptname, '\\')
3442 && (s = PerlEnv_getenv("PATH")))
3446 bufend = s + strlen(s);
3447 while (s < bufend) {
3451 && *s != ';'; len++, s++) {
3452 if (len < sizeof tmpbuf)
3455 if (len < sizeof tmpbuf)
3458 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3464 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3465 continue; /* don't search dir with too-long name */
3468 && tmpbuf[len - 1] != '/'
3469 && tmpbuf[len - 1] != '\\'
3472 tmpbuf[len++] = '/';
3473 if (len == 2 && tmpbuf[0] == '.')
3475 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3479 len = strlen(tmpbuf);
3480 if (extidx > 0) /* reset after previous loop */
3484 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3485 retval = PerlLIO_stat(tmpbuf,&statbuf);
3486 if (S_ISDIR(statbuf.st_mode)) {
3490 } while ( retval < 0 /* not there */
3491 && extidx>=0 && ext[extidx] /* try an extension? */
3492 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3497 if (S_ISREG(statbuf.st_mode)
3498 && cando(S_IRUSR,TRUE,&statbuf)
3499 #if !defined(DOSISH)
3500 && cando(S_IXUSR,TRUE,&statbuf)
3504 xfound = tmpbuf; /* bingo! */
3508 xfailed = savepv(tmpbuf);
3513 if (!xfound && !seen_dot && !xfailed &&
3514 (PerlLIO_stat(scriptname,&statbuf) < 0
3515 || S_ISDIR(statbuf.st_mode)))
3517 seen_dot = 1; /* Disable message. */
3522 if (flags & 1) { /* do or die? */
3523 /* diag_listed_as: Can't execute %s */
3524 Perl_croak(aTHX_ "Can't %s %s%s%s",
3525 (xfailed ? "execute" : "find"),
3526 (xfailed ? xfailed : scriptname),
3527 (xfailed ? "" : " on PATH"),
3528 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3533 scriptname = xfound;
3535 return (scriptname ? savepv(scriptname) : NULL);
3538 #ifndef PERL_GET_CONTEXT_DEFINED
3541 Perl_get_context(void)
3543 #if defined(USE_ITHREADS)
3545 # ifdef OLD_PTHREADS_API
3547 int error = pthread_getspecific(PL_thr_key, &t)
3549 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3552 # ifdef I_MACH_CTHREADS
3553 return (void*)cthread_data(cthread_self());
3555 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3564 Perl_set_context(void *t)
3566 #if defined(USE_ITHREADS)
3569 PERL_ARGS_ASSERT_SET_CONTEXT;
3570 #if defined(USE_ITHREADS)
3571 # ifdef I_MACH_CTHREADS
3572 cthread_set_data(cthread_self(), t);
3575 const int error = pthread_setspecific(PL_thr_key, t);
3577 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3585 #endif /* !PERL_GET_CONTEXT_DEFINED */
3587 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3591 PERL_UNUSED_CONTEXT;
3597 Perl_get_op_names(pTHX)
3599 PERL_UNUSED_CONTEXT;
3600 return (char **)PL_op_name;
3604 Perl_get_op_descs(pTHX)
3606 PERL_UNUSED_CONTEXT;
3607 return (char **)PL_op_desc;
3611 Perl_get_no_modify(pTHX)
3613 PERL_UNUSED_CONTEXT;
3614 return PL_no_modify;
3618 Perl_get_opargs(pTHX)
3620 PERL_UNUSED_CONTEXT;
3621 return (U32 *)PL_opargs;
3625 Perl_get_ppaddr(pTHX)
3628 PERL_UNUSED_CONTEXT;
3629 return (PPADDR_t*)PL_ppaddr;
3632 #ifndef HAS_GETENV_LEN
3634 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3636 char * const env_trans = PerlEnv_getenv(env_elem);
3637 PERL_UNUSED_CONTEXT;
3638 PERL_ARGS_ASSERT_GETENV_LEN;
3640 *len = strlen(env_trans);
3647 Perl_get_vtbl(pTHX_ int vtbl_id)
3649 PERL_UNUSED_CONTEXT;
3651 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3652 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3656 Perl_my_fflush_all(pTHX)
3658 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3659 return PerlIO_flush(NULL);
3661 # if defined(HAS__FWALK)
3662 extern int fflush(FILE *);
3663 /* undocumented, unprototyped, but very useful BSDism */
3664 extern void _fwalk(int (*)(FILE *));
3668 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3670 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3671 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3673 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3674 open_max = sysconf(_SC_OPEN_MAX);
3677 open_max = FOPEN_MAX;
3680 open_max = OPEN_MAX;
3691 for (i = 0; i < open_max; i++)
3692 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3693 STDIO_STREAM_ARRAY[i]._file < open_max &&
3694 STDIO_STREAM_ARRAY[i]._flag)
3695 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3699 SETERRNO(EBADF,RMS_IFI);
3706 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3708 if (ckWARN(WARN_IO)) {
3710 = gv && (isGV_with_GP(gv))
3713 const char * const direction = have == '>' ? "out" : "in";
3715 if (name && HEK_LEN(name))
3716 Perl_warner(aTHX_ packWARN(WARN_IO),
3717 "Filehandle %"HEKf" opened only for %sput",
3718 HEKfARG(name), direction);
3720 Perl_warner(aTHX_ packWARN(WARN_IO),
3721 "Filehandle opened only for %sput", direction);
3726 Perl_report_evil_fh(pTHX_ const GV *gv)
3728 const IO *io = gv ? GvIO(gv) : NULL;
3729 const PERL_BITFIELD16 op = PL_op->op_type;
3733 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3735 warn_type = WARN_CLOSED;
3739 warn_type = WARN_UNOPENED;
3742 if (ckWARN(warn_type)) {
3744 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3745 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3746 const char * const pars =
3747 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3748 const char * const func =
3750 (op == OP_READLINE || op == OP_RCATLINE
3751 ? "readline" : /* "<HANDLE>" not nice */
3752 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3754 const char * const type =
3756 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3757 ? "socket" : "filehandle");
3758 const bool have_name = name && SvCUR(name);
3759 Perl_warner(aTHX_ packWARN(warn_type),
3760 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3761 have_name ? " " : "",
3762 SVfARG(have_name ? name : &PL_sv_no));
3763 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3765 aTHX_ packWARN(warn_type),
3766 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3767 func, pars, have_name ? " " : "",
3768 SVfARG(have_name ? name : &PL_sv_no)
3773 /* To workaround core dumps from the uninitialised tm_zone we get the
3774 * system to give us a reasonable struct to copy. This fix means that
3775 * strftime uses the tm_zone and tm_gmtoff values returned by
3776 * localtime(time()). That should give the desired result most of the
3777 * time. But probably not always!
3779 * This does not address tzname aspects of NETaa14816.
3784 # ifndef STRUCT_TM_HASZONE
3785 # define STRUCT_TM_HASZONE
3789 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3790 # ifndef HAS_TM_TM_ZONE
3791 # define HAS_TM_TM_ZONE
3796 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3798 #ifdef HAS_TM_TM_ZONE
3800 const struct tm* my_tm;
3801 PERL_UNUSED_CONTEXT;
3802 PERL_ARGS_ASSERT_INIT_TM;
3804 my_tm = localtime(&now);
3806 Copy(my_tm, ptm, 1, struct tm);
3808 PERL_UNUSED_CONTEXT;
3809 PERL_ARGS_ASSERT_INIT_TM;
3810 PERL_UNUSED_ARG(ptm);
3815 * mini_mktime - normalise struct tm values without the localtime()
3816 * semantics (and overhead) of mktime().
3819 Perl_mini_mktime(struct tm *ptm)
3823 int month, mday, year, jday;
3824 int odd_cent, odd_year;
3826 PERL_ARGS_ASSERT_MINI_MKTIME;
3828 #define DAYS_PER_YEAR 365
3829 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3830 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3831 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3832 #define SECS_PER_HOUR (60*60)
3833 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3834 /* parentheses deliberately absent on these two, otherwise they don't work */
3835 #define MONTH_TO_DAYS 153/5
3836 #define DAYS_TO_MONTH 5/153
3837 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3838 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3839 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3840 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3843 * Year/day algorithm notes:
3845 * With a suitable offset for numeric value of the month, one can find
3846 * an offset into the year by considering months to have 30.6 (153/5) days,
3847 * using integer arithmetic (i.e., with truncation). To avoid too much
3848 * messing about with leap days, we consider January and February to be
3849 * the 13th and 14th month of the previous year. After that transformation,
3850 * we need the month index we use to be high by 1 from 'normal human' usage,
3851 * so the month index values we use run from 4 through 15.
3853 * Given that, and the rules for the Gregorian calendar (leap years are those
3854 * divisible by 4 unless also divisible by 100, when they must be divisible
3855 * by 400 instead), we can simply calculate the number of days since some
3856 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3857 * the days we derive from our month index, and adding in the day of the
3858 * month. The value used here is not adjusted for the actual origin which
3859 * it normally would use (1 January A.D. 1), since we're not exposing it.
3860 * We're only building the value so we can turn around and get the
3861 * normalised values for the year, month, day-of-month, and day-of-year.
3863 * For going backward, we need to bias the value we're using so that we find
3864 * the right year value. (Basically, we don't want the contribution of
3865 * March 1st to the number to apply while deriving the year). Having done
3866 * that, we 'count up' the contribution to the year number by accounting for
3867 * full quadracenturies (400-year periods) with their extra leap days, plus
3868 * the contribution from full centuries (to avoid counting in the lost leap
3869 * days), plus the contribution from full quad-years (to count in the normal
3870 * leap days), plus the leftover contribution from any non-leap years.
3871 * At this point, if we were working with an actual leap day, we'll have 0
3872 * days left over. This is also true for March 1st, however. So, we have
3873 * to special-case that result, and (earlier) keep track of the 'odd'
3874 * century and year contributions. If we got 4 extra centuries in a qcent,
3875 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3876 * Otherwise, we add back in the earlier bias we removed (the 123 from
3877 * figuring in March 1st), find the month index (integer division by 30.6),
3878 * and the remainder is the day-of-month. We then have to convert back to
3879 * 'real' months (including fixing January and February from being 14/15 in
3880 * the previous year to being in the proper year). After that, to get
3881 * tm_yday, we work with the normalised year and get a new yearday value for
3882 * January 1st, which we subtract from the yearday value we had earlier,
3883 * representing the date we've re-built. This is done from January 1
3884 * because tm_yday is 0-origin.
3886 * Since POSIX time routines are only guaranteed to work for times since the
3887 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3888 * applies Gregorian calendar rules even to dates before the 16th century
3889 * doesn't bother me. Besides, you'd need cultural context for a given
3890 * date to know whether it was Julian or Gregorian calendar, and that's
3891 * outside the scope for this routine. Since we convert back based on the
3892 * same rules we used to build the yearday, you'll only get strange results
3893 * for input which needed normalising, or for the 'odd' century years which
3894 * were leap years in the Julian calendar but not in the Gregorian one.
3895 * I can live with that.
3897 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3898 * that's still outside the scope for POSIX time manipulation, so I don't
3902 year = 1900 + ptm->tm_year;
3903 month = ptm->tm_mon;
3904 mday = ptm->tm_mday;
3910 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3911 yearday += month*MONTH_TO_DAYS + mday + jday;
3913 * Note that we don't know when leap-seconds were or will be,
3914 * so we have to trust the user if we get something which looks
3915 * like a sensible leap-second. Wild values for seconds will
3916 * be rationalised, however.
3918 if ((unsigned) ptm->tm_sec <= 60) {
3925 secs += 60 * ptm->tm_min;
3926 secs += SECS_PER_HOUR * ptm->tm_hour;
3928 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3929 /* got negative remainder, but need positive time */
3930 /* back off an extra day to compensate */
3931 yearday += (secs/SECS_PER_DAY)-1;
3932 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3935 yearday += (secs/SECS_PER_DAY);
3936 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3939 else if (secs >= SECS_PER_DAY) {
3940 yearday += (secs/SECS_PER_DAY);
3941 secs %= SECS_PER_DAY;
3943 ptm->tm_hour = secs/SECS_PER_HOUR;
3944 secs %= SECS_PER_HOUR;
3945 ptm->tm_min = secs/60;
3947 ptm->tm_sec += secs;
3948 /* done with time of day effects */
3950 * The algorithm for yearday has (so far) left it high by 428.
3951 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3952 * bias it by 123 while trying to figure out what year it
3953 * really represents. Even with this tweak, the reverse
3954 * translation fails for years before A.D. 0001.
3955 * It would still fail for Feb 29, but we catch that one below.
3957 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3958 yearday -= YEAR_ADJUST;
3959 year = (yearday / DAYS_PER_QCENT) * 400;
3960 yearday %= DAYS_PER_QCENT;
3961 odd_cent = yearday / DAYS_PER_CENT;
3962 year += odd_cent * 100;
3963 yearday %= DAYS_PER_CENT;
3964 year += (yearday / DAYS_PER_QYEAR) * 4;
3965 yearday %= DAYS_PER_QYEAR;
3966 odd_year = yearday / DAYS_PER_YEAR;
3968 yearday %= DAYS_PER_YEAR;
3969 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3974 yearday += YEAR_ADJUST; /* recover March 1st crock */
3975 month = yearday*DAYS_TO_MONTH;
3976 yearday -= month*MONTH_TO_DAYS;
3977 /* recover other leap-year adjustment */
3986 ptm->tm_year = year - 1900;
3988 ptm->tm_mday = yearday;
3989 ptm->tm_mon = month;
3993 ptm->tm_mon = month - 1;
3995 /* re-build yearday based on Jan 1 to get tm_yday */
3997 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3998 yearday += 14*MONTH_TO_DAYS + 1;
3999 ptm->tm_yday = jday - yearday;
4000 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4004 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)
4008 /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
4015 PERL_ARGS_ASSERT_MY_STRFTIME;
4017 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4020 mytm.tm_hour = hour;
4021 mytm.tm_mday = mday;
4023 mytm.tm_year = year;
4024 mytm.tm_wday = wday;
4025 mytm.tm_yday = yday;
4026 mytm.tm_isdst = isdst;
4028 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4029 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4034 #ifdef HAS_TM_TM_GMTOFF
4035 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4037 #ifdef HAS_TM_TM_ZONE
4038 mytm.tm_zone = mytm2.tm_zone;
4043 Newx(buf, buflen, char);
4045 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4046 len = strftime(buf, buflen, fmt, &mytm);
4050 ** The following is needed to handle to the situation where
4051 ** tmpbuf overflows. Basically we want to allocate a buffer
4052 ** and try repeatedly. The reason why it is so complicated
4053 ** is that getting a return value of 0 from strftime can indicate
4054 ** one of the following:
4055 ** 1. buffer overflowed,
4056 ** 2. illegal conversion specifier, or
4057 ** 3. the format string specifies nothing to be returned(not
4058 ** an error). This could be because format is an empty string
4059 ** or it specifies %p that yields an empty string in some locale.
4060 ** If there is a better way to make it portable, go ahead by
4063 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4066 /* Possibly buf overflowed - try again with a bigger buf */
4067 const int fmtlen = strlen(fmt);
4068 int bufsize = fmtlen + buflen;
4070 Renew(buf, bufsize, char);
4073 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4074 buflen = strftime(buf, bufsize, fmt, &mytm);
4077 if (buflen > 0 && buflen < bufsize)
4079 /* heuristic to prevent out-of-memory errors */
4080 if (bufsize > 100*fmtlen) {
4086 Renew(buf, bufsize, char);
4091 Perl_croak(aTHX_ "panic: no strftime");
4097 #define SV_CWD_RETURN_UNDEF \
4098 sv_setsv(sv, &PL_sv_undef); \
4101 #define SV_CWD_ISDOT(dp) \
4102 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4103 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4106 =head1 Miscellaneous Functions
4108 =for apidoc getcwd_sv
4110 Fill C<sv> with current working directory
4115 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4116 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4117 * getcwd(3) if available
4118 * Comments from the original:
4119 * This is a faster version of getcwd. It's also more dangerous
4120 * because you might chdir out of a directory that you can't chdir
4124 Perl_getcwd_sv(pTHX_ SV *sv)
4129 PERL_ARGS_ASSERT_GETCWD_SV;
4133 char buf[MAXPATHLEN];
4135 /* Some getcwd()s automatically allocate a buffer of the given
4136 * size from the heap if they are given a NULL buffer pointer.
4137 * The problem is that this behaviour is not portable. */
4138 if (getcwd(buf, sizeof(buf) - 1)) {
4143 sv_setsv(sv, &PL_sv_undef);
4151 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4155 SvUPGRADE(sv, SVt_PV);
4157 if (PerlLIO_lstat(".", &statbuf) < 0) {
4158 SV_CWD_RETURN_UNDEF;
4161 orig_cdev = statbuf.st_dev;
4162 orig_cino = statbuf.st_ino;
4172 if (PerlDir_chdir("..") < 0) {
4173 SV_CWD_RETURN_UNDEF;
4175 if (PerlLIO_stat(".", &statbuf) < 0) {
4176 SV_CWD_RETURN_UNDEF;
4179 cdev = statbuf.st_dev;
4180 cino = statbuf.st_ino;
4182 if (odev == cdev && oino == cino) {
4185 if (!(dir = PerlDir_open("."))) {
4186 SV_CWD_RETURN_UNDEF;
4189 while ((dp = PerlDir_read(dir)) != NULL) {
4191 namelen = dp->d_namlen;
4193 namelen = strlen(dp->d_name);
4196 if (SV_CWD_ISDOT(dp)) {
4200 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4201 SV_CWD_RETURN_UNDEF;
4204 tdev = statbuf.st_dev;
4205 tino = statbuf.st_ino;
4206 if (tino == oino && tdev == odev) {
4212 SV_CWD_RETURN_UNDEF;
4215 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4216 SV_CWD_RETURN_UNDEF;
4219 SvGROW(sv, pathlen + namelen + 1);
4223 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4226 /* prepend current directory to the front */
4228 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4229 pathlen += (namelen + 1);
4231 #ifdef VOID_CLOSEDIR
4234 if (PerlDir_close(dir) < 0) {
4235 SV_CWD_RETURN_UNDEF;
4241 SvCUR_set(sv, pathlen);
4245 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4246 SV_CWD_RETURN_UNDEF;
4249 if (PerlLIO_stat(".", &statbuf) < 0) {
4250 SV_CWD_RETURN_UNDEF;
4253 cdev = statbuf.st_dev;
4254 cino = statbuf.st_ino;
4256 if (cdev != orig_cdev || cino != orig_cino) {
4257 Perl_croak(aTHX_ "Unstable directory path, "
4258 "current directory changed unexpectedly");
4271 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4272 # define EMULATE_SOCKETPAIR_UDP
4275 #ifdef EMULATE_SOCKETPAIR_UDP
4277 S_socketpair_udp (int fd[2]) {
4279 /* Fake a datagram socketpair using UDP to localhost. */
4280 int sockets[2] = {-1, -1};
4281 struct sockaddr_in addresses[2];
4283 Sock_size_t size = sizeof(struct sockaddr_in);
4284 unsigned short port;
4287 memset(&addresses, 0, sizeof(addresses));
4290 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4291 if (sockets[i] == -1)
4292 goto tidy_up_and_fail;
4294 addresses[i].sin_family = AF_INET;
4295 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4296 addresses[i].sin_port = 0; /* kernel choses port. */
4297 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4298 sizeof(struct sockaddr_in)) == -1)
4299 goto tidy_up_and_fail;
4302 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4303 for each connect the other socket to it. */
4306 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4308 goto tidy_up_and_fail;
4309 if (size != sizeof(struct sockaddr_in))
4310 goto abort_tidy_up_and_fail;
4311 /* !1 is 0, !0 is 1 */
4312 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4313 sizeof(struct sockaddr_in)) == -1)
4314 goto tidy_up_and_fail;
4317 /* Now we have 2 sockets connected to each other. I don't trust some other
4318 process not to have already sent a packet to us (by random) so send
4319 a packet from each to the other. */
4322 /* I'm going to send my own port number. As a short.
4323 (Who knows if someone somewhere has sin_port as a bitfield and needs
4324 this routine. (I'm assuming crays have socketpair)) */
4325 port = addresses[i].sin_port;
4326 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4327 if (got != sizeof(port)) {
4329 goto tidy_up_and_fail;
4330 goto abort_tidy_up_and_fail;
4334 /* Packets sent. I don't trust them to have arrived though.
4335 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4336 connect to localhost will use a second kernel thread. In 2.6 the
4337 first thread running the connect() returns before the second completes,
4338 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4339 returns 0. Poor programs have tripped up. One poor program's authors'
4340 had a 50-1 reverse stock split. Not sure how connected these were.)
4341 So I don't trust someone not to have an unpredictable UDP stack.
4345 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4346 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4350 FD_SET((unsigned int)sockets[0], &rset);
4351 FD_SET((unsigned int)sockets[1], &rset);
4353 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4354 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4355 || !FD_ISSET(sockets[1], &rset)) {
4356 /* I hope this is portable and appropriate. */
4358 goto tidy_up_and_fail;
4359 goto abort_tidy_up_and_fail;
4363 /* And the paranoia department even now doesn't trust it to have arrive
4364 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4366 struct sockaddr_in readfrom;
4367 unsigned short buffer[2];
4372 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4373 sizeof(buffer), MSG_DONTWAIT,
4374 (struct sockaddr *) &readfrom, &size);
4376 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4378 (struct sockaddr *) &readfrom, &size);
4382 goto tidy_up_and_fail;
4383 if (got != sizeof(port)
4384 || size != sizeof(struct sockaddr_in)
4385 /* Check other socket sent us its port. */
4386 || buffer[0] != (unsigned short) addresses[!i].sin_port
4387 /* Check kernel says we got the datagram from that socket */
4388 || readfrom.sin_family != addresses[!i].sin_family
4389 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4390 || readfrom.sin_port != addresses[!i].sin_port)
4391 goto abort_tidy_up_and_fail;
4394 /* My caller (my_socketpair) has validated that this is non-NULL */
4397 /* I hereby declare this connection open. May God bless all who cross
4401 abort_tidy_up_and_fail:
4402 errno = ECONNABORTED;
4406 if (sockets[0] != -1)
4407 PerlLIO_close(sockets[0]);
4408 if (sockets[1] != -1)
4409 PerlLIO_close(sockets[1]);
4414 #endif /* EMULATE_SOCKETPAIR_UDP */
4416 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4418 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4419 /* Stevens says that family must be AF_LOCAL, protocol 0.
4420 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4425 struct sockaddr_in listen_addr;
4426 struct sockaddr_in connect_addr;
4431 || family != AF_UNIX
4434 errno = EAFNOSUPPORT;
4442 #ifdef EMULATE_SOCKETPAIR_UDP
4443 if (type == SOCK_DGRAM)
4444 return S_socketpair_udp(fd);
4447 aTHXa(PERL_GET_THX);
4448 listener = PerlSock_socket(AF_INET, type, 0);
4451 memset(&listen_addr, 0, sizeof(listen_addr));
4452 listen_addr.sin_family = AF_INET;
4453 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4454 listen_addr.sin_port = 0; /* kernel choses port. */
4455 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4456 sizeof(listen_addr)) == -1)
4457 goto tidy_up_and_fail;
4458 if (PerlSock_listen(listener, 1) == -1)
4459 goto tidy_up_and_fail;
4461 connector = PerlSock_socket(AF_INET, type, 0);
4462 if (connector == -1)
4463 goto tidy_up_and_fail;
4464 /* We want to find out the port number to connect to. */
4465 size = sizeof(connect_addr);
4466 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4468 goto tidy_up_and_fail;
4469 if (size != sizeof(connect_addr))
4470 goto abort_tidy_up_and_fail;
4471 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4472 sizeof(connect_addr)) == -1)
4473 goto tidy_up_and_fail;
4475 size = sizeof(listen_addr);
4476 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4479 goto tidy_up_and_fail;
4480 if (size != sizeof(listen_addr))
4481 goto abort_tidy_up_and_fail;
4482 PerlLIO_close(listener);
4483 /* Now check we are talking to ourself by matching port and host on the
4485 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4487 goto tidy_up_and_fail;
4488 if (size != sizeof(connect_addr)
4489 || listen_addr.sin_family != connect_addr.sin_family
4490 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4491 || listen_addr.sin_port != connect_addr.sin_port) {
4492 goto abort_tidy_up_and_fail;
4498 abort_tidy_up_and_fail:
4500 errno = ECONNABORTED; /* This would be the standard thing to do. */
4502 # ifdef ECONNREFUSED
4503 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4505 errno = ETIMEDOUT; /* Desperation time. */
4512 PerlLIO_close(listener);
4513 if (connector != -1)
4514 PerlLIO_close(connector);
4516 PerlLIO_close(acceptor);
4522 /* In any case have a stub so that there's code corresponding
4523 * to the my_socketpair in embed.fnc. */
4525 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4526 #ifdef HAS_SOCKETPAIR
4527 return socketpair(family, type, protocol, fd);
4536 =for apidoc sv_nosharing
4538 Dummy routine which "shares" an SV when there is no sharing module present.
4539 Or "locks" it. Or "unlocks" it. In other
4540 words, ignores its single SV argument.
4541 Exists to avoid test for a C<NULL> function pointer and because it could
4542 potentially warn under some level of strict-ness.
4548 Perl_sv_nosharing(pTHX_ SV *sv)
4550 PERL_UNUSED_CONTEXT;
4551 PERL_UNUSED_ARG(sv);
4556 =for apidoc sv_destroyable
4558 Dummy routine which reports that object can be destroyed when there is no
4559 sharing module present. It ignores its single SV argument, and returns
4560 'true'. Exists to avoid test for a C<NULL> function pointer and because it
4561 could potentially warn under some level of strict-ness.
4567 Perl_sv_destroyable(pTHX_ SV *sv)
4569 PERL_UNUSED_CONTEXT;
4570 PERL_UNUSED_ARG(sv);
4575 Perl_parse_unicode_opts(pTHX_ const char **popt)
4577 const char *p = *popt;
4580 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4586 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4589 if (p && *p && *p != '\n' && *p != '\r') {
4591 goto the_end_of_the_opts_parser;
4593 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4597 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4603 case PERL_UNICODE_STDIN:
4604 opt |= PERL_UNICODE_STDIN_FLAG; break;
4605 case PERL_UNICODE_STDOUT:
4606 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4607 case PERL_UNICODE_STDERR:
4608 opt |= PERL_UNICODE_STDERR_FLAG; break;
4609 case PERL_UNICODE_STD:
4610 opt |= PERL_UNICODE_STD_FLAG; break;
4611 case PERL_UNICODE_IN:
4612 opt |= PERL_UNICODE_IN_FLAG; break;
4613 case PERL_UNICODE_OUT:
4614 opt |= PERL_UNICODE_OUT_FLAG; break;
4615 case PERL_UNICODE_INOUT:
4616 opt |= PERL_UNICODE_INOUT_FLAG; break;
4617 case PERL_UNICODE_LOCALE:
4618 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4619 case PERL_UNICODE_ARGV:
4620 opt |= PERL_UNICODE_ARGV_FLAG; break;
4621 case PERL_UNICODE_UTF8CACHEASSERT:
4622 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4624 if (*p != '\n' && *p != '\r') {
4625 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4628 "Unknown Unicode option letter '%c'", *p);
4635 opt = PERL_UNICODE_DEFAULT_FLAGS;
4637 the_end_of_the_opts_parser:
4639 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4640 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4641 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4649 # include <starlet.h>
4656 * This is really just a quick hack which grabs various garbage
4657 * values. It really should be a real hash algorithm which
4658 * spreads the effect of every input bit onto every output bit,
4659 * if someone who knows about such things would bother to write it.
4660 * Might be a good idea to add that function to CORE as well.
4661 * No numbers below come from careful analysis or anything here,
4662 * except they are primes and SEED_C1 > 1E6 to get a full-width
4663 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4664 * probably be bigger too.
4667 # define SEED_C1 1000003
4668 #define SEED_C4 73819
4670 # define SEED_C1 25747
4671 #define SEED_C4 20639
4675 #define SEED_C5 26107
4677 #ifndef PERL_NO_DEV_RANDOM
4681 #ifdef HAS_GETTIMEOFDAY
4682 struct timeval when;
4687 /* This test is an escape hatch, this symbol isn't set by Configure. */
4688 #ifndef PERL_NO_DEV_RANDOM
4689 #ifndef PERL_RANDOM_DEVICE
4690 /* /dev/random isn't used by default because reads from it will block
4691 * if there isn't enough entropy available. You can compile with
4692 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4693 * is enough real entropy to fill the seed. */
4694 # ifdef __amigaos4__
4695 # define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4697 # define PERL_RANDOM_DEVICE "/dev/urandom"
4700 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4702 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4710 #ifdef HAS_GETTIMEOFDAY
4711 PerlProc_gettimeofday(&when,NULL);
4712 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4715 u = (U32)SEED_C1 * when;
4717 u += SEED_C3 * (U32)PerlProc_getpid();
4718 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4719 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4720 u += SEED_C5 * (U32)PTR2UV(&when);
4726 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4731 PERL_ARGS_ASSERT_GET_HASH_SEED;
4733 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4736 #ifndef USE_HASH_SEED_EXPLICIT
4738 /* ignore leading spaces */
4739 while (isSPACE(*env_pv))
4741 #ifdef USE_PERL_PERTURB_KEYS
4742 /* if they set it to "0" we disable key traversal randomization completely */
4743 if (strEQ(env_pv,"0")) {
4744 PL_hash_rand_bits_enabled= 0;
4746 /* otherwise switch to deterministic mode */
4747 PL_hash_rand_bits_enabled= 2;
4750 /* ignore a leading 0x... if it is there */
4751 if (env_pv[0] == '0' && env_pv[1] == 'x')
4754 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4755 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4756 if ( isXDIGIT(*env_pv)) {
4757 seed_buffer[i] |= READ_XDIGIT(env_pv);
4760 while (isSPACE(*env_pv))
4763 if (*env_pv && !isXDIGIT(*env_pv)) {
4764 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4766 /* should we check for unparsed crap? */
4767 /* should we warn about unused hex? */
4768 /* should we warn about insufficient hex? */
4773 (void)seedDrand01((Rand_seed_t)seed());
4775 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4776 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4779 #ifdef USE_PERL_PERTURB_KEYS
4780 { /* initialize PL_hash_rand_bits from the hash seed.
4781 * This value is highly volatile, it is updated every
4782 * hash insert, and is used as part of hash bucket chain
4783 * randomization and hash iterator randomization. */
4784 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4785 for( i = 0; i < sizeof(UV) ; i++ ) {
4786 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4787 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4790 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4792 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4793 PL_hash_rand_bits_enabled= 0;
4794 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4795 PL_hash_rand_bits_enabled= 1;
4796 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4797 PL_hash_rand_bits_enabled= 2;
4799 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4805 #ifdef PERL_GLOBAL_STRUCT
4807 #define PERL_GLOBAL_STRUCT_INIT
4808 #include "opcode.h" /* the ppaddr and check */
4811 Perl_init_global_struct(pTHX)
4813 struct perl_vars *plvarsp = NULL;
4814 # ifdef PERL_GLOBAL_STRUCT
4815 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4816 const IV ncheck = C_ARRAY_LENGTH(Gcheck);
4817 PERL_UNUSED_CONTEXT;
4818 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4819 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4820 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4824 plvarsp = PL_VarsPtr;
4825 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4830 # define PERLVAR(prefix,var,type) /**/
4831 # define PERLVARA(prefix,var,n,type) /**/
4832 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4833 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4834 # include "perlvars.h"
4839 # ifdef PERL_GLOBAL_STRUCT
4842 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4843 if (!plvarsp->Gppaddr)
4847 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4848 if (!plvarsp->Gcheck)
4850 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4851 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4853 # ifdef PERL_SET_VARS
4854 PERL_SET_VARS(plvarsp);
4856 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4857 plvarsp->Gsv_placeholder.sv_flags = 0;
4858 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4860 # undef PERL_GLOBAL_STRUCT_INIT
4865 #endif /* PERL_GLOBAL_STRUCT */
4867 #ifdef PERL_GLOBAL_STRUCT
4870 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4872 int veto = plvarsp->Gveto_cleanup;
4874 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4875 PERL_UNUSED_CONTEXT;
4876 # ifdef PERL_GLOBAL_STRUCT
4877 # ifdef PERL_UNSET_VARS
4878 PERL_UNSET_VARS(plvarsp);
4882 free(plvarsp->Gppaddr);
4883 free(plvarsp->Gcheck);
4884 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4890 #endif /* PERL_GLOBAL_STRUCT */
4894 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4895 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4896 * given, and you supply your own implementation.
4898 * The default implementation reads a single env var, PERL_MEM_LOG,
4899 * expecting one or more of the following:
4901 * \d+ - fd fd to write to : must be 1st (grok_atoUV)
4902 * 'm' - memlog was PERL_MEM_LOG=1
4903 * 's' - svlog was PERL_SV_LOG=1
4904 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
4906 * This makes the logger controllable enough that it can reasonably be
4907 * added to the system perl.
4910 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4911 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4913 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4915 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4916 * writes to. In the default logger, this is settable at runtime.
4918 #ifndef PERL_MEM_LOG_FD
4919 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4922 #ifndef PERL_MEM_LOG_NOIMPL
4924 # ifdef DEBUG_LEAKING_SCALARS
4925 # define SV_LOG_SERIAL_FMT " [%lu]"
4926 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
4928 # define SV_LOG_SERIAL_FMT
4929 # define _SV_LOG_SERIAL_ARG(sv)
4933 S_mem_log_common(enum mem_log_type mlt, const UV n,
4934 const UV typesize, const char *type_name, const SV *sv,
4935 Malloc_t oldalloc, Malloc_t newalloc,
4936 const char *filename, const int linenumber,
4937 const char *funcname)
4941 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4943 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4946 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4948 /* We can't use SVs or PerlIO for obvious reasons,
4949 * so we'll use stdio and low-level IO instead. */
4950 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4952 # ifdef HAS_GETTIMEOFDAY
4953 # define MEM_LOG_TIME_FMT "%10d.%06d: "
4954 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
4956 gettimeofday(&tv, 0);
4958 # define MEM_LOG_TIME_FMT "%10d: "
4959 # define MEM_LOG_TIME_ARG (int)when
4963 /* If there are other OS specific ways of hires time than
4964 * gettimeofday() (see dist/Time-HiRes), the easiest way is
4965 * probably that they would be used to fill in the struct
4972 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4973 && uv && uv <= PERL_INT_MAX
4977 fd = PERL_MEM_LOG_FD;
4980 if (strchr(pmlenv, 't')) {
4981 len = my_snprintf(buf, sizeof(buf),
4982 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4983 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4987 len = my_snprintf(buf, sizeof(buf),
4988 "alloc: %s:%d:%s: %"IVdf" %"UVuf
4989 " %s = %"IVdf": %"UVxf"\n",
4990 filename, linenumber, funcname, n, typesize,
4991 type_name, n * typesize, PTR2UV(newalloc));
4994 len = my_snprintf(buf, sizeof(buf),
4995 "realloc: %s:%d:%s: %"IVdf" %"UVuf
4996 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
4997 filename, linenumber, funcname, n, typesize,
4998 type_name, n * typesize, PTR2UV(oldalloc),
5002 len = my_snprintf(buf, sizeof(buf),
5003 "free: %s:%d:%s: %"UVxf"\n",
5004 filename, linenumber, funcname,
5009 len = my_snprintf(buf, sizeof(buf),
5010 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5011 mlt == MLT_NEW_SV ? "new" : "del",
5012 filename, linenumber, funcname,
5013 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5018 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5022 #endif /* !PERL_MEM_LOG_NOIMPL */
5024 #ifndef PERL_MEM_LOG_NOIMPL
5026 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5027 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5029 /* this is suboptimal, but bug compatible. User is providing their
5030 own implementation, but is getting these functions anyway, and they
5031 do nothing. But _NOIMPL users should be able to cope or fix */
5033 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5034 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5038 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5040 const char *filename, const int linenumber,
5041 const char *funcname)
5043 PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5045 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5046 NULL, NULL, newalloc,
5047 filename, linenumber, funcname);
5052 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5053 Malloc_t oldalloc, Malloc_t newalloc,
5054 const char *filename, const int linenumber,
5055 const char *funcname)
5057 PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5059 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5060 NULL, oldalloc, newalloc,
5061 filename, linenumber, funcname);
5066 Perl_mem_log_free(Malloc_t oldalloc,
5067 const char *filename, const int linenumber,
5068 const char *funcname)
5070 PERL_ARGS_ASSERT_MEM_LOG_FREE;
5072 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5073 filename, linenumber, funcname);
5078 Perl_mem_log_new_sv(const SV *sv,
5079 const char *filename, const int linenumber,
5080 const char *funcname)
5082 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5083 filename, linenumber, funcname);
5087 Perl_mem_log_del_sv(const SV *sv,
5088 const char *filename, const int linenumber,
5089 const char *funcname)
5091 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5092 filename, linenumber, funcname);
5095 #endif /* PERL_MEM_LOG */
5098 =for apidoc my_sprintf
5100 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5101 the length of the string written to the buffer. Only rare pre-ANSI systems
5102 need the wrapper function - usually this is a direct call to C<sprintf>.
5106 #ifndef SPRINTF_RETURNS_STRLEN
5108 Perl_my_sprintf(char *buffer, const char* pat, ...)
5111 PERL_ARGS_ASSERT_MY_SPRINTF;
5112 va_start(args, pat);
5113 vsprintf(buffer, pat, args);
5115 return strlen(buffer);
5120 =for apidoc quadmath_format_single
5122 C<quadmath_snprintf()> is very strict about its C<format> string and will
5123 fail, returning -1, if the format is invalid. It accepts exactly
5126 C<quadmath_format_single()> checks that the intended single spec looks
5127 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
5128 and has C<Q> before it. This is not a full "printf syntax check",
5131 Returns the format if it is valid, NULL if not.
5133 C<quadmath_format_single()> can and will actually patch in the missing
5134 C<Q>, if necessary. In this case it will return the modified copy of
5135 the format, B<which the caller will need to free.>
5137 See also L</quadmath_format_needed>.
5143 Perl_quadmath_format_single(const char* format)
5147 PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
5149 if (format[0] != '%' || strchr(format + 1, '%'))
5151 len = strlen(format);
5152 /* minimum length three: %Qg */
5153 if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
5155 if (format[len - 2] != 'Q') {
5157 Newx(fixed, len + 1, char);
5158 memcpy(fixed, format, len - 1);
5159 fixed[len - 1] = 'Q';
5160 fixed[len ] = format[len - 1];
5162 return (const char*)fixed;
5169 =for apidoc quadmath_format_needed
5171 C<quadmath_format_needed()> returns true if the C<format> string seems to
5172 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
5173 or returns false otherwise.
5175 The format specifier detection is not complete printf-syntax detection,
5176 but it should catch most common cases.
5178 If true is returned, those arguments B<should> in theory be processed
5179 with C<quadmath_snprintf()>, but in case there is more than one such
5180 format specifier (see L</quadmath_format_single>), and if there is
5181 anything else beyond that one (even just a single byte), they
5182 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
5183 accepting only one format spec, and nothing else.
5184 In this case, the code should probably fail.
5190 Perl_quadmath_format_needed(const char* format)
5192 const char *p = format;
5195 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5197 while ((q = strchr(p, '%'))) {
5199 if (*q == '+') /* plus */
5201 if (*q == '#') /* alt */
5203 if (*q == '*') /* width */
5207 while (isDIGIT(*q)) q++;
5210 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5215 while (isDIGIT(*q)) q++;
5217 if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5226 =for apidoc my_snprintf
5228 The C library C<snprintf> functionality, if available and
5229 standards-compliant (uses C<vsnprintf>, actually). However, if the
5230 C<vsnprintf> is not available, will unfortunately use the unsafe
5231 C<vsprintf> which can overrun the buffer (there is an overrun check,
5232 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5233 getting C<vsnprintf>.
5238 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5242 PERL_ARGS_ASSERT_MY_SNPRINTF;
5243 #ifndef HAS_VSNPRINTF
5244 PERL_UNUSED_VAR(len);
5246 va_start(ap, format);
5249 const char* qfmt = quadmath_format_single(format);
5250 bool quadmath_valid = FALSE;
5252 /* If the format looked promising, use it as quadmath. */
5253 retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
5255 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
5256 quadmath_valid = TRUE;
5261 assert(qfmt == NULL);
5262 /* quadmath_format_single() will return false for example for
5263 * "foo = %g", or simply "%g". We could handle the %g by
5264 * using quadmath for the NV args. More complex cases of
5265 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
5266 * quadmath-valid but has stuff in front).
5268 * Handling the "Q-less" cases right would require walking
5269 * through the va_list and rewriting the format, calling
5270 * quadmath for the NVs, building a new va_list, and then
5271 * letting vsnprintf/vsprintf to take care of the other
5272 * arguments. This may be doable.
5274 * We do not attempt that now. But for paranoia, we here try
5275 * to detect some common (but not all) cases where the
5276 * "Q-less" %[efgaEFGA] formats are present, and die if
5277 * detected. This doesn't fix the problem, but it stops the
5278 * vsnprintf/vsprintf pulling doubles off the va_list when
5279 * __float128 NVs should be pulled off instead.
5281 * If quadmath_format_needed() returns false, we are reasonably
5282 * certain that we can call vnsprintf() or vsprintf() safely. */
5283 if (!quadmath_valid && quadmath_format_needed(format))
5284 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5289 #ifdef HAS_VSNPRINTF
5290 retval = vsnprintf(buffer, len, format, ap);
5292 retval = vsprintf(buffer, format, ap);
5295 /* vsprintf() shows failure with < 0 */
5297 #ifdef HAS_VSNPRINTF
5298 /* vsnprintf() shows failure with >= len */
5300 (len > 0 && (Size_t)retval >= len)
5303 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5308 =for apidoc my_vsnprintf
5310 The C library C<vsnprintf> if available and standards-compliant.
5311 However, if if the C<vsnprintf> is not available, will unfortunately
5312 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5313 overrun check, but that may be too late). Consider using
5314 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5319 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5322 PERL_UNUSED_ARG(buffer);
5323 PERL_UNUSED_ARG(len);
5324 PERL_UNUSED_ARG(format);
5325 /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
5326 PERL_UNUSED_ARG((void*)ap);
5327 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5334 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5335 Perl_va_copy(ap, apc);
5336 # ifdef HAS_VSNPRINTF
5337 retval = vsnprintf(buffer, len, format, apc);
5339 PERL_UNUSED_ARG(len);
5340 retval = vsprintf(buffer, format, apc);
5344 # ifdef HAS_VSNPRINTF
5345 retval = vsnprintf(buffer, len, format, ap);
5347 PERL_UNUSED_ARG(len);
5348 retval = vsprintf(buffer, format, ap);
5350 #endif /* #ifdef NEED_VA_COPY */
5351 /* vsprintf() shows failure with < 0 */
5353 #ifdef HAS_VSNPRINTF
5354 /* vsnprintf() shows failure with >= len */
5356 (len > 0 && (Size_t)retval >= len)
5359 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5365 Perl_my_clearenv(pTHX)
5368 #if ! defined(PERL_MICRO)
5369 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5371 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5372 # if defined(USE_ENVIRON_ARRAY)
5373 # if defined(USE_ITHREADS)
5374 /* only the parent thread can clobber the process environment */
5375 if (PL_curinterp == aTHX)
5376 # endif /* USE_ITHREADS */
5378 # if ! defined(PERL_USE_SAFE_PUTENV)
5379 if ( !PL_use_safe_putenv) {
5381 if (environ == PL_origenviron)
5382 environ = (char**)safesysmalloc(sizeof(char*));
5384 for (i = 0; environ[i]; i++)
5385 (void)safesysfree(environ[i]);
5388 # else /* PERL_USE_SAFE_PUTENV */
5389 # if defined(HAS_CLEARENV)
5391 # elif defined(HAS_UNSETENV)
5392 int bsiz = 80; /* Most envvar names will be shorter than this. */
5393 char *buf = (char*)safesysmalloc(bsiz);
5394 while (*environ != NULL) {
5395 char *e = strchr(*environ, '=');
5396 int l = e ? e - *environ : (int)strlen(*environ);
5398 (void)safesysfree(buf);
5399 bsiz = l + 1; /* + 1 for the \0. */
5400 buf = (char*)safesysmalloc(bsiz);
5402 memcpy(buf, *environ, l);
5404 (void)unsetenv(buf);
5406 (void)safesysfree(buf);
5407 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5408 /* Just null environ and accept the leakage. */
5410 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5411 # endif /* ! PERL_USE_SAFE_PUTENV */
5413 # endif /* USE_ENVIRON_ARRAY */
5414 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5415 #endif /* PERL_MICRO */
5418 #ifdef PERL_IMPLICIT_CONTEXT
5420 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5421 the global PL_my_cxt_index is incremented, and that value is assigned to
5422 that module's static my_cxt_index (who's address is passed as an arg).
5423 Then, for each interpreter this function is called for, it makes sure a
5424 void* slot is available to hang the static data off, by allocating or
5425 extending the interpreter's PL_my_cxt_list array */
5427 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5429 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5433 PERL_ARGS_ASSERT_MY_CXT_INIT;
5435 /* this module hasn't been allocated an index yet */
5436 #if defined(USE_ITHREADS)
5437 MUTEX_LOCK(&PL_my_ctx_mutex);
5439 *index = PL_my_cxt_index++;
5440 #if defined(USE_ITHREADS)
5441 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5445 /* make sure the array is big enough */
5446 if (PL_my_cxt_size <= *index) {
5447 if (PL_my_cxt_size) {
5448 while (PL_my_cxt_size <= *index)
5449 PL_my_cxt_size *= 2;
5450 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5453 PL_my_cxt_size = 16;
5454 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5457 /* newSV() allocates one more than needed */
5458 p = (void*)SvPVX(newSV(size-1));
5459 PL_my_cxt_list[*index] = p;
5460 Zero(p, size, char);
5464 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5467 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5472 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5474 for (index = 0; index < PL_my_cxt_index; index++) {
5475 const char *key = PL_my_cxt_keys[index];
5476 /* try direct pointer compare first - there are chances to success,
5477 * and it's much faster.
5479 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5486 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5492 PERL_ARGS_ASSERT_MY_CXT_INIT;
5494 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5496 /* this module hasn't been allocated an index yet */
5497 #if defined(USE_ITHREADS)
5498 MUTEX_LOCK(&PL_my_ctx_mutex);
5500 index = PL_my_cxt_index++;
5501 #if defined(USE_ITHREADS)
5502 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5506 /* make sure the array is big enough */
5507 if (PL_my_cxt_size <= index) {
5508 int old_size = PL_my_cxt_size;
5510 if (PL_my_cxt_size) {
5511 while (PL_my_cxt_size <= index)
5512 PL_my_cxt_size *= 2;
5513 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5514 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5517 PL_my_cxt_size = 16;
5518 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5519 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5521 for (i = old_size; i < PL_my_cxt_size; i++) {
5522 PL_my_cxt_keys[i] = 0;
5523 PL_my_cxt_list[i] = 0;
5526 PL_my_cxt_keys[index] = my_cxt_key;
5527 /* newSV() allocates one more than needed */
5528 p = (void*)SvPVX(newSV(size-1));
5529 PL_my_cxt_list[index] = p;
5530 Zero(p, size, char);
5533 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5534 #endif /* PERL_IMPLICIT_CONTEXT */
5537 /* Perl_xs_handshake():
5538 implement the various XS_*_BOOTCHECK macros, which are added to .c
5539 files by ExtUtils::ParseXS, to check that the perl the module was built
5540 with is binary compatible with the running perl.
5543 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5544 [U32 items, U32 ax], [char * api_version], [char * xs_version])
5546 The meaning of the varargs is determined the U32 key arg (which is not
5547 a format string). The fields of key are assembled by using HS_KEY().
5549 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5550 "PerlInterpreter *" and represents the callers context; otherwise it is
5551 of type "CV *", and is the boot xsub's CV.
5553 v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5554 for example, and IO.dll was linked with threaded perl524.dll, and both
5555 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5556 successfully can load IO.dll into the process but simultaneously it
5557 loaded an interpreter of a different version into the process, and XS
5558 code will naturally pass SV*s created by perl524.dll for perl526.dll to
5559 use through perl526.dll's my_perl->Istack_base.
5561 v_my_perl cannot be the first arg, since then 'key' will be out of
5562 place in a threaded vs non-threaded mixup; and analyzing the key
5563 number's bitfields won't reveal the problem, since it will be a valid
5564 key (unthreaded perl) on interp side, but croak will report the XS mod's
5565 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5566 it's a threaded perl and an unthreaded XS module, threaded perl will
5567 look at an uninit C stack or an uninit register to get 'key'
5568 (remember that it assumes that the 1st arg is the interp cxt).
5570 'file' is the source filename of the caller.
5574 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
5580 #ifdef PERL_IMPLICIT_CONTEXT
5587 PERL_ARGS_ASSERT_XS_HANDSHAKE;
5588 va_start(args, file);
5590 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
5591 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
5592 if (UNLIKELY(got != need))
5594 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5595 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5596 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5597 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5598 passed to the XS DLL */
5599 #ifdef PERL_IMPLICIT_CONTEXT
5600 xs_interp = (tTHX)v_my_perl;
5604 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5605 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5606 but the DynaLoder/Perl that started the process and loaded the XS DLL is
5607 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5608 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5609 location in the unthreaded perl binary) stored in CV * to figure out if this
5610 Perl_xs_handshake was called by the same pp_entersub */
5611 cv = (CV*)v_my_perl;
5612 xs_spp = (SV***)CvHSCXT(cv);
5614 need = &PL_stack_sp;
5616 if(UNLIKELY(got != need)) {
5617 bad_handshake:/* recycle branch and string from above */
5618 if(got != (void *)HSf_NOCHK)
5619 noperl_die("%s: loadable library and perl binaries are mismatched"
5620 " (got handshake key %p, needed %p)\n",
5624 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
5625 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5626 PL_xsubfilename = file; /* so the old name must be restored for
5627 additional XSUBs to register themselves */
5628 /* XSUBs can't be perl lang/perl5db.pl debugged
5629 if (PERLDB_LINE_OR_SAVESRC)
5630 (void)gv_fetchfile(file); */
5633 if(key & HSf_POPMARK) {
5635 { SV **mark = PL_stack_base + ax++;
5637 items = (I32)(SP - MARK);
5641 items = va_arg(args, U32);
5642 ax = va_arg(args, U32);
5646 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
5647 if((apiverlen = HS_GETAPIVERLEN(key))) {
5648 char * api_p = va_arg(args, char*);
5649 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5650 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5651 sizeof("v" PERL_API_VERSION_STRING)-1))
5652 Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
5653 api_p, SVfARG(PL_stack_base[ax + 0]),
5654 "v" PERL_API_VERSION_STRING);
5659 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
5660 if((xsverlen = HS_GETXSVERLEN(key)))
5661 S_xs_version_bootcheck(aTHX_
5662 items, ax, va_arg(args, char*), xsverlen);
5670 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5674 const char *vn = NULL;
5675 SV *const module = PL_stack_base[ax];
5677 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5679 if (items >= 2) /* version supplied as bootstrap arg */
5680 sv = PL_stack_base[ax + 1];
5682 /* XXX GV_ADDWARN */
5684 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
5685 if (!sv || !SvOK(sv)) {
5687 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
5691 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5692 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5693 ? sv : sv_2mortal(new_version(sv));
5694 xssv = upg_version(xssv, 0);
5695 if ( vcmp(pmsv,xssv) ) {
5696 SV *string = vstringify(xssv);
5697 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5698 " does not match ", SVfARG(module), SVfARG(string));
5700 SvREFCNT_dec(string);
5701 string = vstringify(pmsv);
5704 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn,
5707 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
5709 SvREFCNT_dec(string);
5711 Perl_sv_2mortal(aTHX_ xpt);
5712 Perl_croak_sv(aTHX_ xpt);
5718 =for apidoc my_strlcat
5720 The C library C<strlcat> if available, or a Perl implementation of it.
5721 This operates on C C<NUL>-terminated strings.
5723 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
5724 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
5725 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5726 practice this should not happen as it means that either C<size> is incorrect or
5727 that C<dst> is not a proper C<NUL>-terminated string).
5729 Note that C<size> is the full size of the destination buffer and
5730 the result is guaranteed to be C<NUL>-terminated if there is room. Note that
5731 room for the C<NUL> should be included in C<size>.
5733 The return value is the total length that C<dst> would have if C<size> is
5734 sufficiently large. Thus it is the initial length of C<dst> plus the length of
5735 C<src>. If C<size> is smaller than the return, the excess was not appended.
5739 Description stolen from http://man.openbsd.org/strlcat.3
5743 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5745 Size_t used, length, copy;
5748 length = strlen(src);
5749 if (size > 0 && used < size - 1) {
5750 copy = (length >= size - used) ? size - used - 1 : length;
5751 memcpy(dst + used, src, copy);
5752 dst[used + copy] = '\0';
5754 return used + length;
5760 =for apidoc my_strlcpy
5762 The C library C<strlcpy> if available, or a Perl implementation of it.
5763 This operates on C C<NUL>-terminated strings.
5765 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5766 to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
5768 The return value is the total length C<src> would be if the copy completely
5769 succeeded. If it is larger than C<size>, the excess was not copied.
5773 Description stolen from http://man.openbsd.org/strlcpy.3
5777 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5779 Size_t length, copy;
5781 length = strlen(src);
5783 copy = (length >= size) ? size - 1 : length;
5784 memcpy(dst, src, copy);
5791 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5792 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5793 long _ftol( double ); /* Defined by VC6 C libs. */
5794 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5797 PERL_STATIC_INLINE bool
5798 S_gv_has_usable_name(pTHX_ GV *gv)
5802 && HvENAME(GvSTASH(gv))
5803 && (gvp = (GV **)hv_fetchhek(
5804 GvSTASH(gv), GvNAME_HEK(gv), 0
5810 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5812 SV * const dbsv = GvSVn(PL_DBsub);
5813 const bool save_taint = TAINT_get;
5815 /* When we are called from pp_goto (svp is null),
5816 * we do not care about using dbsv to call CV;
5817 * it's for informational purposes only.
5820 PERL_ARGS_ASSERT_GET_DB_SUB;
5824 if (!PERLDB_SUB_NN) {
5827 if (!svp && !CvLEXICAL(cv)) {
5828 gv_efullname3(dbsv, gv, NULL);
5830 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
5831 || strEQ(GvNAME(gv), "END")
5832 || ( /* Could be imported, and old sub redefined. */
5833 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5835 !( (SvTYPE(*svp) == SVt_PVGV)
5836 && (GvCV((const GV *)*svp) == cv)
5837 /* Use GV from the stack as a fallback. */
5838 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
5842 /* GV is potentially non-unique, or contain different CV. */
5843 SV * const tmp = newRV(MUTABLE_SV(cv));
5844 sv_setsv(dbsv, tmp);
5848 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5849 sv_catpvs(dbsv, "::");
5850 sv_cathek(dbsv, GvNAME_HEK(gv));
5854 const int type = SvTYPE(dbsv);
5855 if (type < SVt_PVIV && type != SVt_IV)
5856 sv_upgrade(dbsv, SVt_PVIV);
5857 (void)SvIOK_on(dbsv);
5858 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5861 TAINT_IF(save_taint);
5862 #ifdef NO_TAINT_SUPPORT
5863 PERL_UNUSED_VAR(save_taint);
5868 Perl_my_dirfd(DIR * dir) {
5870 /* Most dirfd implementations have problems when passed NULL. */
5875 #elif defined(HAS_DIR_DD_FD)
5878 Perl_croak_nocontext(PL_no_func, "dirfd");
5879 NOT_REACHED; /* NOTREACHED */
5885 Perl_get_re_arg(pTHX_ SV *sv) {
5891 sv = MUTABLE_SV(SvRV(sv));
5892 if (SvTYPE(sv) == SVt_REGEXP)
5893 return (REGEXP*) sv;
5900 * This code is derived from drand48() implementation from FreeBSD,
5901 * found in lib/libc/gen/_rand48.c.
5903 * The U64 implementation is original, based on the POSIX
5904 * specification for drand48().
5908 * Copyright (c) 1993 Martin Birgmeier
5909 * All rights reserved.
5911 * You may redistribute unmodified or modified versions of this source
5912 * code provided that the above copyright notice and this and the
5913 * following conditions are retained.
5915 * This software is provided ``as is'', and comes with no warranties
5916 * of any kind. I shall in no event be liable for anything that happens
5917 * to anyone/anything when using this software.
5920 #define FREEBSD_DRAND48_SEED_0 (0x330e)
5922 #ifdef PERL_DRAND48_QUAD
5924 #define DRAND48_MULT U64_CONST(0x5deece66d)
5925 #define DRAND48_ADD 0xb
5926 #define DRAND48_MASK U64_CONST(0xffffffffffff)
5930 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
5931 #define FREEBSD_DRAND48_SEED_2 (0x1234)
5932 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
5933 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
5934 #define FREEBSD_DRAND48_MULT_2 (0x0005)
5935 #define FREEBSD_DRAND48_ADD (0x000b)
5937 const unsigned short _rand48_mult[3] = {
5938 FREEBSD_DRAND48_MULT_0,
5939 FREEBSD_DRAND48_MULT_1,
5940 FREEBSD_DRAND48_MULT_2
5942 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5947 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5949 PERL_ARGS_ASSERT_DRAND48_INIT_R;
5951 #ifdef PERL_DRAND48_QUAD
5952 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
5954 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5955 random_state->seed[1] = (U16) seed;
5956 random_state->seed[2] = (U16) (seed >> 16);
5961 Perl_drand48_r(perl_drand48_t *random_state)
5963 PERL_ARGS_ASSERT_DRAND48_R;
5965 #ifdef PERL_DRAND48_QUAD
5966 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5969 return ldexp((double)*random_state, -48);
5975 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5976 + (U32) _rand48_add;
5977 temp[0] = (U16) accu; /* lower 16 bits */
5978 accu >>= sizeof(U16) * 8;
5979 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5980 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5981 temp[1] = (U16) accu; /* middle 16 bits */
5982 accu >>= sizeof(U16) * 8;
5983 accu += _rand48_mult[0] * random_state->seed[2]
5984 + _rand48_mult[1] * random_state->seed[1]
5985 + _rand48_mult[2] * random_state->seed[0];
5986 random_state->seed[0] = temp[0];
5987 random_state->seed[1] = temp[1];
5988 random_state->seed[2] = (U16) accu;
5990 return ldexp((double) random_state->seed[0], -48) +
5991 ldexp((double) random_state->seed[1], -32) +
5992 ldexp((double) random_state->seed[2], -16);
5997 #ifdef USE_C_BACKTRACE
5999 /* Possibly move all this USE_C_BACKTRACE code into a new file. */
6004 /* abfd is the BFD handle. */
6006 /* bfd_syms is the BFD symbol table. */
6008 /* bfd_text is handle to the the ".text" section of the object file. */
6010 /* Since opening the executable and scanning its symbols is quite
6011 * heavy operation, we remember the filename we used the last time,
6012 * and do the opening and scanning only if the filename changes.
6013 * This removes most (but not all) open+scan cycles. */
6014 const char* fname_prev;
6017 /* Given a dl_info, update the BFD context if necessary. */
6018 static void bfd_update(bfd_context* ctx, Dl_info* dl_info)
6020 /* BFD open and scan only if the filename changed. */
6021 if (ctx->fname_prev == NULL ||
6022 strNE(dl_info->dli_fname, ctx->fname_prev)) {
6024 bfd_close(ctx->abfd);
6026 ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
6028 if (bfd_check_format(ctx->abfd, bfd_object)) {
6029 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd);
6030 if (symbol_size > 0) {
6031 Safefree(ctx->bfd_syms);
6032 Newx(ctx->bfd_syms, symbol_size, asymbol*);
6034 bfd_get_section_by_name(ctx->abfd, ".text");
6042 ctx->fname_prev = dl_info->dli_fname;
6046 /* Given a raw frame, try to symbolize it and store
6047 * symbol information (source file, line number) away. */
6048 static void bfd_symbolize(bfd_context* ctx,
6051 STRLEN* symbol_name_size,
6053 STRLEN* source_name_size,
6054 STRLEN* source_line)
6056 *symbol_name = NULL;
6057 *symbol_name_size = 0;
6059 IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma);
6061 bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) {
6064 unsigned int line = 0;
6065 if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text,
6066 ctx->bfd_syms, offset,
6067 &file, &func, &line) &&
6068 file && func && line > 0) {
6069 /* Size and copy the source file, use only
6070 * the basename of the source file.
6072 * NOTE: the basenames are fine for the
6073 * Perl source files, but may not always
6074 * be the best idea for XS files. */
6075 const char *p, *b = NULL;
6076 /* Look for the last slash. */
6077 for (p = file; *p; p++) {
6081 if (b == NULL || *b == 0) {
6084 *source_name_size = p - b + 1;
6085 Newx(*source_name, *source_name_size + 1, char);
6086 Copy(b, *source_name, *source_name_size + 1, char);
6088 *symbol_name_size = strlen(func);
6089 Newx(*symbol_name, *symbol_name_size + 1, char);
6090 Copy(func, *symbol_name, *symbol_name_size + 1, char);
6092 *source_line = line;
6098 #endif /* #ifdef USE_BFD */
6102 /* OS X has no public API for for 'symbolicating' (Apple official term)
6103 * stack addresses to {function_name, source_file, line_number}.
6104 * Good news: there is command line utility atos(1) which does that.
6105 * Bad news 1: it's a command line utility.
6106 * Bad news 2: one needs to have the Developer Tools installed.
6107 * Bad news 3: in newer releases it needs to be run as 'xcrun atos'.
6109 * To recap: we need to open a pipe for reading for a utility which
6110 * might not exist, or exists in different locations, and then parse
6111 * the output. And since this is all for a low-level API, we cannot
6112 * use high-level stuff. Thanks, Apple. */
6115 /* tool is set to the absolute pathname of the tool to use:
6118 /* format is set to a printf format string used for building
6119 * the external command to run. */
6121 /* unavail is set if e.g. xcrun cannot be found, or something
6122 * else happens that makes getting the backtrace dubious. Note,
6123 * however, that the context isn't persistent, the next call to
6124 * get_c_backtrace() will start from scratch. */
6126 /* fname is the current object file name. */
6128 /* object_base_addr is the base address of the shared object. */
6129 void* object_base_addr;
6132 /* Given |dl_info|, updates the context. If the context has been
6133 * marked unavailable, return immediately. If not but the tool has
6134 * not been set, set it to either "xcrun atos" or "atos" (also set the
6135 * format to use for creating commands for piping), or if neither is
6136 * unavailable (one needs the Developer Tools installed), mark the context
6137 * an unavailable. Finally, update the filename (object name),
6138 * and its base address. */
6140 static void atos_update(atos_context* ctx,
6145 if (ctx->tool == NULL) {
6146 const char* tools[] = {
6150 const char* formats[] = {
6151 "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1",
6152 "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1"
6156 for (i = 0; i < C_ARRAY_LENGTH(tools); i++) {
6157 if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) {
6158 ctx->tool = tools[i];
6159 ctx->format = formats[i];
6163 if (ctx->tool == NULL) {
6164 ctx->unavail = TRUE;
6168 if (ctx->fname == NULL ||
6169 strNE(dl_info->dli_fname, ctx->fname)) {
6170 ctx->fname = dl_info->dli_fname;
6171 ctx->object_base_addr = dl_info->dli_fbase;
6175 /* Given an output buffer end |p| and its |start|, matches
6176 * for the atos output, extracting the source code location
6177 * and returning non-NULL if possible, returning NULL otherwise. */
6178 static const char* atos_parse(const char* p,
6180 STRLEN* source_name_size,
6181 STRLEN* source_line) {
6182 /* atos() output is something like:
6183 * perl_parse (in miniperl) (perl.c:2314)\n\n".
6184 * We cannot use Perl regular expressions, because we need to
6185 * stay low-level. Therefore here we have a rolled-out version
6186 * of a state machine which matches _backwards_from_the_end_ and
6187 * if there's a success, returns the starts of the filename,
6188 * also setting the filename size and the source line number.
6189 * The matched regular expression is roughly "\(.*:\d+\)\s*$" */
6190 const char* source_number_start;
6191 const char* source_name_end;
6192 const char* source_line_end;
6193 const char* close_paren;
6196 /* Skip trailing whitespace. */
6197 while (p > start && isspace(*p)) p--;
6198 /* Now we should be at the close paren. */
6199 if (p == start || *p != ')')
6203 /* Now we should be in the line number. */
6204 if (p == start || !isdigit(*p))
6206 /* Skip over the digits. */
6207 while (p > start && isdigit(*p))
6209 /* Now we should be at the colon. */
6210 if (p == start || *p != ':')
6212 source_number_start = p + 1;
6213 source_name_end = p; /* Just beyond the end. */
6215 /* Look for the open paren. */
6216 while (p > start && *p != '(')
6221 *source_name_size = source_name_end - p;
6222 if (grok_atoUV(source_number_start, &uv, &source_line_end)
6223 && source_line_end == close_paren
6224 && uv <= PERL_INT_MAX
6226 *source_line = (STRLEN)uv;
6232 /* Given a raw frame, read a pipe from the symbolicator (that's the
6233 * technical term) atos, reads the result, and parses the source code
6234 * location. We must stay low-level, so we use snprintf(), pipe(),
6235 * and fread(), and then also parse the output ourselves. */
6236 static void atos_symbolize(atos_context* ctx,
6239 STRLEN* source_name_size,
6240 STRLEN* source_line)
6248 /* Simple security measure: if there's any funny business with
6249 * the object name (used as "-o '%s'" ), leave since at least
6250 * partially the user controls it. */
6251 for (p = ctx->fname; *p; p++) {
6252 if (*p == '\'' || iscntrl(*p)) {
6253 ctx->unavail = TRUE;
6257 cnt = snprintf(cmd, sizeof(cmd), ctx->format,
6258 ctx->fname, ctx->object_base_addr, raw_frame);
6259 if (cnt < sizeof(cmd)) {
6260 /* Undo nostdio.h #defines that disable stdio.
6261 * This is somewhat naughty, but is used elsewhere
6262 * in the core, and affects only OS X. */
6267 FILE* fp = popen(cmd, "r");
6268 /* At the moment we open a new pipe for each stack frame.
6269 * This is naturally somewhat slow, but hopefully generating
6270 * stack traces is never going to in a performance critical path.
6272 * We could play tricks with atos by batching the stack
6273 * addresses to be resolved: atos can either take multiple
6274 * addresses from the command line, or read addresses from
6275 * a file (though the mess of creating temporary files would
6276 * probably negate much of any possible speedup).
6278 * Normally there are only two objects present in the backtrace:
6279 * perl itself, and the libdyld.dylib. (Note that the object
6280 * filenames contain the full pathname, so perl may not always
6281 * be in the same place.) Whenever the object in the
6282 * backtrace changes, the base address also changes.
6284 * The problem with batching the addresses, though, would be
6285 * matching the results with the addresses: the parsing of
6286 * the results is already painful enough with a single address. */
6289 UV cnt = fread(out, 1, sizeof(out), fp);
6290 if (cnt < sizeof(out)) {
6291 const char* p = atos_parse(out + cnt - 1, out,
6296 *source_name_size, char);
6297 Copy(p, *source_name,
6298 *source_name_size, char);
6306 #endif /* #ifdef PERL_DARWIN */
6309 =for apidoc get_c_backtrace
6311 Collects the backtrace (aka "stacktrace") into a single linear
6312 malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
6314 Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
6315 returning at most C<depth> frames.
6321 Perl_get_c_backtrace(pTHX_ int depth, int skip)
6323 /* Note that here we must stay as low-level as possible: Newx(),
6324 * Copy(), Safefree(); since we may be called from anywhere,
6325 * so we should avoid higher level constructs like SVs or AVs.
6327 * Since we are using safesysmalloc() via Newx(), don't try
6328 * getting backtrace() there, unless you like deep recursion. */
6330 /* Currently only implemented with backtrace() and dladdr(),
6331 * for other platforms NULL is returned. */
6333 #if defined(HAS_BACKTRACE) && defined(HAS_DLADDR)
6334 /* backtrace() is available via <execinfo.h> in glibc and in most
6335 * modern BSDs; dladdr() is available via <dlfcn.h>. */
6337 /* We try fetching this many frames total, but then discard
6338 * the |skip| first ones. For the remaining ones we will try
6339 * retrieving more information with dladdr(). */
6340 int try_depth = skip + depth;
6342 /* The addresses (program counters) returned by backtrace(). */
6345 /* Retrieved with dladdr() from the addresses returned by backtrace(). */
6348 /* Sizes _including_ the terminating \0 of the object name
6349 * and symbol name strings. */
6350 STRLEN* object_name_sizes;
6351 STRLEN* symbol_name_sizes;
6354 /* The symbol names comes either from dli_sname,
6355 * or if using BFD, they can come from BFD. */
6356 char** symbol_names;
6359 /* The source code location information. Dug out with e.g. BFD. */
6360 char** source_names;
6361 STRLEN* source_name_sizes;
6362 STRLEN* source_lines;
6364 Perl_c_backtrace* bt = NULL; /* This is what will be returned. */
6365 int got_depth; /* How many frames were returned from backtrace(). */
6366 UV frame_count = 0; /* How many frames we return. */
6367 UV total_bytes = 0; /* The size of the whole returned backtrace. */
6370 bfd_context bfd_ctx;
6373 atos_context atos_ctx;
6376 /* Here are probably possibilities for optimizing. We could for
6377 * example have a struct that contains most of these and then
6378 * allocate |try_depth| of them, saving a bunch of malloc calls.
6379 * Note, however, that |frames| could not be part of that struct
6380 * because backtrace() will want an array of just them. Also be
6381 * careful about the name strings. */
6382 Newx(raw_frames, try_depth, void*);
6383 Newx(dl_infos, try_depth, Dl_info);
6384 Newx(object_name_sizes, try_depth, STRLEN);
6385 Newx(symbol_name_sizes, try_depth, STRLEN);
6386 Newx(source_names, try_depth, char*);
6387 Newx(source_name_sizes, try_depth, STRLEN);
6388 Newx(source_lines, try_depth, STRLEN);
6390 Newx(symbol_names, try_depth, char*);
6393 /* Get the raw frames. */
6394 got_depth = (int)backtrace(raw_frames, try_depth);
6396 /* We use dladdr() instead of backtrace_symbols() because we want
6397 * the full details instead of opaque strings. This is useful for
6398 * two reasons: () the details are needed for further symbolic
6399 * digging, for example in OS X (2) by having the details we fully
6400 * control the output, which in turn is useful when more platforms
6401 * are added: we can keep out output "portable". */
6403 /* We want a single linear allocation, which can then be freed
6404 * with a single swoop. We will do the usual trick of first
6405 * walking over the structure and seeing how much we need to
6406 * allocate, then allocating, and then walking over the structure
6407 * the second time and populating it. */
6409 /* First we must compute the total size of the buffer. */
6410 total_bytes = sizeof(Perl_c_backtrace_header);
6411 if (got_depth > skip) {
6414 bfd_init(); /* Is this safe to call multiple times? */
6415 Zero(&bfd_ctx, 1, bfd_context);
6418 Zero(&atos_ctx, 1, atos_context);
6420 for (i = skip; i < try_depth; i++) {
6421 Dl_info* dl_info = &dl_infos[i];
6423 object_name_sizes[i] = 0;
6424 source_names[i] = NULL;
6425 source_name_sizes[i] = 0;
6426 source_lines[i] = 0;
6428 /* Yes, zero from dladdr() is failure. */
6429 if (dladdr(raw_frames[i], dl_info)) {
6430 total_bytes += sizeof(Perl_c_backtrace_frame);
6432 object_name_sizes[i] =
6433 dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
6434 symbol_name_sizes[i] =
6435 dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0;
6437 bfd_update(&bfd_ctx, dl_info);
6438 bfd_symbolize(&bfd_ctx, raw_frames[i],
6440 &symbol_name_sizes[i],
6442 &source_name_sizes[i],
6446 atos_update(&atos_ctx, dl_info);
6447 atos_symbolize(&atos_ctx,
6450 &source_name_sizes[i],
6454 /* Plus ones for the terminating \0. */
6455 total_bytes += object_name_sizes[i] + 1;
6456 total_bytes += symbol_name_sizes[i] + 1;
6457 total_bytes += source_name_sizes[i] + 1;
6465 Safefree(bfd_ctx.bfd_syms);
6469 /* Now we can allocate and populate the result buffer. */
6470 Newxc(bt, total_bytes, char, Perl_c_backtrace);
6471 Zero(bt, total_bytes, char);
6472 bt->header.frame_count = frame_count;
6473 bt->header.total_bytes = total_bytes;
6474 if (frame_count > 0) {
6475 Perl_c_backtrace_frame* frame = bt->frame_info;
6476 char* name_base = (char *)(frame + frame_count);
6477 char* name_curr = name_base; /* Outputting the name strings here. */
6479 for (i = skip; i < skip + frame_count; i++) {
6480 Dl_info* dl_info = &dl_infos[i];
6482 frame->addr = raw_frames[i];
6483 frame->object_base_addr = dl_info->dli_fbase;
6484 frame->symbol_addr = dl_info->dli_saddr;
6486 /* Copies a string, including the \0, and advances the name_curr.
6487 * Also copies the start and the size to the frame. */
6488 #define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \
6490 Copy(src, name_curr, size, char); \
6491 frame->doffset = name_curr - (char*)bt; \
6492 frame->dsize = size; \
6493 name_curr += size; \
6496 PERL_C_BACKTRACE_STRCPY(frame, object_name_offset,
6498 object_name_size, object_name_sizes[i]);
6501 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6503 symbol_name_size, symbol_name_sizes[i]);
6504 Safefree(symbol_names[i]);
6506 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6508 symbol_name_size, symbol_name_sizes[i]);
6511 PERL_C_BACKTRACE_STRCPY(frame, source_name_offset,
6513 source_name_size, source_name_sizes[i]);
6514 Safefree(source_names[i]);
6516 #undef PERL_C_BACKTRACE_STRCPY
6518 frame->source_line_number = source_lines[i];
6522 assert(total_bytes ==
6523 (UV)(sizeof(Perl_c_backtrace_header) +
6524 frame_count * sizeof(Perl_c_backtrace_frame) +
6525 name_curr - name_base));
6528 Safefree(symbol_names);
6530 bfd_close(bfd_ctx.abfd);
6533 Safefree(source_lines);
6534 Safefree(source_name_sizes);
6535 Safefree(source_names);
6536 Safefree(symbol_name_sizes);
6537 Safefree(object_name_sizes);
6538 /* Assuming the strings returned by dladdr() are pointers
6539 * to read-only static memory (the object file), so that
6540 * they do not need freeing (and cannot be). */
6542 Safefree(raw_frames);
6545 PERL_UNUSED_ARGV(depth);
6546 PERL_UNUSED_ARGV(skip);
6552 =for apidoc free_c_backtrace
6554 Deallocates a backtrace received from get_c_bracktrace.
6560 =for apidoc get_c_backtrace_dump
6562 Returns a SV containing a dump of C<depth> frames of the call stack, skipping
6563 the C<skip> innermost ones. C<depth> of 20 is usually enough.
6565 The appended output looks like:
6568 1 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl
6569 2 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl
6572 The fields are tab-separated. The first column is the depth (zero
6573 being the innermost non-skipped frame). In the hex:offset, the hex is
6574 where the program counter was in C<S_parse_body>, and the :offset (might
6575 be missing) tells how much inside the C<S_parse_body> the program counter was.
6577 The C<util.c:1716> is the source code file and line number.
6579 The F</usr/bin/perl> is obvious (hopefully).
6581 Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
6582 if the platform doesn't support retrieving the information;
6583 if the binary is missing the debug information;
6584 if the optimizer has transformed the code by for example inlining.
6590 Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
6592 Perl_c_backtrace* bt;
6594 bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */);
6596 Perl_c_backtrace_frame* frame;
6597 SV* dsv = newSVpvs("");
6599 for (i = 0, frame = bt->frame_info;
6600 i < bt->header.frame_count; i++, frame++) {
6601 Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i);
6602 Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-");
6603 /* Symbol (function) names might disappear without debug info.
6605 * The source code location might disappear in case of the
6606 * optimizer inlining or otherwise rearranging the code. */
6607 if (frame->symbol_addr) {
6608 Perl_sv_catpvf(aTHX_ dsv, ":%04x",
6610 ((char*)frame->addr - (char*)frame->symbol_addr));
6612 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6613 frame->symbol_name_size &&
6614 frame->symbol_name_offset ?
6615 (char*)bt + frame->symbol_name_offset : "-");
6616 if (frame->source_name_size &&
6617 frame->source_name_offset &&
6618 frame->source_line_number) {
6619 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
6620 (char*)bt + frame->source_name_offset,
6621 (UV)frame->source_line_number);
6623 Perl_sv_catpvf(aTHX_ dsv, "\t-");
6625 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6626 frame->object_name_size &&
6627 frame->object_name_offset ?
6628 (char*)bt + frame->object_name_offset : "-");
6629 /* The frame->object_base_addr is not output,
6630 * but it is used for symbolizing/symbolicating. */
6631 sv_catpvs(dsv, "\n");
6634 Perl_free_c_backtrace(aTHX_ bt);
6643 =for apidoc dump_c_backtrace
6645 Dumps the C backtrace to the given C<fp>.
6647 Returns true if a backtrace could be retrieved, false if not.
6653 Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
6657 PERL_ARGS_ASSERT_DUMP_C_BACKTRACE;
6659 sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip);
6662 PerlIO_printf(fp, "%s", SvPV_nolen(sv));
6668 #endif /* #ifdef USE_C_BACKTRACE */
6670 #ifdef PERL_TSA_ACTIVE
6672 /* pthread_mutex_t and perl_mutex are typedef equivalent
6673 * so casting the pointers is fine. */
6675 int perl_tsa_mutex_lock(perl_mutex* mutex)
6677 return pthread_mutex_lock((pthread_mutex_t *) mutex);
6680 int perl_tsa_mutex_unlock(perl_mutex* mutex)
6682 return pthread_mutex_unlock((pthread_mutex_t *) mutex);
6685 int perl_tsa_mutex_destroy(perl_mutex* mutex)
6687 return pthread_mutex_destroy((pthread_mutex_t *) mutex);
6695 /* log a sub call or return */
6698 Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call)
6706 PERL_ARGS_ASSERT_DTRACE_PROBE_CALL;
6709 HEK *hek = CvNAME_HEK(cv);
6710 func = HEK_KEY(hek);
6716 start = (const COP *)CvSTART(cv);
6717 file = CopFILE(start);
6718 line = CopLINE(start);
6719 stash = CopSTASHPV(start);
6722 PERL_SUB_ENTRY(func, file, line, stash);
6725 PERL_SUB_RETURN(func, file, line, stash);
6730 /* log a require file loading/loaded */
6733 Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading)
6735 PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
6738 PERL_LOADING_FILE(name);
6741 PERL_LOADED_FILE(name);
6746 /* log an op execution */
6749 Perl_dtrace_probe_op(pTHX_ const OP *op)
6751 PERL_ARGS_ASSERT_DTRACE_PROBE_OP;
6753 PERL_OP_ENTRY(OP_NAME(op));
6757 /* log a compile/run phase change */
6760 Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase)
6762 const char *ph_old = PL_phase_names[PL_phase];
6763 const char *ph_new = PL_phase_names[phase];
6765 PERL_PHASE_CHANGE(ph_new, ph_old);
6771 * ex: set ts=8 sts=4 sw=4 et: