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 */
50 # include <sys/select.h>
54 #ifdef PERL_DEBUG_READONLY_COW
55 # include <sys/mman.h>
60 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
61 # define FD_CLOEXEC 1 /* NeXT needs this */
64 /* NOTE: Do not call the next three routines directly. Use the macros
65 * in handy.h, so that we can easily redefine everything to do tracking of
66 * allocated hunks back to the original New to track down any memory leaks.
67 * XXX This advice seems to be widely ignored :-( --AD August 1996.
70 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
71 # define ALWAYS_NEED_THX
74 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
76 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
79 && mprotect(header, header->size, PROT_READ|PROT_WRITE))
80 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
81 header, header->size, errno);
85 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
88 && mprotect(header, header->size, PROT_READ))
89 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
90 header, header->size, errno);
92 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
93 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
95 # define maybe_protect_rw(foo) NOOP
96 # define maybe_protect_ro(foo) NOOP
99 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
100 /* Use memory_debug_header */
102 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
103 || defined(PERL_DEBUG_READONLY_COW)
104 # define MDH_HAS_SIZE
108 /* paranoid version of system's malloc() */
111 Perl_safesysmalloc(MEM_SIZE size)
113 #ifdef ALWAYS_NEED_THX
117 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
119 if ((SSize_t)size < 0)
120 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
122 if (!size) size = 1; /* malloc(0) is NASTY on our system */
123 #ifdef PERL_DEBUG_READONLY_COW
124 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
125 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
126 perror("mmap failed");
130 ptr = (Malloc_t)PerlMem_malloc(size?size:1);
132 PERL_ALLOC_CHECK(ptr);
135 struct perl_memory_debug_header *const header
136 = (struct perl_memory_debug_header *)ptr;
140 PoisonNew(((char *)ptr), size, char);
143 #ifdef PERL_TRACK_MEMPOOL
144 header->interpreter = aTHX;
145 /* Link us into the list. */
146 header->prev = &PL_memory_debug_header;
147 header->next = PL_memory_debug_header.next;
148 PL_memory_debug_header.next = header;
149 maybe_protect_rw(header->next);
150 header->next->prev = header;
151 maybe_protect_ro(header->next);
152 # ifdef PERL_DEBUG_READONLY_COW
153 header->readonly = 0;
159 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
160 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
164 #ifndef ALWAYS_NEED_THX
176 /* paranoid version of system's realloc() */
179 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
181 #ifdef ALWAYS_NEED_THX
185 #ifdef PERL_DEBUG_READONLY_COW
186 const MEM_SIZE oldsize = where
187 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
190 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
191 Malloc_t PerlMem_realloc();
192 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
200 return safesysmalloc(size);
202 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
203 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
205 struct perl_memory_debug_header *const header
206 = (struct perl_memory_debug_header *)where;
208 # ifdef PERL_TRACK_MEMPOOL
209 if (header->interpreter != aTHX) {
210 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
211 header->interpreter, aTHX);
213 assert(header->next->prev == header);
214 assert(header->prev->next == header);
216 if (header->size > size) {
217 const MEM_SIZE freed_up = header->size - size;
218 char *start_of_freed = ((char *)where) + size;
219 PoisonFree(start_of_freed, freed_up, char);
229 if ((SSize_t)size < 0)
230 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
232 #ifdef PERL_DEBUG_READONLY_COW
233 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
234 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
235 perror("mmap failed");
238 Copy(where,ptr,oldsize < size ? oldsize : size,char);
239 if (munmap(where, oldsize)) {
240 perror("munmap failed");
244 ptr = (Malloc_t)PerlMem_realloc(where,size);
246 PERL_ALLOC_CHECK(ptr);
248 /* MUST do this fixup first, before doing ANYTHING else, as anything else
249 might allocate memory/free/move memory, and until we do the fixup, it
250 may well be chasing (and writing to) free memory. */
252 #ifdef PERL_TRACK_MEMPOOL
253 struct perl_memory_debug_header *const header
254 = (struct perl_memory_debug_header *)ptr;
257 if (header->size < size) {
258 const MEM_SIZE fresh = size - header->size;
259 char *start_of_fresh = ((char *)ptr) + size;
260 PoisonNew(start_of_fresh, fresh, char);
264 maybe_protect_rw(header->next);
265 header->next->prev = header;
266 maybe_protect_ro(header->next);
267 maybe_protect_rw(header->prev);
268 header->prev->next = header;
269 maybe_protect_ro(header->prev);
271 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
274 /* In particular, must do that fixup above before logging anything via
275 *printf(), as it can reallocate memory, which can cause SEGVs. */
277 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
278 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
285 #ifndef ALWAYS_NEED_THX
297 /* safe version of system's free() */
300 Perl_safesysfree(Malloc_t where)
302 #ifdef ALWAYS_NEED_THX
307 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
310 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
312 struct perl_memory_debug_header *const header
313 = (struct perl_memory_debug_header *)where;
316 const MEM_SIZE size = header->size;
318 # ifdef PERL_TRACK_MEMPOOL
319 if (header->interpreter != aTHX) {
320 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
321 header->interpreter, aTHX);
324 Perl_croak_nocontext("panic: duplicate free");
327 Perl_croak_nocontext("panic: bad free, header->next==NULL");
328 if (header->next->prev != header || header->prev->next != header) {
329 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
330 "header=%p, ->prev->next=%p",
331 header->next->prev, header,
334 /* Unlink us from the chain. */
335 maybe_protect_rw(header->next);
336 header->next->prev = header->prev;
337 maybe_protect_ro(header->next);
338 maybe_protect_rw(header->prev);
339 header->prev->next = header->next;
340 maybe_protect_ro(header->prev);
341 maybe_protect_rw(header);
343 PoisonNew(where, size, char);
345 /* Trigger the duplicate free warning. */
348 # ifdef PERL_DEBUG_READONLY_COW
349 if (munmap(where, size)) {
350 perror("munmap failed");
356 #ifndef PERL_DEBUG_READONLY_COW
362 /* safe version of system's calloc() */
365 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
367 #ifdef ALWAYS_NEED_THX
371 #if defined(USE_MDH) || defined(DEBUGGING)
372 MEM_SIZE total_size = 0;
375 /* Even though calloc() for zero bytes is strange, be robust. */
376 if (size && (count <= MEM_SIZE_MAX / size)) {
377 #if defined(USE_MDH) || defined(DEBUGGING)
378 total_size = size * count;
384 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
385 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
390 if ((SSize_t)size < 0 || (SSize_t)count < 0)
391 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
392 (UV)size, (UV)count);
394 #ifdef PERL_DEBUG_READONLY_COW
395 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
396 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
397 perror("mmap failed");
400 #elif defined(PERL_TRACK_MEMPOOL)
401 /* Have to use malloc() because we've added some space for our tracking
403 /* malloc(0) is non-portable. */
404 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
406 /* Use calloc() because it might save a memset() if the memory is fresh
407 and clean from the OS. */
409 ptr = (Malloc_t)PerlMem_calloc(count, size);
410 else /* calloc(0) is non-portable. */
411 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
413 PERL_ALLOC_CHECK(ptr);
414 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));
418 struct perl_memory_debug_header *const header
419 = (struct perl_memory_debug_header *)ptr;
421 # ifndef PERL_DEBUG_READONLY_COW
422 memset((void*)ptr, 0, total_size);
424 # ifdef PERL_TRACK_MEMPOOL
425 header->interpreter = aTHX;
426 /* Link us into the list. */
427 header->prev = &PL_memory_debug_header;
428 header->next = PL_memory_debug_header.next;
429 PL_memory_debug_header.next = header;
430 maybe_protect_rw(header->next);
431 header->next->prev = header;
432 maybe_protect_ro(header->next);
433 # ifdef PERL_DEBUG_READONLY_COW
434 header->readonly = 0;
438 header->size = total_size;
440 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
446 #ifndef ALWAYS_NEED_THX
455 /* These must be defined when not using Perl's malloc for binary
460 Malloc_t Perl_malloc (MEM_SIZE nbytes)
463 return (Malloc_t)PerlMem_malloc(nbytes);
466 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
469 return (Malloc_t)PerlMem_calloc(elements, size);
472 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
475 return (Malloc_t)PerlMem_realloc(where, nbytes);
478 Free_t Perl_mfree (Malloc_t where)
486 /* copy a string up to some (non-backslashed) delimiter, if any */
489 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
493 PERL_ARGS_ASSERT_DELIMCPY;
495 for (tolen = 0; from < fromend; from++, tolen++) {
497 if (from[1] != delim) {
504 else if (*from == delim)
515 /* return ptr to little string in big string, NULL if not found */
516 /* This routine was donated by Corey Satten. */
519 Perl_instr(const char *big, const char *little)
522 PERL_ARGS_ASSERT_INSTR;
524 /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL
528 return strstr((char*)big, (char*)little);
531 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond
532 * the final character desired to be checked */
535 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
537 PERL_ARGS_ASSERT_NINSTR;
541 const char first = *little;
543 bigend -= lend - little++;
545 while (big <= bigend) {
546 if (*big++ == first) {
547 for (x=big,s=little; s < lend; x++,s++) {
551 return (char*)(big-1);
558 /* reverse of the above--find last substring */
561 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
564 const I32 first = *little;
565 const char * const littleend = lend;
567 PERL_ARGS_ASSERT_RNINSTR;
569 if (little >= littleend)
570 return (char*)bigend;
572 big = bigend - (littleend - little++);
573 while (big >= bigbeg) {
577 for (x=big+2,s=little; s < littleend; /**/ ) {
586 return (char*)(big+1);
591 /* As a space optimization, we do not compile tables for strings of length
592 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
593 special-cased in fbm_instr().
595 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
598 =head1 Miscellaneous Functions
600 =for apidoc fbm_compile
602 Analyses the string in order to make fast searches on it using fbm_instr()
603 -- the Boyer-Moore algorithm.
609 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
617 PERL_DEB( STRLEN rarest = 0 );
619 PERL_ARGS_ASSERT_FBM_COMPILE;
621 if (isGV_with_GP(sv) || SvROK(sv))
627 if (flags & FBMcf_TAIL) {
628 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
629 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
630 if (mg && mg->mg_len >= 0)
633 if (!SvPOK(sv) || SvNIOKp(sv))
634 s = (U8*)SvPV_force_mutable(sv, len);
635 else s = (U8 *)SvPV_mutable(sv, len);
636 if (len == 0) /* TAIL might be on a zero-length string. */
638 SvUPGRADE(sv, SVt_PVMG);
643 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
644 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
645 to call SvVALID_off() if the scalar was assigned to.
647 The comment itself (and "deeper magic" below) date back to
648 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
650 where the magic (presumably) was that the scalar had a BM table hidden
653 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
654 the table instead of the previous (somewhat hacky) approach of co-opting
655 the string buffer and storing it after the string. */
657 assert(!mg_find(sv, PERL_MAGIC_bm));
658 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
662 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
664 const U8 mlen = (len>255) ? 255 : (U8)len;
665 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
668 Newx(table, 256, U8);
669 memset((void*)table, mlen, 256);
670 mg->mg_ptr = (char *)table;
673 s += len - 1; /* last char */
676 if (table[*s] == mlen)
682 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
683 for (i = 0; i < len; i++) {
684 if (PL_freq[s[i]] < frequency) {
685 PERL_DEB( rarest = i );
686 frequency = PL_freq[s[i]];
689 BmUSEFUL(sv) = 100; /* Initial value */
690 if (flags & FBMcf_TAIL)
692 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
693 s[rarest], (UV)rarest));
696 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
697 /* If SvTAIL is actually due to \Z or \z, this gives false positives
701 =for apidoc fbm_instr
703 Returns the location of the SV in the string delimited by C<big> and
704 C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
705 does not have to be fbm_compiled, but the search will not be as fast
712 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
716 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
717 STRLEN littlelen = l;
718 const I32 multiline = flags & FBMrf_MULTILINE;
720 PERL_ARGS_ASSERT_FBM_INSTR;
722 if ((STRLEN)(bigend - big) < littlelen) {
723 if ( SvTAIL(littlestr)
724 && ((STRLEN)(bigend - big) == littlelen - 1)
726 || (*big == *little &&
727 memEQ((char *)big, (char *)little, littlelen - 1))))
732 switch (littlelen) { /* Special cases for 0, 1 and 2 */
734 return (char*)big; /* Cannot be SvTAIL! */
736 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
737 /* Know that bigend != big. */
738 if (bigend[-1] == '\n')
739 return (char *)(bigend - 1);
740 return (char *) bigend;
748 if (SvTAIL(littlestr))
749 return (char *) bigend;
752 if (SvTAIL(littlestr) && !multiline) {
753 if (bigend[-1] == '\n' && bigend[-2] == *little)
754 return (char*)bigend - 2;
755 if (bigend[-1] == *little)
756 return (char*)bigend - 1;
760 /* This should be better than FBM if c1 == c2, and almost
761 as good otherwise: maybe better since we do less indirection.
762 And we save a lot of memory by caching no table. */
763 const unsigned char c1 = little[0];
764 const unsigned char c2 = little[1];
769 while (s <= bigend) {
779 goto check_1char_anchor;
790 goto check_1char_anchor;
793 while (s <= bigend) {
798 goto check_1char_anchor;
807 check_1char_anchor: /* One char and anchor! */
808 if (SvTAIL(littlestr) && (*bigend == *little))
809 return (char *)bigend; /* bigend is already decremented. */
812 break; /* Only lengths 0 1 and 2 have special-case code. */
815 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
816 s = bigend - littlelen;
817 if (s >= big && bigend[-1] == '\n' && *s == *little
818 /* Automatically of length > 2 */
819 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
821 return (char*)s; /* how sweet it is */
824 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
826 return (char*)s + 1; /* how sweet it is */
830 if (!SvVALID(littlestr)) {
831 char * const b = ninstr((char*)big,(char*)bigend,
832 (char*)little, (char*)little + littlelen);
834 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
835 /* Chop \n from littlestr: */
836 s = bigend - littlelen + 1;
838 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
848 if (littlelen > (STRLEN)(bigend - big))
852 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
853 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
854 const unsigned char *oldlittle;
856 --littlelen; /* Last char found by table lookup */
859 little += littlelen; /* last char */
865 if ((tmp = table[*s])) {
866 if ((s += tmp) < bigend)
870 else { /* less expensive than calling strncmp() */
871 unsigned char * const olds = s;
876 if (*--s == *--little)
878 s = olds + 1; /* here we pay the price for failure */
880 if (s < bigend) /* fake up continue to outer loop */
890 && memEQ((char *)(bigend - littlelen),
891 (char *)(oldlittle - littlelen), littlelen) )
892 return (char*)bigend - littlelen;
898 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
901 PERL_ARGS_ASSERT_SCREAMINSTR;
902 PERL_UNUSED_ARG(bigstr);
903 PERL_UNUSED_ARG(littlestr);
904 PERL_UNUSED_ARG(start_shift);
905 PERL_UNUSED_ARG(end_shift);
906 PERL_UNUSED_ARG(old_posp);
907 PERL_UNUSED_ARG(last);
909 /* This function must only ever be called on a scalar with study magic,
910 but those do not happen any more. */
911 Perl_croak(aTHX_ "panic: screaminstr");
918 Returns true if the leading len bytes of the strings s1 and s2 are the same
919 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
920 match themselves and their opposite case counterparts. Non-cased and non-ASCII
921 range bytes match only themselves.
928 Perl_foldEQ(const char *s1, const char *s2, I32 len)
930 const U8 *a = (const U8 *)s1;
931 const U8 *b = (const U8 *)s2;
933 PERL_ARGS_ASSERT_FOLDEQ;
938 if (*a != *b && *a != PL_fold[*b])
945 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
947 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
948 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
949 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
950 * does it check that the strings each have at least 'len' characters */
952 const U8 *a = (const U8 *)s1;
953 const U8 *b = (const U8 *)s2;
955 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
960 if (*a != *b && *a != PL_fold_latin1[*b]) {
969 =for apidoc foldEQ_locale
971 Returns true if the leading len bytes of the strings s1 and s2 are the same
972 case-insensitively in the current locale; false otherwise.
978 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
981 const U8 *a = (const U8 *)s1;
982 const U8 *b = (const U8 *)s2;
984 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
989 if (*a != *b && *a != PL_fold_locale[*b])
996 /* copy a string to a safe spot */
999 =head1 Memory Management
1003 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1004 string which is a duplicate of C<pv>. The size of the string is
1005 determined by C<strlen()>. The memory allocated for the new string can
1006 be freed with the C<Safefree()> function.
1008 On some platforms, Windows for example, all allocated memory owned by a thread
1009 is deallocated when that thread ends. So if you need that not to happen, you
1010 need to use the shared memory functions, such as C<L</savesharedpv>>.
1016 Perl_savepv(pTHX_ const char *pv)
1018 PERL_UNUSED_CONTEXT;
1023 const STRLEN pvlen = strlen(pv)+1;
1024 Newx(newaddr, pvlen, char);
1025 return (char*)memcpy(newaddr, pv, pvlen);
1029 /* same thing but with a known length */
1034 Perl's version of what C<strndup()> would be if it existed. Returns a
1035 pointer to a newly allocated string which is a duplicate of the first
1036 C<len> bytes from C<pv>, plus a trailing
1037 NUL byte. The memory allocated for
1038 the new string can be freed with the C<Safefree()> function.
1040 On some platforms, Windows for example, all allocated memory owned by a thread
1041 is deallocated when that thread ends. So if you need that not to happen, you
1042 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1048 Perl_savepvn(pTHX_ const char *pv, I32 len)
1051 PERL_UNUSED_CONTEXT;
1055 Newx(newaddr,len+1,char);
1056 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1058 /* might not be null terminated */
1059 newaddr[len] = '\0';
1060 return (char *) CopyD(pv,newaddr,len,char);
1063 return (char *) ZeroD(newaddr,len+1,char);
1068 =for apidoc savesharedpv
1070 A version of C<savepv()> which allocates the duplicate string in memory
1071 which is shared between threads.
1076 Perl_savesharedpv(pTHX_ const char *pv)
1083 pvlen = strlen(pv)+1;
1084 newaddr = (char*)PerlMemShared_malloc(pvlen);
1088 return (char*)memcpy(newaddr, pv, pvlen);
1092 =for apidoc savesharedpvn
1094 A version of C<savepvn()> which allocates the duplicate string in memory
1095 which is shared between threads. (With the specific difference that a NULL
1096 pointer is not acceptable)
1101 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1103 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1105 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1110 newaddr[len] = '\0';
1111 return (char*)memcpy(newaddr, pv, len);
1115 =for apidoc savesvpv
1117 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1118 the passed in SV using C<SvPV()>
1120 On some platforms, Windows for example, all allocated memory owned by a thread
1121 is deallocated when that thread ends. So if you need that not to happen, you
1122 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1128 Perl_savesvpv(pTHX_ SV *sv)
1131 const char * const pv = SvPV_const(sv, len);
1134 PERL_ARGS_ASSERT_SAVESVPV;
1137 Newx(newaddr,len,char);
1138 return (char *) CopyD(pv,newaddr,len,char);
1142 =for apidoc savesharedsvpv
1144 A version of C<savesharedpv()> which allocates the duplicate string in
1145 memory which is shared between threads.
1151 Perl_savesharedsvpv(pTHX_ SV *sv)
1154 const char * const pv = SvPV_const(sv, len);
1156 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1158 return savesharedpvn(pv, len);
1161 /* the SV for Perl_form() and mess() is not kept in an arena */
1170 if (PL_phase != PERL_PHASE_DESTRUCT)
1171 return newSVpvs_flags("", SVs_TEMP);
1176 /* Create as PVMG now, to avoid any upgrading later */
1178 Newxz(any, 1, XPVMG);
1179 SvFLAGS(sv) = SVt_PVMG;
1180 SvANY(sv) = (void*)any;
1182 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1187 #if defined(PERL_IMPLICIT_CONTEXT)
1189 Perl_form_nocontext(const char* pat, ...)
1194 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1195 va_start(args, pat);
1196 retval = vform(pat, &args);
1200 #endif /* PERL_IMPLICIT_CONTEXT */
1203 =head1 Miscellaneous Functions
1206 Takes a sprintf-style format pattern and conventional
1207 (non-SV) arguments and returns the formatted string.
1209 (char *) Perl_form(pTHX_ const char* pat, ...)
1211 can be used any place a string (char *) is required:
1213 char * s = Perl_form("%d.%d",major,minor);
1215 Uses a single private buffer so if you want to format several strings you
1216 must explicitly copy the earlier strings away (and free the copies when you
1223 Perl_form(pTHX_ const char* pat, ...)
1227 PERL_ARGS_ASSERT_FORM;
1228 va_start(args, pat);
1229 retval = vform(pat, &args);
1235 Perl_vform(pTHX_ const char *pat, va_list *args)
1237 SV * const sv = mess_alloc();
1238 PERL_ARGS_ASSERT_VFORM;
1239 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1244 =for apidoc Am|SV *|mess|const char *pat|...
1246 Take a sprintf-style format pattern and argument list. These are used to
1247 generate a string message. If the message does not end with a newline,
1248 then it will be extended with some indication of the current location
1249 in the code, as described for L</mess_sv>.
1251 Normally, the resulting message is returned in a new mortal SV.
1252 During global destruction a single SV may be shared between uses of
1258 #if defined(PERL_IMPLICIT_CONTEXT)
1260 Perl_mess_nocontext(const char *pat, ...)
1265 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1266 va_start(args, pat);
1267 retval = vmess(pat, &args);
1271 #endif /* PERL_IMPLICIT_CONTEXT */
1274 Perl_mess(pTHX_ const char *pat, ...)
1278 PERL_ARGS_ASSERT_MESS;
1279 va_start(args, pat);
1280 retval = vmess(pat, &args);
1286 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1290 /* Look for curop starting from o. cop is the last COP we've seen. */
1291 /* opnext means that curop is actually the ->op_next of the op we are
1294 PERL_ARGS_ASSERT_CLOSEST_COP;
1296 if (!o || !curop || (
1297 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1301 if (o->op_flags & OPf_KIDS) {
1303 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1306 /* If the OP_NEXTSTATE has been optimised away we can still use it
1307 * the get the file and line number. */
1309 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1310 cop = (const COP *)kid;
1312 /* Keep searching, and return when we've found something. */
1314 new_cop = closest_cop(cop, kid, curop, opnext);
1320 /* Nothing found. */
1326 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1328 Expands a message, intended for the user, to include an indication of
1329 the current location in the code, if the message does not already appear
1332 C<basemsg> is the initial message or object. If it is a reference, it
1333 will be used as-is and will be the result of this function. Otherwise it
1334 is used as a string, and if it already ends with a newline, it is taken
1335 to be complete, and the result of this function will be the same string.
1336 If the message does not end with a newline, then a segment such as C<at
1337 foo.pl line 37> will be appended, and possibly other clauses indicating
1338 the current state of execution. The resulting message will end with a
1341 Normally, the resulting message is returned in a new mortal SV.
1342 During global destruction a single SV may be shared between uses of this
1343 function. If C<consume> is true, then the function is permitted (but not
1344 required) to modify and return C<basemsg> instead of allocating a new SV.
1350 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1355 PERL_ARGS_ASSERT_MESS_SV;
1357 if (SvROK(basemsg)) {
1363 sv_setsv(sv, basemsg);
1368 if (SvPOK(basemsg) && consume) {
1373 sv_copypv(sv, basemsg);
1376 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1378 * Try and find the file and line for PL_op. This will usually be
1379 * PL_curcop, but it might be a cop that has been optimised away. We
1380 * can try to find such a cop by searching through the optree starting
1381 * from the sibling of PL_curcop.
1385 closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
1390 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1391 OutCopFILE(cop), (IV)CopLINE(cop));
1392 /* Seems that GvIO() can be untrustworthy during global destruction. */
1393 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1394 && IoLINES(GvIOp(PL_last_in_gv)))
1397 const bool line_mode = (RsSIMPLE(PL_rs) &&
1398 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1399 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1400 SVfARG(PL_last_in_gv == PL_argvgv
1402 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1403 line_mode ? "line" : "chunk",
1404 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1406 if (PL_phase == PERL_PHASE_DESTRUCT)
1407 sv_catpvs(sv, " during global destruction");
1408 sv_catpvs(sv, ".\n");
1414 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1416 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1417 argument list. These are used to generate a string message. If the
1418 message does not end with a newline, then it will be extended with
1419 some indication of the current location in the code, as described for
1422 Normally, the resulting message is returned in a new mortal SV.
1423 During global destruction a single SV may be shared between uses of
1430 Perl_vmess(pTHX_ const char *pat, va_list *args)
1433 SV * const sv = mess_alloc();
1435 PERL_ARGS_ASSERT_VMESS;
1437 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1438 return mess_sv(sv, 1);
1442 Perl_write_to_stderr(pTHX_ SV* msv)
1448 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1450 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1451 && (io = GvIO(PL_stderrgv))
1452 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1453 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1454 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1456 PerlIO * const serr = Perl_error_log;
1458 do_print(msv, serr);
1459 (void)PerlIO_flush(serr);
1464 =head1 Warning and Dieing
1467 /* Common code used in dieing and warning */
1470 S_with_queued_errors(pTHX_ SV *ex)
1472 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1473 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1474 sv_catsv(PL_errors, ex);
1475 ex = sv_mortalcopy(PL_errors);
1476 SvCUR_set(PL_errors, 0);
1482 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1488 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1489 /* sv_2cv might call Perl_croak() or Perl_warner() */
1490 SV * const oldhook = *hook;
1498 cv = sv_2cv(oldhook, &stash, &gv, 0);
1500 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1510 exarg = newSVsv(ex);
1511 SvREADONLY_on(exarg);
1514 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1518 call_sv(MUTABLE_SV(cv), G_DISCARD);
1527 =for apidoc Am|OP *|die_sv|SV *baseex
1529 Behaves the same as L</croak_sv>, except for the return type.
1530 It should be used only where the C<OP *> return type is required.
1531 The function never actually returns.
1537 Perl_die_sv(pTHX_ SV *baseex)
1539 PERL_ARGS_ASSERT_DIE_SV;
1541 assert(0); /* NOTREACHED */
1546 =for apidoc Am|OP *|die|const char *pat|...
1548 Behaves the same as L</croak>, except for the return type.
1549 It should be used only where the C<OP *> return type is required.
1550 The function never actually returns.
1555 #if defined(PERL_IMPLICIT_CONTEXT)
1557 Perl_die_nocontext(const char* pat, ...)
1561 va_start(args, pat);
1563 assert(0); /* NOTREACHED */
1567 #endif /* PERL_IMPLICIT_CONTEXT */
1570 Perl_die(pTHX_ const char* pat, ...)
1573 va_start(args, pat);
1575 assert(0); /* NOTREACHED */
1581 =for apidoc Am|void|croak_sv|SV *baseex
1583 This is an XS interface to Perl's C<die> function.
1585 C<baseex> is the error message or object. If it is a reference, it
1586 will be used as-is. Otherwise it is used as a string, and if it does
1587 not end with a newline then it will be extended with some indication of
1588 the current location in the code, as described for L</mess_sv>.
1590 The error message or object will be used as an exception, by default
1591 returning control to the nearest enclosing C<eval>, but subject to
1592 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1593 function never returns normally.
1595 To die with a simple string message, the L</croak> function may be
1602 Perl_croak_sv(pTHX_ SV *baseex)
1604 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1605 PERL_ARGS_ASSERT_CROAK_SV;
1606 invoke_exception_hook(ex, FALSE);
1611 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1613 This is an XS interface to Perl's C<die> function.
1615 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1616 argument list. These are used to generate a string message. If the
1617 message does not end with a newline, then it will be extended with
1618 some indication of the current location in the code, as described for
1621 The error message will be used as an exception, by default
1622 returning control to the nearest enclosing C<eval>, but subject to
1623 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1624 function never returns normally.
1626 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1627 (C<$@>) will be used as an error message or object instead of building an
1628 error message from arguments. If you want to throw a non-string object,
1629 or build an error message in an SV yourself, it is preferable to use
1630 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1636 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1638 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1639 invoke_exception_hook(ex, FALSE);
1644 =for apidoc Am|void|croak|const char *pat|...
1646 This is an XS interface to Perl's C<die> function.
1648 Take a sprintf-style format pattern and argument list. These are used to
1649 generate a string message. If the message does not end with a newline,
1650 then it will be extended with some indication of the current location
1651 in the code, as described for L</mess_sv>.
1653 The error message will be used as an exception, by default
1654 returning control to the nearest enclosing C<eval>, but subject to
1655 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1656 function never returns normally.
1658 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1659 (C<$@>) will be used as an error message or object instead of building an
1660 error message from arguments. If you want to throw a non-string object,
1661 or build an error message in an SV yourself, it is preferable to use
1662 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1667 #if defined(PERL_IMPLICIT_CONTEXT)
1669 Perl_croak_nocontext(const char *pat, ...)
1673 va_start(args, pat);
1675 assert(0); /* NOTREACHED */
1678 #endif /* PERL_IMPLICIT_CONTEXT */
1681 Perl_croak(pTHX_ const char *pat, ...)
1684 va_start(args, pat);
1686 assert(0); /* NOTREACHED */
1691 =for apidoc Am|void|croak_no_modify
1693 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1694 terser object code than using C<Perl_croak>. Less code used on exception code
1695 paths reduces CPU cache pressure.
1701 Perl_croak_no_modify(void)
1703 Perl_croak_nocontext( "%s", PL_no_modify);
1706 /* does not return, used in util.c perlio.c and win32.c
1707 This is typically called when malloc returns NULL.
1710 Perl_croak_no_mem(void)
1715 /* Can't use PerlIO to write as it allocates memory */
1716 rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
1717 PL_no_mem, sizeof(PL_no_mem)-1);
1718 /* silently ignore failures */
1719 PERL_UNUSED_VAR(rc);
1723 /* does not return, used only in POPSTACK */
1725 Perl_croak_popstack(void)
1728 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1733 =for apidoc Am|void|warn_sv|SV *baseex
1735 This is an XS interface to Perl's C<warn> function.
1737 C<baseex> is the error message or object. If it is a reference, it
1738 will be used as-is. Otherwise it is used as a string, and if it does
1739 not end with a newline then it will be extended with some indication of
1740 the current location in the code, as described for L</mess_sv>.
1742 The error message or object will by default be written to standard error,
1743 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1745 To warn with a simple string message, the L</warn> function may be
1752 Perl_warn_sv(pTHX_ SV *baseex)
1754 SV *ex = mess_sv(baseex, 0);
1755 PERL_ARGS_ASSERT_WARN_SV;
1756 if (!invoke_exception_hook(ex, TRUE))
1757 write_to_stderr(ex);
1761 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1763 This is an XS interface to Perl's C<warn> function.
1765 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1766 argument list. These are used to generate a string message. If the
1767 message does not end with a newline, then it will be extended with
1768 some indication of the current location in the code, as described for
1771 The error message or object will by default be written to standard error,
1772 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1774 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1780 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1782 SV *ex = vmess(pat, args);
1783 PERL_ARGS_ASSERT_VWARN;
1784 if (!invoke_exception_hook(ex, TRUE))
1785 write_to_stderr(ex);
1789 =for apidoc Am|void|warn|const char *pat|...
1791 This is an XS interface to Perl's C<warn> function.
1793 Take a sprintf-style format pattern and argument list. These are used to
1794 generate a string message. If the message does not end with a newline,
1795 then it will be extended with some indication of the current location
1796 in the code, as described for L</mess_sv>.
1798 The error message or object will by default be written to standard error,
1799 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1801 Unlike with L</croak>, C<pat> is not permitted to be null.
1806 #if defined(PERL_IMPLICIT_CONTEXT)
1808 Perl_warn_nocontext(const char *pat, ...)
1812 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1813 va_start(args, pat);
1817 #endif /* PERL_IMPLICIT_CONTEXT */
1820 Perl_warn(pTHX_ const char *pat, ...)
1823 PERL_ARGS_ASSERT_WARN;
1824 va_start(args, pat);
1829 #if defined(PERL_IMPLICIT_CONTEXT)
1831 Perl_warner_nocontext(U32 err, const char *pat, ...)
1835 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1836 va_start(args, pat);
1837 vwarner(err, pat, &args);
1840 #endif /* PERL_IMPLICIT_CONTEXT */
1843 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1845 PERL_ARGS_ASSERT_CK_WARNER_D;
1847 if (Perl_ckwarn_d(aTHX_ err)) {
1849 va_start(args, pat);
1850 vwarner(err, pat, &args);
1856 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1858 PERL_ARGS_ASSERT_CK_WARNER;
1860 if (Perl_ckwarn(aTHX_ err)) {
1862 va_start(args, pat);
1863 vwarner(err, pat, &args);
1869 Perl_warner(pTHX_ U32 err, const char* pat,...)
1872 PERL_ARGS_ASSERT_WARNER;
1873 va_start(args, pat);
1874 vwarner(err, pat, &args);
1879 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1882 PERL_ARGS_ASSERT_VWARNER;
1883 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1884 SV * const msv = vmess(pat, args);
1886 invoke_exception_hook(msv, FALSE);
1890 Perl_vwarn(aTHX_ pat, args);
1894 /* implements the ckWARN? macros */
1897 Perl_ckwarn(pTHX_ U32 w)
1900 /* If lexical warnings have not been set, use $^W. */
1902 return PL_dowarn & G_WARN_ON;
1904 return ckwarn_common(w);
1907 /* implements the ckWARN?_d macro */
1910 Perl_ckwarn_d(pTHX_ U32 w)
1913 /* If lexical warnings have not been set then default classes warn. */
1917 return ckwarn_common(w);
1921 S_ckwarn_common(pTHX_ U32 w)
1923 if (PL_curcop->cop_warnings == pWARN_ALL)
1926 if (PL_curcop->cop_warnings == pWARN_NONE)
1929 /* Check the assumption that at least the first slot is non-zero. */
1930 assert(unpackWARN1(w));
1932 /* Check the assumption that it is valid to stop as soon as a zero slot is
1934 if (!unpackWARN2(w)) {
1935 assert(!unpackWARN3(w));
1936 assert(!unpackWARN4(w));
1937 } else if (!unpackWARN3(w)) {
1938 assert(!unpackWARN4(w));
1941 /* Right, dealt with all the special cases, which are implemented as non-
1942 pointers, so there is a pointer to a real warnings mask. */
1944 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1946 } while (w >>= WARNshift);
1951 /* Set buffer=NULL to get a new one. */
1953 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1955 const MEM_SIZE len_wanted =
1956 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1957 PERL_UNUSED_CONTEXT;
1958 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1961 (specialWARN(buffer) ?
1962 PerlMemShared_malloc(len_wanted) :
1963 PerlMemShared_realloc(buffer, len_wanted));
1965 Copy(bits, (buffer + 1), size, char);
1966 if (size < WARNsize)
1967 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1971 /* since we've already done strlen() for both nam and val
1972 * we can use that info to make things faster than
1973 * sprintf(s, "%s=%s", nam, val)
1975 #define my_setenv_format(s, nam, nlen, val, vlen) \
1976 Copy(nam, s, nlen, char); \
1978 Copy(val, s+(nlen+1), vlen, char); \
1979 *(s+(nlen+1+vlen)) = '\0'
1981 #ifdef USE_ENVIRON_ARRAY
1982 /* VMS' my_setenv() is in vms.c */
1983 #if !defined(WIN32) && !defined(NETWARE)
1985 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1989 /* only parent thread can modify process environment */
1990 if (PL_curinterp == aTHX)
1993 #ifndef PERL_USE_SAFE_PUTENV
1994 if (!PL_use_safe_putenv) {
1995 /* most putenv()s leak, so we manipulate environ directly */
1997 const I32 len = strlen(nam);
2000 /* where does it go? */
2001 for (i = 0; environ[i]; i++) {
2002 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2006 if (environ == PL_origenviron) { /* need we copy environment? */
2012 while (environ[max])
2014 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2015 for (j=0; j<max; j++) { /* copy environment */
2016 const int len = strlen(environ[j]);
2017 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2018 Copy(environ[j], tmpenv[j], len+1, char);
2021 environ = tmpenv; /* tell exec where it is now */
2024 safesysfree(environ[i]);
2025 while (environ[i]) {
2026 environ[i] = environ[i+1];
2031 if (!environ[i]) { /* does not exist yet */
2032 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2033 environ[i+1] = NULL; /* make sure it's null terminated */
2036 safesysfree(environ[i]);
2040 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2041 /* all that work just for this */
2042 my_setenv_format(environ[i], nam, nlen, val, vlen);
2045 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
2046 # if defined(HAS_UNSETENV)
2048 (void)unsetenv(nam);
2050 (void)setenv(nam, val, 1);
2052 # else /* ! HAS_UNSETENV */
2053 (void)setenv(nam, val, 1);
2054 # endif /* HAS_UNSETENV */
2056 # if defined(HAS_UNSETENV)
2058 if (environ) /* old glibc can crash with null environ */
2059 (void)unsetenv(nam);
2061 const int nlen = strlen(nam);
2062 const int vlen = strlen(val);
2063 char * const new_env =
2064 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2065 my_setenv_format(new_env, nam, nlen, val, vlen);
2066 (void)putenv(new_env);
2068 # else /* ! HAS_UNSETENV */
2070 const int nlen = strlen(nam);
2076 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2077 /* all that work just for this */
2078 my_setenv_format(new_env, nam, nlen, val, vlen);
2079 (void)putenv(new_env);
2080 # endif /* HAS_UNSETENV */
2081 # endif /* __CYGWIN__ */
2082 #ifndef PERL_USE_SAFE_PUTENV
2088 #else /* WIN32 || NETWARE */
2091 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2095 const int nlen = strlen(nam);
2102 Newx(envstr, nlen+vlen+2, char);
2103 my_setenv_format(envstr, nam, nlen, val, vlen);
2104 (void)PerlEnv_putenv(envstr);
2108 #endif /* WIN32 || NETWARE */
2112 #ifdef UNLINK_ALL_VERSIONS
2114 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2118 PERL_ARGS_ASSERT_UNLNK;
2120 while (PerlLIO_unlink(f) >= 0)
2122 return retries ? 0 : -1;
2126 /* this is a drop-in replacement for bcopy() */
2127 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2129 Perl_my_bcopy(const char *from, char *to, I32 len)
2131 char * const retval = to;
2133 PERL_ARGS_ASSERT_MY_BCOPY;
2137 if (from - to >= 0) {
2145 *(--to) = *(--from);
2151 /* this is a drop-in replacement for memset() */
2154 Perl_my_memset(char *loc, I32 ch, I32 len)
2156 char * const retval = loc;
2158 PERL_ARGS_ASSERT_MY_MEMSET;
2168 /* this is a drop-in replacement for bzero() */
2169 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2171 Perl_my_bzero(char *loc, I32 len)
2173 char * const retval = loc;
2175 PERL_ARGS_ASSERT_MY_BZERO;
2185 /* this is a drop-in replacement for memcmp() */
2186 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2188 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2190 const U8 *a = (const U8 *)s1;
2191 const U8 *b = (const U8 *)s2;
2194 PERL_ARGS_ASSERT_MY_MEMCMP;
2199 if ((tmp = *a++ - *b++))
2204 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2207 /* This vsprintf replacement should generally never get used, since
2208 vsprintf was available in both System V and BSD 2.11. (There may
2209 be some cross-compilation or embedded set-ups where it is needed,
2212 If you encounter a problem in this function, it's probably a symptom
2213 that Configure failed to detect your system's vprintf() function.
2214 See the section on "item vsprintf" in the INSTALL file.
2216 This version may compile on systems with BSD-ish <stdio.h>,
2217 but probably won't on others.
2220 #ifdef USE_CHAR_VSPRINTF
2225 vsprintf(char *dest, const char *pat, void *args)
2229 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2230 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2231 FILE_cnt(&fakebuf) = 32767;
2233 /* These probably won't compile -- If you really need
2234 this, you'll have to figure out some other method. */
2235 fakebuf._ptr = dest;
2236 fakebuf._cnt = 32767;
2241 fakebuf._flag = _IOWRT|_IOSTRG;
2242 _doprnt(pat, args, &fakebuf); /* what a kludge */
2243 #if defined(STDIO_PTR_LVALUE)
2244 *(FILE_ptr(&fakebuf)++) = '\0';
2246 /* PerlIO has probably #defined away fputc, but we want it here. */
2248 # undef fputc /* XXX Should really restore it later */
2250 (void)fputc('\0', &fakebuf);
2252 #ifdef USE_CHAR_VSPRINTF
2255 return 0; /* perl doesn't use return value */
2259 #endif /* HAS_VPRINTF */
2262 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2264 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2273 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2275 PERL_FLUSHALL_FOR_CHILD;
2276 This = (*mode == 'w');
2280 taint_proper("Insecure %s%s", "EXEC");
2282 if (PerlProc_pipe(p) < 0)
2284 /* Try for another pipe pair for error return */
2285 if (PerlProc_pipe(pp) >= 0)
2287 while ((pid = PerlProc_fork()) < 0) {
2288 if (errno != EAGAIN) {
2289 PerlLIO_close(p[This]);
2290 PerlLIO_close(p[that]);
2292 PerlLIO_close(pp[0]);
2293 PerlLIO_close(pp[1]);
2297 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2306 /* Close parent's end of error status pipe (if any) */
2308 PerlLIO_close(pp[0]);
2309 #if defined(HAS_FCNTL) && defined(F_SETFD)
2310 /* Close error pipe automatically if exec works */
2311 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2314 /* Now dup our end of _the_ pipe to right position */
2315 if (p[THIS] != (*mode == 'r')) {
2316 PerlLIO_dup2(p[THIS], *mode == 'r');
2317 PerlLIO_close(p[THIS]);
2318 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2319 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2322 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2323 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2324 /* No automatic close - do it by hand */
2331 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2337 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2343 do_execfree(); /* free any memory malloced by child on fork */
2345 PerlLIO_close(pp[1]);
2346 /* Keep the lower of the two fd numbers */
2347 if (p[that] < p[This]) {
2348 PerlLIO_dup2(p[This], p[that]);
2349 PerlLIO_close(p[This]);
2353 PerlLIO_close(p[that]); /* close child's end of pipe */
2355 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2356 SvUPGRADE(sv,SVt_IV);
2358 PL_forkprocess = pid;
2359 /* If we managed to get status pipe check for exec fail */
2360 if (did_pipes && pid > 0) {
2365 while (n < sizeof(int)) {
2366 n1 = PerlLIO_read(pp[0],
2367 (void*)(((char*)&errkid)+n),
2373 PerlLIO_close(pp[0]);
2375 if (n) { /* Error */
2377 PerlLIO_close(p[This]);
2378 if (n != sizeof(int))
2379 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2381 pid2 = wait4pid(pid, &status, 0);
2382 } while (pid2 == -1 && errno == EINTR);
2383 errno = errkid; /* Propagate errno from kid */
2388 PerlLIO_close(pp[0]);
2389 return PerlIO_fdopen(p[This], mode);
2391 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2392 return my_syspopen4(aTHX_ NULL, mode, n, args);
2394 Perl_croak(aTHX_ "List form of piped open not implemented");
2395 return (PerlIO *) NULL;
2400 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2401 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2403 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2410 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2414 PERL_ARGS_ASSERT_MY_POPEN;
2416 PERL_FLUSHALL_FOR_CHILD;
2419 return my_syspopen(aTHX_ cmd,mode);
2422 This = (*mode == 'w');
2424 if (doexec && TAINTING_get) {
2426 taint_proper("Insecure %s%s", "EXEC");
2428 if (PerlProc_pipe(p) < 0)
2430 if (doexec && PerlProc_pipe(pp) >= 0)
2432 while ((pid = PerlProc_fork()) < 0) {
2433 if (errno != EAGAIN) {
2434 PerlLIO_close(p[This]);
2435 PerlLIO_close(p[that]);
2437 PerlLIO_close(pp[0]);
2438 PerlLIO_close(pp[1]);
2441 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2444 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2454 PerlLIO_close(pp[0]);
2455 #if defined(HAS_FCNTL) && defined(F_SETFD)
2456 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2459 if (p[THIS] != (*mode == 'r')) {
2460 PerlLIO_dup2(p[THIS], *mode == 'r');
2461 PerlLIO_close(p[THIS]);
2462 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2463 PerlLIO_close(p[THAT]);
2466 PerlLIO_close(p[THAT]);
2469 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2476 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2481 /* may or may not use the shell */
2482 do_exec3(cmd, pp[1], did_pipes);
2485 #endif /* defined OS2 */
2487 #ifdef PERLIO_USING_CRLF
2488 /* Since we circumvent IO layers when we manipulate low-level
2489 filedescriptors directly, need to manually switch to the
2490 default, binary, low-level mode; see PerlIOBuf_open(). */
2491 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2494 #ifdef PERL_USES_PL_PIDSTATUS
2495 hv_clear(PL_pidstatus); /* we have no children */
2501 do_execfree(); /* free any memory malloced by child on vfork */
2503 PerlLIO_close(pp[1]);
2504 if (p[that] < p[This]) {
2505 PerlLIO_dup2(p[This], p[that]);
2506 PerlLIO_close(p[This]);
2510 PerlLIO_close(p[that]);
2512 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2513 SvUPGRADE(sv,SVt_IV);
2515 PL_forkprocess = pid;
2516 if (did_pipes && pid > 0) {
2521 while (n < sizeof(int)) {
2522 n1 = PerlLIO_read(pp[0],
2523 (void*)(((char*)&errkid)+n),
2529 PerlLIO_close(pp[0]);
2531 if (n) { /* Error */
2533 PerlLIO_close(p[This]);
2534 if (n != sizeof(int))
2535 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2537 pid2 = wait4pid(pid, &status, 0);
2538 } while (pid2 == -1 && errno == EINTR);
2539 errno = errkid; /* Propagate errno from kid */
2544 PerlLIO_close(pp[0]);
2545 return PerlIO_fdopen(p[This], mode);
2549 FILE *djgpp_popen();
2551 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2553 PERL_FLUSHALL_FOR_CHILD;
2554 /* Call system's popen() to get a FILE *, then import it.
2555 used 0 for 2nd parameter to PerlIO_importFILE;
2558 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2561 #if defined(__LIBCATAMOUNT__)
2563 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2570 #endif /* !DOSISH */
2572 /* this is called in parent before the fork() */
2574 Perl_atfork_lock(void)
2577 #if defined(USE_ITHREADS)
2578 /* locks must be held in locking order (if any) */
2580 MUTEX_LOCK(&PL_perlio_mutex);
2583 MUTEX_LOCK(&PL_malloc_mutex);
2589 /* this is called in both parent and child after the fork() */
2591 Perl_atfork_unlock(void)
2594 #if defined(USE_ITHREADS)
2595 /* locks must be released in same order as in atfork_lock() */
2597 MUTEX_UNLOCK(&PL_perlio_mutex);
2600 MUTEX_UNLOCK(&PL_malloc_mutex);
2609 #if defined(HAS_FORK)
2611 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2616 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2617 * handlers elsewhere in the code */
2622 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2623 Perl_croak_nocontext("fork() not available");
2625 #endif /* HAS_FORK */
2630 dup2(int oldfd, int newfd)
2632 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2635 PerlLIO_close(newfd);
2636 return fcntl(oldfd, F_DUPFD, newfd);
2638 #define DUP2_MAX_FDS 256
2639 int fdtmp[DUP2_MAX_FDS];
2645 PerlLIO_close(newfd);
2646 /* good enough for low fd's... */
2647 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2648 if (fdx >= DUP2_MAX_FDS) {
2656 PerlLIO_close(fdtmp[--fdx]);
2663 #ifdef HAS_SIGACTION
2666 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2669 struct sigaction act, oact;
2672 /* only "parent" interpreter can diddle signals */
2673 if (PL_curinterp != aTHX)
2674 return (Sighandler_t) SIG_ERR;
2677 act.sa_handler = (void(*)(int))handler;
2678 sigemptyset(&act.sa_mask);
2681 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2682 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2684 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2685 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2686 act.sa_flags |= SA_NOCLDWAIT;
2688 if (sigaction(signo, &act, &oact) == -1)
2689 return (Sighandler_t) SIG_ERR;
2691 return (Sighandler_t) oact.sa_handler;
2695 Perl_rsignal_state(pTHX_ int signo)
2697 struct sigaction oact;
2698 PERL_UNUSED_CONTEXT;
2700 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2701 return (Sighandler_t) SIG_ERR;
2703 return (Sighandler_t) oact.sa_handler;
2707 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2710 struct sigaction act;
2712 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2715 /* only "parent" interpreter can diddle signals */
2716 if (PL_curinterp != aTHX)
2720 act.sa_handler = (void(*)(int))handler;
2721 sigemptyset(&act.sa_mask);
2724 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2725 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2727 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2728 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2729 act.sa_flags |= SA_NOCLDWAIT;
2731 return sigaction(signo, &act, save);
2735 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2739 /* only "parent" interpreter can diddle signals */
2740 if (PL_curinterp != aTHX)
2744 return sigaction(signo, save, (struct sigaction *)NULL);
2747 #else /* !HAS_SIGACTION */
2750 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2752 #if defined(USE_ITHREADS) && !defined(WIN32)
2753 /* only "parent" interpreter can diddle signals */
2754 if (PL_curinterp != aTHX)
2755 return (Sighandler_t) SIG_ERR;
2758 return PerlProc_signal(signo, handler);
2769 Perl_rsignal_state(pTHX_ int signo)
2772 Sighandler_t oldsig;
2774 #if defined(USE_ITHREADS) && !defined(WIN32)
2775 /* only "parent" interpreter can diddle signals */
2776 if (PL_curinterp != aTHX)
2777 return (Sighandler_t) SIG_ERR;
2781 oldsig = PerlProc_signal(signo, sig_trap);
2782 PerlProc_signal(signo, oldsig);
2784 PerlProc_kill(PerlProc_getpid(), signo);
2789 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2791 #if defined(USE_ITHREADS) && !defined(WIN32)
2792 /* only "parent" interpreter can diddle signals */
2793 if (PL_curinterp != aTHX)
2796 *save = PerlProc_signal(signo, handler);
2797 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2801 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2803 #if defined(USE_ITHREADS) && !defined(WIN32)
2804 /* only "parent" interpreter can diddle signals */
2805 if (PL_curinterp != aTHX)
2808 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2811 #endif /* !HAS_SIGACTION */
2812 #endif /* !PERL_MICRO */
2814 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2815 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2817 Perl_my_pclose(pTHX_ PerlIO *ptr)
2826 const int fd = PerlIO_fileno(ptr);
2829 svp = av_fetch(PL_fdpid,fd,TRUE);
2830 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2834 #if defined(USE_PERLIO)
2835 /* Find out whether the refcount is low enough for us to wait for the
2836 child proc without blocking. */
2837 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2839 should_wait = pid > 0;
2843 if (pid == -1) { /* Opened by popen. */
2844 return my_syspclose(ptr);
2847 close_failed = (PerlIO_close(ptr) == EOF);
2849 if (should_wait) do {
2850 pid2 = wait4pid(pid, &status, 0);
2851 } while (pid2 == -1 && errno == EINTR);
2858 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2863 #if defined(__LIBCATAMOUNT__)
2865 Perl_my_pclose(pTHX_ PerlIO *ptr)
2870 #endif /* !DOSISH */
2872 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2874 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2878 PERL_ARGS_ASSERT_WAIT4PID;
2879 #ifdef PERL_USES_PL_PIDSTATUS
2881 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2882 waitpid() nor wait4() is available, or on OS/2, which
2883 doesn't appear to support waiting for a progress group
2884 member, so we can only treat a 0 pid as an unknown child.
2891 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2892 pid, rather than a string form. */
2893 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2894 if (svp && *svp != &PL_sv_undef) {
2895 *statusp = SvIVX(*svp);
2896 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2904 hv_iterinit(PL_pidstatus);
2905 if ((entry = hv_iternext(PL_pidstatus))) {
2906 SV * const sv = hv_iterval(PL_pidstatus,entry);
2908 const char * const spid = hv_iterkey(entry,&len);
2910 assert (len == sizeof(Pid_t));
2911 memcpy((char *)&pid, spid, len);
2912 *statusp = SvIVX(sv);
2913 /* The hash iterator is currently on this entry, so simply
2914 calling hv_delete would trigger the lazy delete, which on
2915 aggregate does more work, beacuse next call to hv_iterinit()
2916 would spot the flag, and have to call the delete routine,
2917 while in the meantime any new entries can't re-use that
2919 hv_iterinit(PL_pidstatus);
2920 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2927 # ifdef HAS_WAITPID_RUNTIME
2928 if (!HAS_WAITPID_RUNTIME)
2931 result = PerlProc_waitpid(pid,statusp,flags);
2934 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2935 result = wait4(pid,statusp,flags,NULL);
2938 #ifdef PERL_USES_PL_PIDSTATUS
2939 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2944 Perl_croak(aTHX_ "Can't do waitpid with flags");
2946 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2947 pidgone(result,*statusp);
2953 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2956 if (result < 0 && errno == EINTR) {
2958 errno = EINTR; /* reset in case a signal handler changed $! */
2962 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2964 #ifdef PERL_USES_PL_PIDSTATUS
2966 S_pidgone(pTHX_ Pid_t pid, int status)
2970 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2971 SvUPGRADE(sv,SVt_IV);
2972 SvIV_set(sv, status);
2980 int /* Cannot prototype with I32
2982 my_syspclose(PerlIO *ptr)
2985 Perl_my_pclose(pTHX_ PerlIO *ptr)
2988 /* Needs work for PerlIO ! */
2989 FILE * const f = PerlIO_findFILE(ptr);
2990 const I32 result = pclose(f);
2991 PerlIO_releaseFILE(ptr,f);
2999 Perl_my_pclose(pTHX_ PerlIO *ptr)
3001 /* Needs work for PerlIO ! */
3002 FILE * const f = PerlIO_findFILE(ptr);
3003 I32 result = djgpp_pclose(f);
3004 result = (result << 8) & 0xff00;
3005 PerlIO_releaseFILE(ptr,f);
3010 #define PERL_REPEATCPY_LINEAR 4
3012 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3014 PERL_ARGS_ASSERT_REPEATCPY;
3019 croak_memory_wrap();
3022 memset(to, *from, count);
3025 IV items, linear, half;
3027 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3028 for (items = 0; items < linear; ++items) {
3029 const char *q = from;
3031 for (todo = len; todo > 0; todo--)
3036 while (items <= half) {
3037 IV size = items * len;
3038 memcpy(p, to, size);
3044 memcpy(p, to, (count - items) * len);
3050 Perl_same_dirent(pTHX_ const char *a, const char *b)
3052 char *fa = strrchr(a,'/');
3053 char *fb = strrchr(b,'/');
3056 SV * const tmpsv = sv_newmortal();
3058 PERL_ARGS_ASSERT_SAME_DIRENT;
3071 sv_setpvs(tmpsv, ".");
3073 sv_setpvn(tmpsv, a, fa - a);
3074 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3077 sv_setpvs(tmpsv, ".");
3079 sv_setpvn(tmpsv, b, fb - b);
3080 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3082 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3083 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3085 #endif /* !HAS_RENAME */
3088 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3089 const char *const *const search_ext, I32 flags)
3092 const char *xfound = NULL;
3093 char *xfailed = NULL;
3094 char tmpbuf[MAXPATHLEN];
3099 #if defined(DOSISH) && !defined(OS2)
3100 # define SEARCH_EXTS ".bat", ".cmd", NULL
3101 # define MAX_EXT_LEN 4
3104 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3105 # define MAX_EXT_LEN 4
3108 # define SEARCH_EXTS ".pl", ".com", NULL
3109 # define MAX_EXT_LEN 4
3111 /* additional extensions to try in each dir if scriptname not found */
3113 static const char *const exts[] = { SEARCH_EXTS };
3114 const char *const *const ext = search_ext ? search_ext : exts;
3115 int extidx = 0, i = 0;
3116 const char *curext = NULL;
3118 PERL_UNUSED_ARG(search_ext);
3119 # define MAX_EXT_LEN 0
3122 PERL_ARGS_ASSERT_FIND_SCRIPT;
3125 * If dosearch is true and if scriptname does not contain path
3126 * delimiters, search the PATH for scriptname.
3128 * If SEARCH_EXTS is also defined, will look for each
3129 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3130 * while searching the PATH.
3132 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3133 * proceeds as follows:
3134 * If DOSISH or VMSISH:
3135 * + look for ./scriptname{,.foo,.bar}
3136 * + search the PATH for scriptname{,.foo,.bar}
3139 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3140 * this will not look in '.' if it's not in the PATH)
3145 # ifdef ALWAYS_DEFTYPES
3146 len = strlen(scriptname);
3147 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3148 int idx = 0, deftypes = 1;
3151 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3154 int idx = 0, deftypes = 1;
3157 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3159 /* The first time through, just add SEARCH_EXTS to whatever we
3160 * already have, so we can check for default file types. */
3162 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3168 if ((strlen(tmpbuf) + strlen(scriptname)
3169 + MAX_EXT_LEN) >= sizeof tmpbuf)
3170 continue; /* don't search dir with too-long name */
3171 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3175 if (strEQ(scriptname, "-"))
3177 if (dosearch) { /* Look in '.' first. */
3178 const char *cur = scriptname;
3180 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3182 if (strEQ(ext[i++],curext)) {
3183 extidx = -1; /* already has an ext */
3188 DEBUG_p(PerlIO_printf(Perl_debug_log,
3189 "Looking for %s\n",cur));
3190 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3191 && !S_ISDIR(PL_statbuf.st_mode)) {
3199 if (cur == scriptname) {
3200 len = strlen(scriptname);
3201 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3203 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3206 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3207 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3212 if (dosearch && !strchr(scriptname, '/')
3214 && !strchr(scriptname, '\\')
3216 && (s = PerlEnv_getenv("PATH")))
3220 bufend = s + strlen(s);
3221 while (s < bufend) {
3224 && *s != ';'; len++, s++) {
3225 if (len < sizeof tmpbuf)
3228 if (len < sizeof tmpbuf)
3231 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3237 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3238 continue; /* don't search dir with too-long name */
3241 && tmpbuf[len - 1] != '/'
3242 && tmpbuf[len - 1] != '\\'
3245 tmpbuf[len++] = '/';
3246 if (len == 2 && tmpbuf[0] == '.')
3248 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3252 len = strlen(tmpbuf);
3253 if (extidx > 0) /* reset after previous loop */
3257 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3258 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3259 if (S_ISDIR(PL_statbuf.st_mode)) {
3263 } while ( retval < 0 /* not there */
3264 && extidx>=0 && ext[extidx] /* try an extension? */
3265 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3270 if (S_ISREG(PL_statbuf.st_mode)
3271 && cando(S_IRUSR,TRUE,&PL_statbuf)
3272 #if !defined(DOSISH)
3273 && cando(S_IXUSR,TRUE,&PL_statbuf)
3277 xfound = tmpbuf; /* bingo! */
3281 xfailed = savepv(tmpbuf);
3284 if (!xfound && !seen_dot && !xfailed &&
3285 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3286 || S_ISDIR(PL_statbuf.st_mode)))
3288 seen_dot = 1; /* Disable message. */
3290 if (flags & 1) { /* do or die? */
3291 /* diag_listed_as: Can't execute %s */
3292 Perl_croak(aTHX_ "Can't %s %s%s%s",
3293 (xfailed ? "execute" : "find"),
3294 (xfailed ? xfailed : scriptname),
3295 (xfailed ? "" : " on PATH"),
3296 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3301 scriptname = xfound;
3303 return (scriptname ? savepv(scriptname) : NULL);
3306 #ifndef PERL_GET_CONTEXT_DEFINED
3309 Perl_get_context(void)
3312 #if defined(USE_ITHREADS)
3313 # ifdef OLD_PTHREADS_API
3315 int error = pthread_getspecific(PL_thr_key, &t)
3317 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3320 # ifdef I_MACH_CTHREADS
3321 return (void*)cthread_data(cthread_self());
3323 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3332 Perl_set_context(void *t)
3335 PERL_ARGS_ASSERT_SET_CONTEXT;
3336 #if defined(USE_ITHREADS)
3337 # ifdef I_MACH_CTHREADS
3338 cthread_set_data(cthread_self(), t);
3341 const int error = pthread_setspecific(PL_thr_key, t);
3343 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3351 #endif /* !PERL_GET_CONTEXT_DEFINED */
3353 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3362 Perl_get_op_names(pTHX)
3364 PERL_UNUSED_CONTEXT;
3365 return (char **)PL_op_name;
3369 Perl_get_op_descs(pTHX)
3371 PERL_UNUSED_CONTEXT;
3372 return (char **)PL_op_desc;
3376 Perl_get_no_modify(pTHX)
3378 PERL_UNUSED_CONTEXT;
3379 return PL_no_modify;
3383 Perl_get_opargs(pTHX)
3385 PERL_UNUSED_CONTEXT;
3386 return (U32 *)PL_opargs;
3390 Perl_get_ppaddr(pTHX)
3393 PERL_UNUSED_CONTEXT;
3394 return (PPADDR_t*)PL_ppaddr;
3397 #ifndef HAS_GETENV_LEN
3399 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3401 char * const env_trans = PerlEnv_getenv(env_elem);
3402 PERL_UNUSED_CONTEXT;
3403 PERL_ARGS_ASSERT_GETENV_LEN;
3405 *len = strlen(env_trans);
3412 Perl_get_vtbl(pTHX_ int vtbl_id)
3414 PERL_UNUSED_CONTEXT;
3416 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3417 ? NULL : PL_magic_vtables + vtbl_id;
3421 Perl_my_fflush_all(pTHX)
3423 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3424 return PerlIO_flush(NULL);
3426 # if defined(HAS__FWALK)
3427 extern int fflush(FILE *);
3428 /* undocumented, unprototyped, but very useful BSDism */
3429 extern void _fwalk(int (*)(FILE *));
3433 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3435 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3436 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3438 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3439 open_max = sysconf(_SC_OPEN_MAX);
3442 open_max = FOPEN_MAX;
3445 open_max = OPEN_MAX;
3456 for (i = 0; i < open_max; i++)
3457 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3458 STDIO_STREAM_ARRAY[i]._file < open_max &&
3459 STDIO_STREAM_ARRAY[i]._flag)
3460 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3464 SETERRNO(EBADF,RMS_IFI);
3471 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3473 if (ckWARN(WARN_IO)) {
3475 = gv && (isGV_with_GP(gv))
3478 const char * const direction = have == '>' ? "out" : "in";
3480 if (name && HEK_LEN(name))
3481 Perl_warner(aTHX_ packWARN(WARN_IO),
3482 "Filehandle %"HEKf" opened only for %sput",
3485 Perl_warner(aTHX_ packWARN(WARN_IO),
3486 "Filehandle opened only for %sput", direction);
3491 Perl_report_evil_fh(pTHX_ const GV *gv)
3493 const IO *io = gv ? GvIO(gv) : NULL;
3494 const PERL_BITFIELD16 op = PL_op->op_type;
3498 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3500 warn_type = WARN_CLOSED;
3504 warn_type = WARN_UNOPENED;
3507 if (ckWARN(warn_type)) {
3509 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3510 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3511 const char * const pars =
3512 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3513 const char * const func =
3515 (op == OP_READLINE || op == OP_RCATLINE
3516 ? "readline" : /* "<HANDLE>" not nice */
3517 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3519 const char * const type =
3521 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3522 ? "socket" : "filehandle");
3523 const bool have_name = name && SvCUR(name);
3524 Perl_warner(aTHX_ packWARN(warn_type),
3525 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3526 have_name ? " " : "",
3527 SVfARG(have_name ? name : &PL_sv_no));
3528 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3530 aTHX_ packWARN(warn_type),
3531 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3532 func, pars, have_name ? " " : "",
3533 SVfARG(have_name ? name : &PL_sv_no)
3538 /* To workaround core dumps from the uninitialised tm_zone we get the
3539 * system to give us a reasonable struct to copy. This fix means that
3540 * strftime uses the tm_zone and tm_gmtoff values returned by
3541 * localtime(time()). That should give the desired result most of the
3542 * time. But probably not always!
3544 * This does not address tzname aspects of NETaa14816.
3549 # ifndef STRUCT_TM_HASZONE
3550 # define STRUCT_TM_HASZONE
3554 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3555 # ifndef HAS_TM_TM_ZONE
3556 # define HAS_TM_TM_ZONE
3561 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3563 #ifdef HAS_TM_TM_ZONE
3565 const struct tm* my_tm;
3566 PERL_ARGS_ASSERT_INIT_TM;
3568 my_tm = localtime(&now);
3570 Copy(my_tm, ptm, 1, struct tm);
3572 PERL_ARGS_ASSERT_INIT_TM;
3573 PERL_UNUSED_ARG(ptm);
3578 * mini_mktime - normalise struct tm values without the localtime()
3579 * semantics (and overhead) of mktime().
3582 Perl_mini_mktime(pTHX_ struct tm *ptm)
3586 int month, mday, year, jday;
3587 int odd_cent, odd_year;
3588 PERL_UNUSED_CONTEXT;
3590 PERL_ARGS_ASSERT_MINI_MKTIME;
3592 #define DAYS_PER_YEAR 365
3593 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3594 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3595 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3596 #define SECS_PER_HOUR (60*60)
3597 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3598 /* parentheses deliberately absent on these two, otherwise they don't work */
3599 #define MONTH_TO_DAYS 153/5
3600 #define DAYS_TO_MONTH 5/153
3601 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3602 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3603 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3604 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3607 * Year/day algorithm notes:
3609 * With a suitable offset for numeric value of the month, one can find
3610 * an offset into the year by considering months to have 30.6 (153/5) days,
3611 * using integer arithmetic (i.e., with truncation). To avoid too much
3612 * messing about with leap days, we consider January and February to be
3613 * the 13th and 14th month of the previous year. After that transformation,
3614 * we need the month index we use to be high by 1 from 'normal human' usage,
3615 * so the month index values we use run from 4 through 15.
3617 * Given that, and the rules for the Gregorian calendar (leap years are those
3618 * divisible by 4 unless also divisible by 100, when they must be divisible
3619 * by 400 instead), we can simply calculate the number of days since some
3620 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3621 * the days we derive from our month index, and adding in the day of the
3622 * month. The value used here is not adjusted for the actual origin which
3623 * it normally would use (1 January A.D. 1), since we're not exposing it.
3624 * We're only building the value so we can turn around and get the
3625 * normalised values for the year, month, day-of-month, and day-of-year.
3627 * For going backward, we need to bias the value we're using so that we find
3628 * the right year value. (Basically, we don't want the contribution of
3629 * March 1st to the number to apply while deriving the year). Having done
3630 * that, we 'count up' the contribution to the year number by accounting for
3631 * full quadracenturies (400-year periods) with their extra leap days, plus
3632 * the contribution from full centuries (to avoid counting in the lost leap
3633 * days), plus the contribution from full quad-years (to count in the normal
3634 * leap days), plus the leftover contribution from any non-leap years.
3635 * At this point, if we were working with an actual leap day, we'll have 0
3636 * days left over. This is also true for March 1st, however. So, we have
3637 * to special-case that result, and (earlier) keep track of the 'odd'
3638 * century and year contributions. If we got 4 extra centuries in a qcent,
3639 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3640 * Otherwise, we add back in the earlier bias we removed (the 123 from
3641 * figuring in March 1st), find the month index (integer division by 30.6),
3642 * and the remainder is the day-of-month. We then have to convert back to
3643 * 'real' months (including fixing January and February from being 14/15 in
3644 * the previous year to being in the proper year). After that, to get
3645 * tm_yday, we work with the normalised year and get a new yearday value for
3646 * January 1st, which we subtract from the yearday value we had earlier,
3647 * representing the date we've re-built. This is done from January 1
3648 * because tm_yday is 0-origin.
3650 * Since POSIX time routines are only guaranteed to work for times since the
3651 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3652 * applies Gregorian calendar rules even to dates before the 16th century
3653 * doesn't bother me. Besides, you'd need cultural context for a given
3654 * date to know whether it was Julian or Gregorian calendar, and that's
3655 * outside the scope for this routine. Since we convert back based on the
3656 * same rules we used to build the yearday, you'll only get strange results
3657 * for input which needed normalising, or for the 'odd' century years which
3658 * were leap years in the Julian calendar but not in the Gregorian one.
3659 * I can live with that.
3661 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3662 * that's still outside the scope for POSIX time manipulation, so I don't
3666 year = 1900 + ptm->tm_year;
3667 month = ptm->tm_mon;
3668 mday = ptm->tm_mday;
3674 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3675 yearday += month*MONTH_TO_DAYS + mday + jday;
3677 * Note that we don't know when leap-seconds were or will be,
3678 * so we have to trust the user if we get something which looks
3679 * like a sensible leap-second. Wild values for seconds will
3680 * be rationalised, however.
3682 if ((unsigned) ptm->tm_sec <= 60) {
3689 secs += 60 * ptm->tm_min;
3690 secs += SECS_PER_HOUR * ptm->tm_hour;
3692 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3693 /* got negative remainder, but need positive time */
3694 /* back off an extra day to compensate */
3695 yearday += (secs/SECS_PER_DAY)-1;
3696 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3699 yearday += (secs/SECS_PER_DAY);
3700 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3703 else if (secs >= SECS_PER_DAY) {
3704 yearday += (secs/SECS_PER_DAY);
3705 secs %= SECS_PER_DAY;
3707 ptm->tm_hour = secs/SECS_PER_HOUR;
3708 secs %= SECS_PER_HOUR;
3709 ptm->tm_min = secs/60;
3711 ptm->tm_sec += secs;
3712 /* done with time of day effects */
3714 * The algorithm for yearday has (so far) left it high by 428.
3715 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3716 * bias it by 123 while trying to figure out what year it
3717 * really represents. Even with this tweak, the reverse
3718 * translation fails for years before A.D. 0001.
3719 * It would still fail for Feb 29, but we catch that one below.
3721 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3722 yearday -= YEAR_ADJUST;
3723 year = (yearday / DAYS_PER_QCENT) * 400;
3724 yearday %= DAYS_PER_QCENT;
3725 odd_cent = yearday / DAYS_PER_CENT;
3726 year += odd_cent * 100;
3727 yearday %= DAYS_PER_CENT;
3728 year += (yearday / DAYS_PER_QYEAR) * 4;
3729 yearday %= DAYS_PER_QYEAR;
3730 odd_year = yearday / DAYS_PER_YEAR;
3732 yearday %= DAYS_PER_YEAR;
3733 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3738 yearday += YEAR_ADJUST; /* recover March 1st crock */
3739 month = yearday*DAYS_TO_MONTH;
3740 yearday -= month*MONTH_TO_DAYS;
3741 /* recover other leap-year adjustment */
3750 ptm->tm_year = year - 1900;
3752 ptm->tm_mday = yearday;
3753 ptm->tm_mon = month;
3757 ptm->tm_mon = month - 1;
3759 /* re-build yearday based on Jan 1 to get tm_yday */
3761 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3762 yearday += 14*MONTH_TO_DAYS + 1;
3763 ptm->tm_yday = jday - yearday;
3764 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3768 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)
3776 PERL_ARGS_ASSERT_MY_STRFTIME;
3778 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3781 mytm.tm_hour = hour;
3782 mytm.tm_mday = mday;
3784 mytm.tm_year = year;
3785 mytm.tm_wday = wday;
3786 mytm.tm_yday = yday;
3787 mytm.tm_isdst = isdst;
3789 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3790 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3795 #ifdef HAS_TM_TM_GMTOFF
3796 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3798 #ifdef HAS_TM_TM_ZONE
3799 mytm.tm_zone = mytm2.tm_zone;
3804 Newx(buf, buflen, char);
3806 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3807 len = strftime(buf, buflen, fmt, &mytm);
3811 ** The following is needed to handle to the situation where
3812 ** tmpbuf overflows. Basically we want to allocate a buffer
3813 ** and try repeatedly. The reason why it is so complicated
3814 ** is that getting a return value of 0 from strftime can indicate
3815 ** one of the following:
3816 ** 1. buffer overflowed,
3817 ** 2. illegal conversion specifier, or
3818 ** 3. the format string specifies nothing to be returned(not
3819 ** an error). This could be because format is an empty string
3820 ** or it specifies %p that yields an empty string in some locale.
3821 ** If there is a better way to make it portable, go ahead by
3824 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3827 /* Possibly buf overflowed - try again with a bigger buf */
3828 const int fmtlen = strlen(fmt);
3829 int bufsize = fmtlen + buflen;
3831 Renew(buf, bufsize, char);
3834 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3835 buflen = strftime(buf, bufsize, fmt, &mytm);
3838 if (buflen > 0 && buflen < bufsize)
3840 /* heuristic to prevent out-of-memory errors */
3841 if (bufsize > 100*fmtlen) {
3847 Renew(buf, bufsize, char);
3852 Perl_croak(aTHX_ "panic: no strftime");
3858 #define SV_CWD_RETURN_UNDEF \
3859 sv_setsv(sv, &PL_sv_undef); \
3862 #define SV_CWD_ISDOT(dp) \
3863 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3864 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3867 =head1 Miscellaneous Functions
3869 =for apidoc getcwd_sv
3871 Fill the sv with current working directory
3876 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3877 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3878 * getcwd(3) if available
3879 * Comments from the orignal:
3880 * This is a faster version of getcwd. It's also more dangerous
3881 * because you might chdir out of a directory that you can't chdir
3885 Perl_getcwd_sv(pTHX_ SV *sv)
3891 PERL_ARGS_ASSERT_GETCWD_SV;
3895 char buf[MAXPATHLEN];
3897 /* Some getcwd()s automatically allocate a buffer of the given
3898 * size from the heap if they are given a NULL buffer pointer.
3899 * The problem is that this behaviour is not portable. */
3900 if (getcwd(buf, sizeof(buf) - 1)) {
3905 sv_setsv(sv, &PL_sv_undef);
3913 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3917 SvUPGRADE(sv, SVt_PV);
3919 if (PerlLIO_lstat(".", &statbuf) < 0) {
3920 SV_CWD_RETURN_UNDEF;
3923 orig_cdev = statbuf.st_dev;
3924 orig_cino = statbuf.st_ino;
3934 if (PerlDir_chdir("..") < 0) {
3935 SV_CWD_RETURN_UNDEF;
3937 if (PerlLIO_stat(".", &statbuf) < 0) {
3938 SV_CWD_RETURN_UNDEF;
3941 cdev = statbuf.st_dev;
3942 cino = statbuf.st_ino;
3944 if (odev == cdev && oino == cino) {
3947 if (!(dir = PerlDir_open("."))) {
3948 SV_CWD_RETURN_UNDEF;
3951 while ((dp = PerlDir_read(dir)) != NULL) {
3953 namelen = dp->d_namlen;
3955 namelen = strlen(dp->d_name);
3958 if (SV_CWD_ISDOT(dp)) {
3962 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3963 SV_CWD_RETURN_UNDEF;
3966 tdev = statbuf.st_dev;
3967 tino = statbuf.st_ino;
3968 if (tino == oino && tdev == odev) {
3974 SV_CWD_RETURN_UNDEF;
3977 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3978 SV_CWD_RETURN_UNDEF;
3981 SvGROW(sv, pathlen + namelen + 1);
3985 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3988 /* prepend current directory to the front */
3990 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3991 pathlen += (namelen + 1);
3993 #ifdef VOID_CLOSEDIR
3996 if (PerlDir_close(dir) < 0) {
3997 SV_CWD_RETURN_UNDEF;
4003 SvCUR_set(sv, pathlen);
4007 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4008 SV_CWD_RETURN_UNDEF;
4011 if (PerlLIO_stat(".", &statbuf) < 0) {
4012 SV_CWD_RETURN_UNDEF;
4015 cdev = statbuf.st_dev;
4016 cino = statbuf.st_ino;
4018 if (cdev != orig_cdev || cino != orig_cino) {
4019 Perl_croak(aTHX_ "Unstable directory path, "
4020 "current directory changed unexpectedly");
4033 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4034 # define EMULATE_SOCKETPAIR_UDP
4037 #ifdef EMULATE_SOCKETPAIR_UDP
4039 S_socketpair_udp (int fd[2]) {
4041 /* Fake a datagram socketpair using UDP to localhost. */
4042 int sockets[2] = {-1, -1};
4043 struct sockaddr_in addresses[2];
4045 Sock_size_t size = sizeof(struct sockaddr_in);
4046 unsigned short port;
4049 memset(&addresses, 0, sizeof(addresses));
4052 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4053 if (sockets[i] == -1)
4054 goto tidy_up_and_fail;
4056 addresses[i].sin_family = AF_INET;
4057 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4058 addresses[i].sin_port = 0; /* kernel choses port. */
4059 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4060 sizeof(struct sockaddr_in)) == -1)
4061 goto tidy_up_and_fail;
4064 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4065 for each connect the other socket to it. */
4068 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4070 goto tidy_up_and_fail;
4071 if (size != sizeof(struct sockaddr_in))
4072 goto abort_tidy_up_and_fail;
4073 /* !1 is 0, !0 is 1 */
4074 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4075 sizeof(struct sockaddr_in)) == -1)
4076 goto tidy_up_and_fail;
4079 /* Now we have 2 sockets connected to each other. I don't trust some other
4080 process not to have already sent a packet to us (by random) so send
4081 a packet from each to the other. */
4084 /* I'm going to send my own port number. As a short.
4085 (Who knows if someone somewhere has sin_port as a bitfield and needs
4086 this routine. (I'm assuming crays have socketpair)) */
4087 port = addresses[i].sin_port;
4088 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4089 if (got != sizeof(port)) {
4091 goto tidy_up_and_fail;
4092 goto abort_tidy_up_and_fail;
4096 /* Packets sent. I don't trust them to have arrived though.
4097 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4098 connect to localhost will use a second kernel thread. In 2.6 the
4099 first thread running the connect() returns before the second completes,
4100 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4101 returns 0. Poor programs have tripped up. One poor program's authors'
4102 had a 50-1 reverse stock split. Not sure how connected these were.)
4103 So I don't trust someone not to have an unpredictable UDP stack.
4107 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4108 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4112 FD_SET((unsigned int)sockets[0], &rset);
4113 FD_SET((unsigned int)sockets[1], &rset);
4115 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4116 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4117 || !FD_ISSET(sockets[1], &rset)) {
4118 /* I hope this is portable and appropriate. */
4120 goto tidy_up_and_fail;
4121 goto abort_tidy_up_and_fail;
4125 /* And the paranoia department even now doesn't trust it to have arrive
4126 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4128 struct sockaddr_in readfrom;
4129 unsigned short buffer[2];
4134 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4135 sizeof(buffer), MSG_DONTWAIT,
4136 (struct sockaddr *) &readfrom, &size);
4138 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4140 (struct sockaddr *) &readfrom, &size);
4144 goto tidy_up_and_fail;
4145 if (got != sizeof(port)
4146 || size != sizeof(struct sockaddr_in)
4147 /* Check other socket sent us its port. */
4148 || buffer[0] != (unsigned short) addresses[!i].sin_port
4149 /* Check kernel says we got the datagram from that socket */
4150 || readfrom.sin_family != addresses[!i].sin_family
4151 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4152 || readfrom.sin_port != addresses[!i].sin_port)
4153 goto abort_tidy_up_and_fail;
4156 /* My caller (my_socketpair) has validated that this is non-NULL */
4159 /* I hereby declare this connection open. May God bless all who cross
4163 abort_tidy_up_and_fail:
4164 errno = ECONNABORTED;
4168 if (sockets[0] != -1)
4169 PerlLIO_close(sockets[0]);
4170 if (sockets[1] != -1)
4171 PerlLIO_close(sockets[1]);
4176 #endif /* EMULATE_SOCKETPAIR_UDP */
4178 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4180 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4181 /* Stevens says that family must be AF_LOCAL, protocol 0.
4182 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4187 struct sockaddr_in listen_addr;
4188 struct sockaddr_in connect_addr;
4193 || family != AF_UNIX
4196 errno = EAFNOSUPPORT;
4204 #ifdef EMULATE_SOCKETPAIR_UDP
4205 if (type == SOCK_DGRAM)
4206 return S_socketpair_udp(fd);
4209 aTHXa(PERL_GET_THX);
4210 listener = PerlSock_socket(AF_INET, type, 0);
4213 memset(&listen_addr, 0, sizeof(listen_addr));
4214 listen_addr.sin_family = AF_INET;
4215 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4216 listen_addr.sin_port = 0; /* kernel choses port. */
4217 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4218 sizeof(listen_addr)) == -1)
4219 goto tidy_up_and_fail;
4220 if (PerlSock_listen(listener, 1) == -1)
4221 goto tidy_up_and_fail;
4223 connector = PerlSock_socket(AF_INET, type, 0);
4224 if (connector == -1)
4225 goto tidy_up_and_fail;
4226 /* We want to find out the port number to connect to. */
4227 size = sizeof(connect_addr);
4228 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4230 goto tidy_up_and_fail;
4231 if (size != sizeof(connect_addr))
4232 goto abort_tidy_up_and_fail;
4233 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4234 sizeof(connect_addr)) == -1)
4235 goto tidy_up_and_fail;
4237 size = sizeof(listen_addr);
4238 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4241 goto tidy_up_and_fail;
4242 if (size != sizeof(listen_addr))
4243 goto abort_tidy_up_and_fail;
4244 PerlLIO_close(listener);
4245 /* Now check we are talking to ourself by matching port and host on the
4247 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4249 goto tidy_up_and_fail;
4250 if (size != sizeof(connect_addr)
4251 || listen_addr.sin_family != connect_addr.sin_family
4252 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4253 || listen_addr.sin_port != connect_addr.sin_port) {
4254 goto abort_tidy_up_and_fail;
4260 abort_tidy_up_and_fail:
4262 errno = ECONNABORTED; /* This would be the standard thing to do. */
4264 # ifdef ECONNREFUSED
4265 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4267 errno = ETIMEDOUT; /* Desperation time. */
4274 PerlLIO_close(listener);
4275 if (connector != -1)
4276 PerlLIO_close(connector);
4278 PerlLIO_close(acceptor);
4284 /* In any case have a stub so that there's code corresponding
4285 * to the my_socketpair in embed.fnc. */
4287 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4288 #ifdef HAS_SOCKETPAIR
4289 return socketpair(family, type, protocol, fd);
4298 =for apidoc sv_nosharing
4300 Dummy routine which "shares" an SV when there is no sharing module present.
4301 Or "locks" it. Or "unlocks" it. In other
4302 words, ignores its single SV argument.
4303 Exists to avoid test for a NULL function pointer and because it could
4304 potentially warn under some level of strict-ness.
4310 Perl_sv_nosharing(pTHX_ SV *sv)
4312 PERL_UNUSED_CONTEXT;
4313 PERL_UNUSED_ARG(sv);
4318 =for apidoc sv_destroyable
4320 Dummy routine which reports that object can be destroyed when there is no
4321 sharing module present. It ignores its single SV argument, and returns
4322 'true'. Exists to avoid test for a NULL function pointer and because it
4323 could potentially warn under some level of strict-ness.
4329 Perl_sv_destroyable(pTHX_ SV *sv)
4331 PERL_UNUSED_CONTEXT;
4332 PERL_UNUSED_ARG(sv);
4337 Perl_parse_unicode_opts(pTHX_ const char **popt)
4339 const char *p = *popt;
4342 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4346 opt = (U32) atoi(p);
4349 if (*p && *p != '\n' && *p != '\r') {
4350 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4352 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4358 case PERL_UNICODE_STDIN:
4359 opt |= PERL_UNICODE_STDIN_FLAG; break;
4360 case PERL_UNICODE_STDOUT:
4361 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4362 case PERL_UNICODE_STDERR:
4363 opt |= PERL_UNICODE_STDERR_FLAG; break;
4364 case PERL_UNICODE_STD:
4365 opt |= PERL_UNICODE_STD_FLAG; break;
4366 case PERL_UNICODE_IN:
4367 opt |= PERL_UNICODE_IN_FLAG; break;
4368 case PERL_UNICODE_OUT:
4369 opt |= PERL_UNICODE_OUT_FLAG; break;
4370 case PERL_UNICODE_INOUT:
4371 opt |= PERL_UNICODE_INOUT_FLAG; break;
4372 case PERL_UNICODE_LOCALE:
4373 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4374 case PERL_UNICODE_ARGV:
4375 opt |= PERL_UNICODE_ARGV_FLAG; break;
4376 case PERL_UNICODE_UTF8CACHEASSERT:
4377 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4379 if (*p != '\n' && *p != '\r') {
4380 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4383 "Unknown Unicode option letter '%c'", *p);
4390 opt = PERL_UNICODE_DEFAULT_FLAGS;
4392 the_end_of_the_opts_parser:
4394 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4395 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4396 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4404 # include <starlet.h>
4412 * This is really just a quick hack which grabs various garbage
4413 * values. It really should be a real hash algorithm which
4414 * spreads the effect of every input bit onto every output bit,
4415 * if someone who knows about such things would bother to write it.
4416 * Might be a good idea to add that function to CORE as well.
4417 * No numbers below come from careful analysis or anything here,
4418 * except they are primes and SEED_C1 > 1E6 to get a full-width
4419 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4420 * probably be bigger too.
4423 # define SEED_C1 1000003
4424 #define SEED_C4 73819
4426 # define SEED_C1 25747
4427 #define SEED_C4 20639
4431 #define SEED_C5 26107
4433 #ifndef PERL_NO_DEV_RANDOM
4438 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4439 * in 100-ns units, typically incremented ever 10 ms. */
4440 unsigned int when[2];
4442 # ifdef HAS_GETTIMEOFDAY
4443 struct timeval when;
4449 /* This test is an escape hatch, this symbol isn't set by Configure. */
4450 #ifndef PERL_NO_DEV_RANDOM
4451 #ifndef PERL_RANDOM_DEVICE
4452 /* /dev/random isn't used by default because reads from it will block
4453 * if there isn't enough entropy available. You can compile with
4454 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4455 * is enough real entropy to fill the seed. */
4456 # define PERL_RANDOM_DEVICE "/dev/urandom"
4458 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4460 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4469 _ckvmssts(sys$gettim(when));
4470 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4472 # ifdef HAS_GETTIMEOFDAY
4473 PerlProc_gettimeofday(&when,NULL);
4474 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4477 u = (U32)SEED_C1 * when;
4480 u += SEED_C3 * (U32)PerlProc_getpid();
4481 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4482 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4483 u += SEED_C5 * (U32)PTR2UV(&when);
4489 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4495 PERL_ARGS_ASSERT_GET_HASH_SEED;
4497 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4500 #ifndef USE_HASH_SEED_EXPLICIT
4502 /* ignore leading spaces */
4503 while (isSPACE(*env_pv))
4505 #ifdef USE_PERL_PERTURB_KEYS
4506 /* if they set it to "0" we disable key traversal randomization completely */
4507 if (strEQ(env_pv,"0")) {
4508 PL_hash_rand_bits_enabled= 0;
4510 /* otherwise switch to deterministic mode */
4511 PL_hash_rand_bits_enabled= 2;
4514 /* ignore a leading 0x... if it is there */
4515 if (env_pv[0] == '0' && env_pv[1] == 'x')
4518 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4519 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4520 if ( isXDIGIT(*env_pv)) {
4521 seed_buffer[i] |= READ_XDIGIT(env_pv);
4524 while (isSPACE(*env_pv))
4527 if (*env_pv && !isXDIGIT(*env_pv)) {
4528 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4530 /* should we check for unparsed crap? */
4531 /* should we warn about unused hex? */
4532 /* should we warn about insufficient hex? */
4537 (void)seedDrand01((Rand_seed_t)seed());
4539 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4540 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4543 #ifdef USE_PERL_PERTURB_KEYS
4544 { /* initialize PL_hash_rand_bits from the hash seed.
4545 * This value is highly volatile, it is updated every
4546 * hash insert, and is used as part of hash bucket chain
4547 * randomization and hash iterator randomization. */
4548 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4549 for( i = 0; i < sizeof(UV) ; i++ ) {
4550 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4551 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4554 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4556 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4557 PL_hash_rand_bits_enabled= 0;
4558 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4559 PL_hash_rand_bits_enabled= 1;
4560 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4561 PL_hash_rand_bits_enabled= 2;
4563 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4569 #ifdef PERL_GLOBAL_STRUCT
4571 #define PERL_GLOBAL_STRUCT_INIT
4572 #include "opcode.h" /* the ppaddr and check */
4575 Perl_init_global_struct(pTHX)
4577 struct perl_vars *plvarsp = NULL;
4578 # ifdef PERL_GLOBAL_STRUCT
4579 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4580 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4581 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4582 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4583 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4587 plvarsp = PL_VarsPtr;
4588 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4593 # define PERLVAR(prefix,var,type) /**/
4594 # define PERLVARA(prefix,var,n,type) /**/
4595 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4596 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4597 # include "perlvars.h"
4602 # ifdef PERL_GLOBAL_STRUCT
4605 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4606 if (!plvarsp->Gppaddr)
4610 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4611 if (!plvarsp->Gcheck)
4613 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4614 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4616 # ifdef PERL_SET_VARS
4617 PERL_SET_VARS(plvarsp);
4619 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4620 plvarsp->Gsv_placeholder.sv_flags = 0;
4621 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4623 # undef PERL_GLOBAL_STRUCT_INIT
4628 #endif /* PERL_GLOBAL_STRUCT */
4630 #ifdef PERL_GLOBAL_STRUCT
4633 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4635 int veto = plvarsp->Gveto_cleanup;
4637 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4638 # ifdef PERL_GLOBAL_STRUCT
4639 # ifdef PERL_UNSET_VARS
4640 PERL_UNSET_VARS(plvarsp);
4644 free(plvarsp->Gppaddr);
4645 free(plvarsp->Gcheck);
4646 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4652 #endif /* PERL_GLOBAL_STRUCT */
4656 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
4657 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4658 * given, and you supply your own implementation.
4660 * The default implementation reads a single env var, PERL_MEM_LOG,
4661 * expecting one or more of the following:
4663 * \d+ - fd fd to write to : must be 1st (atoi)
4664 * 'm' - memlog was PERL_MEM_LOG=1
4665 * 's' - svlog was PERL_SV_LOG=1
4666 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
4668 * This makes the logger controllable enough that it can reasonably be
4669 * added to the system perl.
4672 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4673 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4675 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4677 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4678 * writes to. In the default logger, this is settable at runtime.
4680 #ifndef PERL_MEM_LOG_FD
4681 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4684 #ifndef PERL_MEM_LOG_NOIMPL
4686 # ifdef DEBUG_LEAKING_SCALARS
4687 # define SV_LOG_SERIAL_FMT " [%lu]"
4688 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
4690 # define SV_LOG_SERIAL_FMT
4691 # define _SV_LOG_SERIAL_ARG(sv)
4695 S_mem_log_common(enum mem_log_type mlt, const UV n,
4696 const UV typesize, const char *type_name, const SV *sv,
4697 Malloc_t oldalloc, Malloc_t newalloc,
4698 const char *filename, const int linenumber,
4699 const char *funcname)
4703 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4705 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4708 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4710 /* We can't use SVs or PerlIO for obvious reasons,
4711 * so we'll use stdio and low-level IO instead. */
4712 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4714 # ifdef HAS_GETTIMEOFDAY
4715 # define MEM_LOG_TIME_FMT "%10d.%06d: "
4716 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
4718 gettimeofday(&tv, 0);
4720 # define MEM_LOG_TIME_FMT "%10d: "
4721 # define MEM_LOG_TIME_ARG (int)when
4725 /* If there are other OS specific ways of hires time than
4726 * gettimeofday() (see ext/Time-HiRes), the easiest way is
4727 * probably that they would be used to fill in the struct
4731 int fd = atoi(pmlenv);
4733 fd = PERL_MEM_LOG_FD;
4735 if (strchr(pmlenv, 't')) {
4736 len = my_snprintf(buf, sizeof(buf),
4737 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4738 PerlLIO_write(fd, buf, len);
4742 len = my_snprintf(buf, sizeof(buf),
4743 "alloc: %s:%d:%s: %"IVdf" %"UVuf
4744 " %s = %"IVdf": %"UVxf"\n",
4745 filename, linenumber, funcname, n, typesize,
4746 type_name, n * typesize, PTR2UV(newalloc));
4749 len = my_snprintf(buf, sizeof(buf),
4750 "realloc: %s:%d:%s: %"IVdf" %"UVuf
4751 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
4752 filename, linenumber, funcname, n, typesize,
4753 type_name, n * typesize, PTR2UV(oldalloc),
4757 len = my_snprintf(buf, sizeof(buf),
4758 "free: %s:%d:%s: %"UVxf"\n",
4759 filename, linenumber, funcname,
4764 len = my_snprintf(buf, sizeof(buf),
4765 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
4766 mlt == MLT_NEW_SV ? "new" : "del",
4767 filename, linenumber, funcname,
4768 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4773 PerlLIO_write(fd, buf, len);
4777 #endif /* !PERL_MEM_LOG_NOIMPL */
4779 #ifndef PERL_MEM_LOG_NOIMPL
4781 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
4782 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
4784 /* this is suboptimal, but bug compatible. User is providing their
4785 own implementation, but is getting these functions anyway, and they
4786 do nothing. But _NOIMPL users should be able to cope or fix */
4788 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
4789 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
4793 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
4795 const char *filename, const int linenumber,
4796 const char *funcname)
4798 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
4799 NULL, NULL, newalloc,
4800 filename, linenumber, funcname);
4805 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
4806 Malloc_t oldalloc, Malloc_t newalloc,
4807 const char *filename, const int linenumber,
4808 const char *funcname)
4810 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
4811 NULL, oldalloc, newalloc,
4812 filename, linenumber, funcname);
4817 Perl_mem_log_free(Malloc_t oldalloc,
4818 const char *filename, const int linenumber,
4819 const char *funcname)
4821 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
4822 filename, linenumber, funcname);
4827 Perl_mem_log_new_sv(const SV *sv,
4828 const char *filename, const int linenumber,
4829 const char *funcname)
4831 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
4832 filename, linenumber, funcname);
4836 Perl_mem_log_del_sv(const SV *sv,
4837 const char *filename, const int linenumber,
4838 const char *funcname)
4840 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
4841 filename, linenumber, funcname);
4844 #endif /* PERL_MEM_LOG */
4847 =for apidoc my_sprintf
4849 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
4850 the length of the string written to the buffer. Only rare pre-ANSI systems
4851 need the wrapper function - usually this is a direct call to C<sprintf>.
4855 #ifndef SPRINTF_RETURNS_STRLEN
4857 Perl_my_sprintf(char *buffer, const char* pat, ...)
4860 PERL_ARGS_ASSERT_MY_SPRINTF;
4861 va_start(args, pat);
4862 vsprintf(buffer, pat, args);
4864 return strlen(buffer);
4869 =for apidoc my_snprintf
4871 The C library C<snprintf> functionality, if available and
4872 standards-compliant (uses C<vsnprintf>, actually). However, if the
4873 C<vsnprintf> is not available, will unfortunately use the unsafe
4874 C<vsprintf> which can overrun the buffer (there is an overrun check,
4875 but that may be too late). Consider using C<sv_vcatpvf> instead, or
4876 getting C<vsnprintf>.
4881 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
4885 PERL_ARGS_ASSERT_MY_SNPRINTF;
4886 va_start(ap, format);
4887 #ifdef HAS_VSNPRINTF
4888 retval = vsnprintf(buffer, len, format, ap);
4890 retval = vsprintf(buffer, format, ap);
4893 /* vsprintf() shows failure with < 0 */
4895 #ifdef HAS_VSNPRINTF
4896 /* vsnprintf() shows failure with >= len */
4898 (len > 0 && (Size_t)retval >= len)
4901 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
4906 =for apidoc my_vsnprintf
4908 The C library C<vsnprintf> if available and standards-compliant.
4909 However, if if the C<vsnprintf> is not available, will unfortunately
4910 use the unsafe C<vsprintf> which can overrun the buffer (there is an
4911 overrun check, but that may be too late). Consider using
4912 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
4917 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
4923 PERL_ARGS_ASSERT_MY_VSNPRINTF;
4925 Perl_va_copy(ap, apc);
4926 # ifdef HAS_VSNPRINTF
4927 retval = vsnprintf(buffer, len, format, apc);
4929 retval = vsprintf(buffer, format, apc);
4932 # ifdef HAS_VSNPRINTF
4933 retval = vsnprintf(buffer, len, format, ap);
4935 retval = vsprintf(buffer, format, ap);
4937 #endif /* #ifdef NEED_VA_COPY */
4938 /* vsprintf() shows failure with < 0 */
4940 #ifdef HAS_VSNPRINTF
4941 /* vsnprintf() shows failure with >= len */
4943 (len > 0 && (Size_t)retval >= len)
4946 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
4951 Perl_my_clearenv(pTHX)
4954 #if ! defined(PERL_MICRO)
4955 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
4957 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
4958 # if defined(USE_ENVIRON_ARRAY)
4959 # if defined(USE_ITHREADS)
4960 /* only the parent thread can clobber the process environment */
4961 if (PL_curinterp == aTHX)
4962 # endif /* USE_ITHREADS */
4964 # if ! defined(PERL_USE_SAFE_PUTENV)
4965 if ( !PL_use_safe_putenv) {
4967 if (environ == PL_origenviron)
4968 environ = (char**)safesysmalloc(sizeof(char*));
4970 for (i = 0; environ[i]; i++)
4971 (void)safesysfree(environ[i]);
4974 # else /* PERL_USE_SAFE_PUTENV */
4975 # if defined(HAS_CLEARENV)
4977 # elif defined(HAS_UNSETENV)
4978 int bsiz = 80; /* Most envvar names will be shorter than this. */
4979 char *buf = (char*)safesysmalloc(bsiz);
4980 while (*environ != NULL) {
4981 char *e = strchr(*environ, '=');
4982 int l = e ? e - *environ : (int)strlen(*environ);
4984 (void)safesysfree(buf);
4985 bsiz = l + 1; /* + 1 for the \0. */
4986 buf = (char*)safesysmalloc(bsiz);
4988 memcpy(buf, *environ, l);
4990 (void)unsetenv(buf);
4992 (void)safesysfree(buf);
4993 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
4994 /* Just null environ and accept the leakage. */
4996 # endif /* HAS_CLEARENV || HAS_UNSETENV */
4997 # endif /* ! PERL_USE_SAFE_PUTENV */
4999 # endif /* USE_ENVIRON_ARRAY */
5000 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5001 #endif /* PERL_MICRO */
5004 #ifdef PERL_IMPLICIT_CONTEXT
5006 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5007 the global PL_my_cxt_index is incremented, and that value is assigned to
5008 that module's static my_cxt_index (who's address is passed as an arg).
5009 Then, for each interpreter this function is called for, it makes sure a
5010 void* slot is available to hang the static data off, by allocating or
5011 extending the interpreter's PL_my_cxt_list array */
5013 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5015 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5019 PERL_ARGS_ASSERT_MY_CXT_INIT;
5021 /* this module hasn't been allocated an index yet */
5022 #if defined(USE_ITHREADS)
5023 MUTEX_LOCK(&PL_my_ctx_mutex);
5025 *index = PL_my_cxt_index++;
5026 #if defined(USE_ITHREADS)
5027 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5031 /* make sure the array is big enough */
5032 if (PL_my_cxt_size <= *index) {
5033 if (PL_my_cxt_size) {
5034 while (PL_my_cxt_size <= *index)
5035 PL_my_cxt_size *= 2;
5036 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5039 PL_my_cxt_size = 16;
5040 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5043 /* newSV() allocates one more than needed */
5044 p = (void*)SvPVX(newSV(size-1));
5045 PL_my_cxt_list[*index] = p;
5046 Zero(p, size, char);
5050 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5053 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5058 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5060 for (index = 0; index < PL_my_cxt_index; index++) {
5061 const char *key = PL_my_cxt_keys[index];
5062 /* try direct pointer compare first - there are chances to success,
5063 * and it's much faster.
5065 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5072 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5078 PERL_ARGS_ASSERT_MY_CXT_INIT;
5080 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5082 /* this module hasn't been allocated an index yet */
5083 #if defined(USE_ITHREADS)
5084 MUTEX_LOCK(&PL_my_ctx_mutex);
5086 index = PL_my_cxt_index++;
5087 #if defined(USE_ITHREADS)
5088 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5092 /* make sure the array is big enough */
5093 if (PL_my_cxt_size <= index) {
5094 int old_size = PL_my_cxt_size;
5096 if (PL_my_cxt_size) {
5097 while (PL_my_cxt_size <= index)
5098 PL_my_cxt_size *= 2;
5099 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5100 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5103 PL_my_cxt_size = 16;
5104 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5105 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5107 for (i = old_size; i < PL_my_cxt_size; i++) {
5108 PL_my_cxt_keys[i] = 0;
5109 PL_my_cxt_list[i] = 0;
5112 PL_my_cxt_keys[index] = my_cxt_key;
5113 /* newSV() allocates one more than needed */
5114 p = (void*)SvPVX(newSV(size-1));
5115 PL_my_cxt_list[index] = p;
5116 Zero(p, size, char);
5119 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5120 #endif /* PERL_IMPLICIT_CONTEXT */
5123 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5127 const char *vn = NULL;
5128 SV *const module = PL_stack_base[ax];
5130 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5132 if (items >= 2) /* version supplied as bootstrap arg */
5133 sv = PL_stack_base[ax + 1];
5135 /* XXX GV_ADDWARN */
5137 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5138 if (!sv || !SvOK(sv)) {
5140 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5144 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5145 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5146 ? sv : sv_2mortal(new_version(sv));
5147 xssv = upg_version(xssv, 0);
5148 if ( vcmp(pmsv,xssv) ) {
5149 SV *string = vstringify(xssv);
5150 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5151 " does not match ", module, string);
5153 SvREFCNT_dec(string);
5154 string = vstringify(pmsv);
5157 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5160 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
5162 SvREFCNT_dec(string);
5164 Perl_sv_2mortal(aTHX_ xpt);
5165 Perl_croak_sv(aTHX_ xpt);
5171 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
5175 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
5178 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
5180 /* This might croak */
5181 compver = upg_version(compver, 0);
5182 /* This should never croak */
5183 runver = new_version(PL_apiversion);
5184 if (vcmp(compver, runver)) {
5185 SV *compver_string = vstringify(compver);
5186 SV *runver_string = vstringify(runver);
5187 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
5188 " of %"SVf" does not match %"SVf,
5189 compver_string, module, runver_string);
5190 Perl_sv_2mortal(aTHX_ xpt);
5192 SvREFCNT_dec(compver_string);
5193 SvREFCNT_dec(runver_string);
5195 SvREFCNT_dec(runver);
5197 Perl_croak_sv(aTHX_ xpt);
5201 =for apidoc my_strlcat
5203 The C library C<strlcat> if available, or a Perl implementation of it.
5204 This operates on C NUL-terminated strings.
5206 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
5207 most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
5208 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5209 practice this should not happen as it means that either C<size> is incorrect or
5210 that C<dst> is not a proper NUL-terminated string).
5212 Note that C<size> is the full size of the destination buffer and
5213 the result is guaranteed to be NUL-terminated if there is room. Note that room
5214 for the NUL should be included in C<size>.
5218 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
5222 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5224 Size_t used, length, copy;
5227 length = strlen(src);
5228 if (size > 0 && used < size - 1) {
5229 copy = (length >= size - used) ? size - used - 1 : length;
5230 memcpy(dst + used, src, copy);
5231 dst[used + copy] = '\0';
5233 return used + length;
5239 =for apidoc my_strlcpy
5241 The C library C<strlcpy> if available, or a Perl implementation of it.
5242 This operates on C NUL-terminated strings.
5244 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5245 to C<dst>, NUL-terminating the result if C<size> is not 0.
5249 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
5253 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5255 Size_t length, copy;
5257 length = strlen(src);
5259 copy = (length >= size) ? size - 1 : length;
5260 memcpy(dst, src, copy);
5267 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5268 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5269 long _ftol( double ); /* Defined by VC6 C libs. */
5270 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5273 PERL_STATIC_INLINE bool
5274 S_gv_has_usable_name(pTHX_ GV *gv)
5278 && HvENAME(GvSTASH(gv))
5279 && (gvp = (GV **)hv_fetchhek(
5280 GvSTASH(gv), GvNAME_HEK(gv), 0
5286 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5289 SV * const dbsv = GvSVn(PL_DBsub);
5290 const bool save_taint = TAINT_get;
5292 /* When we are called from pp_goto (svp is null),
5293 * we do not care about using dbsv to call CV;
5294 * it's for informational purposes only.
5297 PERL_ARGS_ASSERT_GET_DB_SUB;
5301 if (!PERLDB_SUB_NN) {
5305 gv_efullname3(dbsv, gv, NULL);
5307 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5308 || strEQ(GvNAME(gv), "END")
5309 || ( /* Could be imported, and old sub redefined. */
5310 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5312 !( (SvTYPE(*svp) == SVt_PVGV)
5313 && (GvCV((const GV *)*svp) == cv)
5314 /* Use GV from the stack as a fallback. */
5315 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
5319 /* GV is potentially non-unique, or contain different CV. */
5320 SV * const tmp = newRV(MUTABLE_SV(cv));
5321 sv_setsv(dbsv, tmp);
5325 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5326 sv_catpvs(dbsv, "::");
5328 dbsv, GvNAME(gv), GvNAMELEN(gv),
5329 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
5334 const int type = SvTYPE(dbsv);
5335 if (type < SVt_PVIV && type != SVt_IV)
5336 sv_upgrade(dbsv, SVt_PVIV);
5337 (void)SvIOK_on(dbsv);
5338 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5341 TAINT_IF(save_taint);
5342 #ifdef NO_TAINT_SUPPORT
5343 PERL_UNUSED_VAR(save_taint);
5348 Perl_my_dirfd(pTHX_ DIR * dir) {
5350 /* Most dirfd implementations have problems when passed NULL. */
5355 #elif defined(HAS_DIR_DD_FD)
5358 Perl_die(aTHX_ PL_no_func, "dirfd");
5359 assert(0); /* NOT REACHED */
5365 Perl_get_re_arg(pTHX_ SV *sv) {
5371 sv = MUTABLE_SV(SvRV(sv));
5372 if (SvTYPE(sv) == SVt_REGEXP)
5373 return (REGEXP*) sv;
5380 * This code is derived from drand48() implementation from FreeBSD,
5381 * found in lib/libc/gen/_rand48.c.
5383 * The U64 implementation is original, based on the POSIX
5384 * specification for drand48().
5388 * Copyright (c) 1993 Martin Birgmeier
5389 * All rights reserved.
5391 * You may redistribute unmodified or modified versions of this source
5392 * code provided that the above copyright notice and this and the
5393 * following conditions are retained.
5395 * This software is provided ``as is'', and comes with no warranties
5396 * of any kind. I shall in no event be liable for anything that happens
5397 * to anyone/anything when using this software.
5400 #define FREEBSD_DRAND48_SEED_0 (0x330e)
5402 #ifdef PERL_DRAND48_QUAD
5404 #define DRAND48_MULT U64_CONST(0x5deece66d)
5405 #define DRAND48_ADD 0xb
5406 #define DRAND48_MASK U64_CONST(0xffffffffffff)
5410 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
5411 #define FREEBSD_DRAND48_SEED_2 (0x1234)
5412 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
5413 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
5414 #define FREEBSD_DRAND48_MULT_2 (0x0005)
5415 #define FREEBSD_DRAND48_ADD (0x000b)
5417 const unsigned short _rand48_mult[3] = {
5418 FREEBSD_DRAND48_MULT_0,
5419 FREEBSD_DRAND48_MULT_1,
5420 FREEBSD_DRAND48_MULT_2
5422 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5427 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5429 PERL_ARGS_ASSERT_DRAND48_INIT_R;
5431 #ifdef PERL_DRAND48_QUAD
5432 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
5434 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5435 random_state->seed[1] = (U16) seed;
5436 random_state->seed[2] = (U16) (seed >> 16);
5441 Perl_drand48_r(perl_drand48_t *random_state)
5443 PERL_ARGS_ASSERT_DRAND48_R;
5445 #ifdef PERL_DRAND48_QUAD
5446 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5449 return ldexp((double)*random_state, -48);
5455 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5456 + (U32) _rand48_add;
5457 temp[0] = (U16) accu; /* lower 16 bits */
5458 accu >>= sizeof(U16) * 8;
5459 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5460 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5461 temp[1] = (U16) accu; /* middle 16 bits */
5462 accu >>= sizeof(U16) * 8;
5463 accu += _rand48_mult[0] * random_state->seed[2]
5464 + _rand48_mult[1] * random_state->seed[1]
5465 + _rand48_mult[2] * random_state->seed[0];
5466 random_state->seed[0] = temp[0];
5467 random_state->seed[1] = temp[1];
5468 random_state->seed[2] = (U16) accu;
5470 return ldexp((double) random_state->seed[0], -48) +
5471 ldexp((double) random_state->seed[1], -32) +
5472 ldexp((double) random_state->seed[2], -16);
5480 * c-indentation-style: bsd
5482 * indent-tabs-mode: nil
5485 * ex: set ts=8 sts=4 sw=4 et: