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>
56 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
57 # define FD_CLOEXEC 1 /* NeXT needs this */
60 /* NOTE: Do not call the next three routines directly. Use the macros
61 * in handy.h, so that we can easily redefine everything to do tracking of
62 * allocated hunks back to the original New to track down any memory leaks.
63 * XXX This advice seems to be widely ignored :-( --AD August 1996.
66 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
67 # define ALWAYS_NEED_THX
70 /* paranoid version of system's malloc() */
73 Perl_safesysmalloc(MEM_SIZE size)
75 #ifdef ALWAYS_NEED_THX
79 #ifdef PERL_TRACK_MEMPOOL
83 if ((SSize_t)size < 0)
84 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
86 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
87 PERL_ALLOC_CHECK(ptr);
89 #ifdef PERL_TRACK_MEMPOOL
90 struct perl_memory_debug_header *const header
91 = (struct perl_memory_debug_header *)ptr;
95 PoisonNew(((char *)ptr), size, char);
98 #ifdef PERL_TRACK_MEMPOOL
99 header->interpreter = aTHX;
100 /* Link us into the list. */
101 header->prev = &PL_memory_debug_header;
102 header->next = PL_memory_debug_header.next;
103 PL_memory_debug_header.next = header;
104 header->next->prev = header;
108 ptr = (Malloc_t)((char*)ptr+sTHX);
110 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
114 #ifndef ALWAYS_NEED_THX
126 /* paranoid version of system's realloc() */
129 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
131 #ifdef ALWAYS_NEED_THX
135 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
136 Malloc_t PerlMem_realloc();
137 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
145 return safesysmalloc(size);
146 #ifdef PERL_TRACK_MEMPOOL
147 where = (Malloc_t)((char*)where-sTHX);
150 struct perl_memory_debug_header *const header
151 = (struct perl_memory_debug_header *)where;
153 if (header->interpreter != aTHX) {
154 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
155 header->interpreter, aTHX);
157 assert(header->next->prev == header);
158 assert(header->prev->next == header);
160 if (header->size > size) {
161 const MEM_SIZE freed_up = header->size - size;
162 char *start_of_freed = ((char *)where) + size;
163 PoisonFree(start_of_freed, freed_up, char);
170 if ((SSize_t)size < 0)
171 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
173 ptr = (Malloc_t)PerlMem_realloc(where,size);
174 PERL_ALLOC_CHECK(ptr);
176 /* MUST do this fixup first, before doing ANYTHING else, as anything else
177 might allocate memory/free/move memory, and until we do the fixup, it
178 may well be chasing (and writing to) free memory. */
179 #ifdef PERL_TRACK_MEMPOOL
181 struct perl_memory_debug_header *const header
182 = (struct perl_memory_debug_header *)ptr;
185 if (header->size < size) {
186 const MEM_SIZE fresh = size - header->size;
187 char *start_of_fresh = ((char *)ptr) + size;
188 PoisonNew(start_of_fresh, fresh, char);
192 header->next->prev = header;
193 header->prev->next = header;
195 ptr = (Malloc_t)((char*)ptr+sTHX);
199 /* In particular, must do that fixup above before logging anything via
200 *printf(), as it can reallocate memory, which can cause SEGVs. */
202 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
203 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
210 #ifndef ALWAYS_NEED_THX
222 /* safe version of system's free() */
225 Perl_safesysfree(Malloc_t where)
227 #ifdef ALWAYS_NEED_THX
232 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
234 #ifdef PERL_TRACK_MEMPOOL
235 where = (Malloc_t)((char*)where-sTHX);
237 struct perl_memory_debug_header *const header
238 = (struct perl_memory_debug_header *)where;
240 if (header->interpreter != aTHX) {
241 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
242 header->interpreter, aTHX);
245 Perl_croak_nocontext("panic: duplicate free");
248 Perl_croak_nocontext("panic: bad free, header->next==NULL");
249 if (header->next->prev != header || header->prev->next != header) {
250 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
251 "header=%p, ->prev->next=%p",
252 header->next->prev, header,
255 /* Unlink us from the chain. */
256 header->next->prev = header->prev;
257 header->prev->next = header->next;
259 PoisonNew(where, header->size, char);
261 /* Trigger the duplicate free warning. */
269 /* safe version of system's calloc() */
272 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
274 #ifdef ALWAYS_NEED_THX
278 #if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
279 MEM_SIZE total_size = 0;
282 /* Even though calloc() for zero bytes is strange, be robust. */
283 if (size && (count <= MEM_SIZE_MAX / size)) {
284 #if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
285 total_size = size * count;
290 #ifdef PERL_TRACK_MEMPOOL
291 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
297 if ((SSize_t)size < 0 || (SSize_t)count < 0)
298 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
299 (UV)size, (UV)count);
301 #ifdef PERL_TRACK_MEMPOOL
302 /* Have to use malloc() because we've added some space for our tracking
304 /* malloc(0) is non-portable. */
305 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
307 /* Use calloc() because it might save a memset() if the memory is fresh
308 and clean from the OS. */
310 ptr = (Malloc_t)PerlMem_calloc(count, size);
311 else /* calloc(0) is non-portable. */
312 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
314 PERL_ALLOC_CHECK(ptr);
315 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));
317 #ifdef PERL_TRACK_MEMPOOL
319 struct perl_memory_debug_header *const header
320 = (struct perl_memory_debug_header *)ptr;
322 memset((void*)ptr, 0, total_size);
323 header->interpreter = aTHX;
324 /* Link us into the list. */
325 header->prev = &PL_memory_debug_header;
326 header->next = PL_memory_debug_header.next;
327 PL_memory_debug_header.next = header;
328 header->next->prev = header;
330 header->size = total_size;
332 ptr = (Malloc_t)((char*)ptr+sTHX);
338 #ifndef ALWAYS_NEED_THX
347 /* These must be defined when not using Perl's malloc for binary
352 Malloc_t Perl_malloc (MEM_SIZE nbytes)
355 return (Malloc_t)PerlMem_malloc(nbytes);
358 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
361 return (Malloc_t)PerlMem_calloc(elements, size);
364 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
367 return (Malloc_t)PerlMem_realloc(where, nbytes);
370 Free_t Perl_mfree (Malloc_t where)
378 /* copy a string up to some (non-backslashed) delimiter, if any */
381 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
385 PERL_ARGS_ASSERT_DELIMCPY;
387 for (tolen = 0; from < fromend; from++, tolen++) {
389 if (from[1] != delim) {
396 else if (*from == delim)
407 /* return ptr to little string in big string, NULL if not found */
408 /* This routine was donated by Corey Satten. */
411 Perl_instr(const char *big, const char *little)
414 PERL_ARGS_ASSERT_INSTR;
416 /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
419 return strstr((char*)big, (char*)little);
422 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond
423 * the final character desired to be checked */
426 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
428 PERL_ARGS_ASSERT_NINSTR;
432 const char first = *little;
434 bigend -= lend - little++;
436 while (big <= bigend) {
437 if (*big++ == first) {
438 for (x=big,s=little; s < lend; x++,s++) {
442 return (char*)(big-1);
449 /* reverse of the above--find last substring */
452 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
455 const I32 first = *little;
456 const char * const littleend = lend;
458 PERL_ARGS_ASSERT_RNINSTR;
460 if (little >= littleend)
461 return (char*)bigend;
463 big = bigend - (littleend - little++);
464 while (big >= bigbeg) {
468 for (x=big+2,s=little; s < littleend; /**/ ) {
477 return (char*)(big+1);
482 /* As a space optimization, we do not compile tables for strings of length
483 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
484 special-cased in fbm_instr().
486 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
489 =head1 Miscellaneous Functions
491 =for apidoc fbm_compile
493 Analyses the string in order to make fast searches on it using fbm_instr()
494 -- the Boyer-Moore algorithm.
500 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
508 PERL_DEB( STRLEN rarest = 0 );
510 PERL_ARGS_ASSERT_FBM_COMPILE;
512 if (isGV_with_GP(sv) || SvROK(sv))
518 if (flags & FBMcf_TAIL) {
519 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
520 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
521 if (mg && mg->mg_len >= 0)
524 if (!SvPOK(sv) || SvNIOKp(sv))
525 s = (U8*)SvPV_force_mutable(sv, len);
526 else s = (U8 *)SvPV_mutable(sv, len);
527 if (len == 0) /* TAIL might be on a zero-length string. */
529 SvUPGRADE(sv, SVt_PVMG);
534 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
535 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
536 to call SvVALID_off() if the scalar was assigned to.
538 The comment itself (and "deeper magic" below) date back to
539 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
541 where the magic (presumably) was that the scalar had a BM table hidden
544 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
545 the table instead of the previous (somewhat hacky) approach of co-opting
546 the string buffer and storing it after the string. */
548 assert(!mg_find(sv, PERL_MAGIC_bm));
549 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
553 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
555 const U8 mlen = (len>255) ? 255 : (U8)len;
556 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
559 Newx(table, 256, U8);
560 memset((void*)table, mlen, 256);
561 mg->mg_ptr = (char *)table;
564 s += len - 1; /* last char */
567 if (table[*s] == mlen)
573 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
574 for (i = 0; i < len; i++) {
575 if (PL_freq[s[i]] < frequency) {
576 PERL_DEB( rarest = i );
577 frequency = PL_freq[s[i]];
580 BmUSEFUL(sv) = 100; /* Initial value */
581 if (flags & FBMcf_TAIL)
583 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
584 s[rarest], (UV)rarest));
587 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
588 /* If SvTAIL is actually due to \Z or \z, this gives false positives
592 =for apidoc fbm_instr
594 Returns the location of the SV in the string delimited by C<big> and
595 C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
596 does not have to be fbm_compiled, but the search will not be as fast
603 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
607 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
608 STRLEN littlelen = l;
609 const I32 multiline = flags & FBMrf_MULTILINE;
611 PERL_ARGS_ASSERT_FBM_INSTR;
613 if ((STRLEN)(bigend - big) < littlelen) {
614 if ( SvTAIL(littlestr)
615 && ((STRLEN)(bigend - big) == littlelen - 1)
617 || (*big == *little &&
618 memEQ((char *)big, (char *)little, littlelen - 1))))
623 switch (littlelen) { /* Special cases for 0, 1 and 2 */
625 return (char*)big; /* Cannot be SvTAIL! */
627 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
628 /* Know that bigend != big. */
629 if (bigend[-1] == '\n')
630 return (char *)(bigend - 1);
631 return (char *) bigend;
639 if (SvTAIL(littlestr))
640 return (char *) bigend;
643 if (SvTAIL(littlestr) && !multiline) {
644 if (bigend[-1] == '\n' && bigend[-2] == *little)
645 return (char*)bigend - 2;
646 if (bigend[-1] == *little)
647 return (char*)bigend - 1;
651 /* This should be better than FBM if c1 == c2, and almost
652 as good otherwise: maybe better since we do less indirection.
653 And we save a lot of memory by caching no table. */
654 const unsigned char c1 = little[0];
655 const unsigned char c2 = little[1];
660 while (s <= bigend) {
670 goto check_1char_anchor;
681 goto check_1char_anchor;
684 while (s <= bigend) {
689 goto check_1char_anchor;
698 check_1char_anchor: /* One char and anchor! */
699 if (SvTAIL(littlestr) && (*bigend == *little))
700 return (char *)bigend; /* bigend is already decremented. */
703 break; /* Only lengths 0 1 and 2 have special-case code. */
706 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
707 s = bigend - littlelen;
708 if (s >= big && bigend[-1] == '\n' && *s == *little
709 /* Automatically of length > 2 */
710 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
712 return (char*)s; /* how sweet it is */
715 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
717 return (char*)s + 1; /* how sweet it is */
721 if (!SvVALID(littlestr)) {
722 char * const b = ninstr((char*)big,(char*)bigend,
723 (char*)little, (char*)little + littlelen);
725 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
726 /* Chop \n from littlestr: */
727 s = bigend - littlelen + 1;
729 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
739 if (littlelen > (STRLEN)(bigend - big))
743 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
744 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
745 const unsigned char *oldlittle;
747 --littlelen; /* Last char found by table lookup */
750 little += littlelen; /* last char */
756 if ((tmp = table[*s])) {
757 if ((s += tmp) < bigend)
761 else { /* less expensive than calling strncmp() */
762 unsigned char * const olds = s;
767 if (*--s == *--little)
769 s = olds + 1; /* here we pay the price for failure */
771 if (s < bigend) /* fake up continue to outer loop */
781 && memEQ((char *)(bigend - littlelen),
782 (char *)(oldlittle - littlelen), littlelen) )
783 return (char*)bigend - littlelen;
789 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
792 PERL_ARGS_ASSERT_SCREAMINSTR;
793 PERL_UNUSED_ARG(bigstr);
794 PERL_UNUSED_ARG(littlestr);
795 PERL_UNUSED_ARG(start_shift);
796 PERL_UNUSED_ARG(end_shift);
797 PERL_UNUSED_ARG(old_posp);
798 PERL_UNUSED_ARG(last);
800 /* This function must only ever be called on a scalar with study magic,
801 but those do not happen any more. */
802 Perl_croak(aTHX_ "panic: screaminstr");
809 Returns true if the leading len bytes of the strings s1 and s2 are the same
810 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
811 match themselves and their opposite case counterparts. Non-cased and non-ASCII
812 range bytes match only themselves.
819 Perl_foldEQ(const char *s1, const char *s2, I32 len)
821 const U8 *a = (const U8 *)s1;
822 const U8 *b = (const U8 *)s2;
824 PERL_ARGS_ASSERT_FOLDEQ;
829 if (*a != *b && *a != PL_fold[*b])
836 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
838 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
839 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
840 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
841 * does it check that the strings each have at least 'len' characters */
843 const U8 *a = (const U8 *)s1;
844 const U8 *b = (const U8 *)s2;
846 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
851 if (*a != *b && *a != PL_fold_latin1[*b]) {
860 =for apidoc foldEQ_locale
862 Returns true if the leading len bytes of the strings s1 and s2 are the same
863 case-insensitively in the current locale; false otherwise.
869 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
872 const U8 *a = (const U8 *)s1;
873 const U8 *b = (const U8 *)s2;
875 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
880 if (*a != *b && *a != PL_fold_locale[*b])
887 /* copy a string to a safe spot */
890 =head1 Memory Management
894 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
895 string which is a duplicate of C<pv>. The size of the string is
896 determined by C<strlen()>. The memory allocated for the new string can
897 be freed with the C<Safefree()> function.
899 On some platforms, Windows for example, all allocated memory owned by a thread
900 is deallocated when that thread ends. So if you need that not to happen, you
901 need to use the shared memory functions, such as C<L</savesharedpv>>.
907 Perl_savepv(pTHX_ const char *pv)
914 const STRLEN pvlen = strlen(pv)+1;
915 Newx(newaddr, pvlen, char);
916 return (char*)memcpy(newaddr, pv, pvlen);
920 /* same thing but with a known length */
925 Perl's version of what C<strndup()> would be if it existed. Returns a
926 pointer to a newly allocated string which is a duplicate of the first
927 C<len> bytes from C<pv>, plus a trailing
928 NUL byte. The memory allocated for
929 the new string can be freed with the C<Safefree()> function.
931 On some platforms, Windows for example, all allocated memory owned by a thread
932 is deallocated when that thread ends. So if you need that not to happen, you
933 need to use the shared memory functions, such as C<L</savesharedpvn>>.
939 Perl_savepvn(pTHX_ const char *pv, I32 len)
946 Newx(newaddr,len+1,char);
947 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
949 /* might not be null terminated */
951 return (char *) CopyD(pv,newaddr,len,char);
954 return (char *) ZeroD(newaddr,len+1,char);
959 =for apidoc savesharedpv
961 A version of C<savepv()> which allocates the duplicate string in memory
962 which is shared between threads.
967 Perl_savesharedpv(pTHX_ const char *pv)
974 pvlen = strlen(pv)+1;
975 newaddr = (char*)PerlMemShared_malloc(pvlen);
979 return (char*)memcpy(newaddr, pv, pvlen);
983 =for apidoc savesharedpvn
985 A version of C<savepvn()> which allocates the duplicate string in memory
986 which is shared between threads. (With the specific difference that a NULL
987 pointer is not acceptable)
992 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
994 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
996 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1001 newaddr[len] = '\0';
1002 return (char*)memcpy(newaddr, pv, len);
1006 =for apidoc savesvpv
1008 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1009 the passed in SV using C<SvPV()>
1011 On some platforms, Windows for example, all allocated memory owned by a thread
1012 is deallocated when that thread ends. So if you need that not to happen, you
1013 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1019 Perl_savesvpv(pTHX_ SV *sv)
1022 const char * const pv = SvPV_const(sv, len);
1025 PERL_ARGS_ASSERT_SAVESVPV;
1028 Newx(newaddr,len,char);
1029 return (char *) CopyD(pv,newaddr,len,char);
1033 =for apidoc savesharedsvpv
1035 A version of C<savesharedpv()> which allocates the duplicate string in
1036 memory which is shared between threads.
1042 Perl_savesharedsvpv(pTHX_ SV *sv)
1045 const char * const pv = SvPV_const(sv, len);
1047 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1049 return savesharedpvn(pv, len);
1052 /* the SV for Perl_form() and mess() is not kept in an arena */
1061 if (PL_phase != PERL_PHASE_DESTRUCT)
1062 return newSVpvs_flags("", SVs_TEMP);
1067 /* Create as PVMG now, to avoid any upgrading later */
1069 Newxz(any, 1, XPVMG);
1070 SvFLAGS(sv) = SVt_PVMG;
1071 SvANY(sv) = (void*)any;
1073 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1078 #if defined(PERL_IMPLICIT_CONTEXT)
1080 Perl_form_nocontext(const char* pat, ...)
1085 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1086 va_start(args, pat);
1087 retval = vform(pat, &args);
1091 #endif /* PERL_IMPLICIT_CONTEXT */
1094 =head1 Miscellaneous Functions
1097 Takes a sprintf-style format pattern and conventional
1098 (non-SV) arguments and returns the formatted string.
1100 (char *) Perl_form(pTHX_ const char* pat, ...)
1102 can be used any place a string (char *) is required:
1104 char * s = Perl_form("%d.%d",major,minor);
1106 Uses a single private buffer so if you want to format several strings you
1107 must explicitly copy the earlier strings away (and free the copies when you
1114 Perl_form(pTHX_ const char* pat, ...)
1118 PERL_ARGS_ASSERT_FORM;
1119 va_start(args, pat);
1120 retval = vform(pat, &args);
1126 Perl_vform(pTHX_ const char *pat, va_list *args)
1128 SV * const sv = mess_alloc();
1129 PERL_ARGS_ASSERT_VFORM;
1130 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1135 =for apidoc Am|SV *|mess|const char *pat|...
1137 Take a sprintf-style format pattern and argument list. These are used to
1138 generate a string message. If the message does not end with a newline,
1139 then it will be extended with some indication of the current location
1140 in the code, as described for L</mess_sv>.
1142 Normally, the resulting message is returned in a new mortal SV.
1143 During global destruction a single SV may be shared between uses of
1149 #if defined(PERL_IMPLICIT_CONTEXT)
1151 Perl_mess_nocontext(const char *pat, ...)
1156 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1157 va_start(args, pat);
1158 retval = vmess(pat, &args);
1162 #endif /* PERL_IMPLICIT_CONTEXT */
1165 Perl_mess(pTHX_ const char *pat, ...)
1169 PERL_ARGS_ASSERT_MESS;
1170 va_start(args, pat);
1171 retval = vmess(pat, &args);
1177 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1181 /* Look for curop starting from o. cop is the last COP we've seen. */
1182 /* opnext means that curop is actually the ->op_next of the op we are
1185 PERL_ARGS_ASSERT_CLOSEST_COP;
1187 if (!o || !curop || (
1188 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1192 if (o->op_flags & OPf_KIDS) {
1194 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1197 /* If the OP_NEXTSTATE has been optimised away we can still use it
1198 * the get the file and line number. */
1200 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1201 cop = (const COP *)kid;
1203 /* Keep searching, and return when we've found something. */
1205 new_cop = closest_cop(cop, kid, curop, opnext);
1211 /* Nothing found. */
1217 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1219 Expands a message, intended for the user, to include an indication of
1220 the current location in the code, if the message does not already appear
1223 C<basemsg> is the initial message or object. If it is a reference, it
1224 will be used as-is and will be the result of this function. Otherwise it
1225 is used as a string, and if it already ends with a newline, it is taken
1226 to be complete, and the result of this function will be the same string.
1227 If the message does not end with a newline, then a segment such as C<at
1228 foo.pl line 37> will be appended, and possibly other clauses indicating
1229 the current state of execution. The resulting message will end with a
1232 Normally, the resulting message is returned in a new mortal SV.
1233 During global destruction a single SV may be shared between uses of this
1234 function. If C<consume> is true, then the function is permitted (but not
1235 required) to modify and return C<basemsg> instead of allocating a new SV.
1241 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1246 PERL_ARGS_ASSERT_MESS_SV;
1248 if (SvROK(basemsg)) {
1254 sv_setsv(sv, basemsg);
1259 if (SvPOK(basemsg) && consume) {
1264 sv_copypv(sv, basemsg);
1267 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1269 * Try and find the file and line for PL_op. This will usually be
1270 * PL_curcop, but it might be a cop that has been optimised away. We
1271 * can try to find such a cop by searching through the optree starting
1272 * from the sibling of PL_curcop.
1276 closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
1281 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1282 OutCopFILE(cop), (IV)CopLINE(cop));
1283 /* Seems that GvIO() can be untrustworthy during global destruction. */
1284 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1285 && IoLINES(GvIOp(PL_last_in_gv)))
1288 const bool line_mode = (RsSIMPLE(PL_rs) &&
1289 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1290 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1291 SVfARG(PL_last_in_gv == PL_argvgv
1293 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1294 line_mode ? "line" : "chunk",
1295 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1297 if (PL_phase == PERL_PHASE_DESTRUCT)
1298 sv_catpvs(sv, " during global destruction");
1299 sv_catpvs(sv, ".\n");
1305 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1307 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1308 argument list. These are used to generate a string message. If the
1309 message does not end with a newline, then it will be extended with
1310 some indication of the current location in the code, as described for
1313 Normally, the resulting message is returned in a new mortal SV.
1314 During global destruction a single SV may be shared between uses of
1321 Perl_vmess(pTHX_ const char *pat, va_list *args)
1324 SV * const sv = mess_alloc();
1326 PERL_ARGS_ASSERT_VMESS;
1328 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1329 return mess_sv(sv, 1);
1333 Perl_write_to_stderr(pTHX_ SV* msv)
1339 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1341 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1342 && (io = GvIO(PL_stderrgv))
1343 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1344 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1345 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1347 PerlIO * const serr = Perl_error_log;
1349 do_print(msv, serr);
1350 (void)PerlIO_flush(serr);
1355 =head1 Warning and Dieing
1358 /* Common code used in dieing and warning */
1361 S_with_queued_errors(pTHX_ SV *ex)
1363 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1364 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1365 sv_catsv(PL_errors, ex);
1366 ex = sv_mortalcopy(PL_errors);
1367 SvCUR_set(PL_errors, 0);
1373 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1379 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1380 /* sv_2cv might call Perl_croak() or Perl_warner() */
1381 SV * const oldhook = *hook;
1389 cv = sv_2cv(oldhook, &stash, &gv, 0);
1391 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1401 exarg = newSVsv(ex);
1402 SvREADONLY_on(exarg);
1405 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1409 call_sv(MUTABLE_SV(cv), G_DISCARD);
1418 =for apidoc Am|OP *|die_sv|SV *baseex
1420 Behaves the same as L</croak_sv>, except for the return type.
1421 It should be used only where the C<OP *> return type is required.
1422 The function never actually returns.
1428 Perl_die_sv(pTHX_ SV *baseex)
1430 PERL_ARGS_ASSERT_DIE_SV;
1432 assert(0); /* NOTREACHED */
1437 =for apidoc Am|OP *|die|const char *pat|...
1439 Behaves the same as L</croak>, except for the return type.
1440 It should be used only where the C<OP *> return type is required.
1441 The function never actually returns.
1446 #if defined(PERL_IMPLICIT_CONTEXT)
1448 Perl_die_nocontext(const char* pat, ...)
1452 va_start(args, pat);
1454 assert(0); /* NOTREACHED */
1458 #endif /* PERL_IMPLICIT_CONTEXT */
1461 Perl_die(pTHX_ const char* pat, ...)
1464 va_start(args, pat);
1466 assert(0); /* NOTREACHED */
1472 =for apidoc Am|void|croak_sv|SV *baseex
1474 This is an XS interface to Perl's C<die> function.
1476 C<baseex> is the error message or object. If it is a reference, it
1477 will be used as-is. Otherwise it is used as a string, and if it does
1478 not end with a newline then it will be extended with some indication of
1479 the current location in the code, as described for L</mess_sv>.
1481 The error message or object will be used as an exception, by default
1482 returning control to the nearest enclosing C<eval>, but subject to
1483 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1484 function never returns normally.
1486 To die with a simple string message, the L</croak> function may be
1493 Perl_croak_sv(pTHX_ SV *baseex)
1495 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1496 PERL_ARGS_ASSERT_CROAK_SV;
1497 invoke_exception_hook(ex, FALSE);
1502 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1504 This is an XS interface to Perl's C<die> function.
1506 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1507 argument list. These are used to generate a string message. If the
1508 message does not end with a newline, then it will be extended with
1509 some indication of the current location in the code, as described for
1512 The error message will be used as an exception, by default
1513 returning control to the nearest enclosing C<eval>, but subject to
1514 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1515 function never returns normally.
1517 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1518 (C<$@>) will be used as an error message or object instead of building an
1519 error message from arguments. If you want to throw a non-string object,
1520 or build an error message in an SV yourself, it is preferable to use
1521 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1527 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1529 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1530 invoke_exception_hook(ex, FALSE);
1535 =for apidoc Am|void|croak|const char *pat|...
1537 This is an XS interface to Perl's C<die> function.
1539 Take a sprintf-style format pattern and argument list. These are used to
1540 generate a string message. If the message does not end with a newline,
1541 then it will be extended with some indication of the current location
1542 in the code, as described for L</mess_sv>.
1544 The error message will be used as an exception, by default
1545 returning control to the nearest enclosing C<eval>, but subject to
1546 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1547 function never returns normally.
1549 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1550 (C<$@>) will be used as an error message or object instead of building an
1551 error message from arguments. If you want to throw a non-string object,
1552 or build an error message in an SV yourself, it is preferable to use
1553 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1558 #if defined(PERL_IMPLICIT_CONTEXT)
1560 Perl_croak_nocontext(const char *pat, ...)
1564 va_start(args, pat);
1566 assert(0); /* NOTREACHED */
1569 #endif /* PERL_IMPLICIT_CONTEXT */
1572 Perl_croak(pTHX_ const char *pat, ...)
1575 va_start(args, pat);
1577 assert(0); /* NOTREACHED */
1582 =for apidoc Am|void|croak_no_modify
1584 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1585 terser object code than using C<Perl_croak>. Less code used on exception code
1586 paths reduces CPU cache pressure.
1592 Perl_croak_no_modify()
1594 Perl_croak_nocontext( "%s", PL_no_modify);
1597 /* does not return, used in util.c perlio.c and win32.c
1598 This is typically called when malloc returns NULL.
1606 /* Can't use PerlIO to write as it allocates memory */
1607 rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
1608 PL_no_mem, sizeof(PL_no_mem)-1);
1609 /* silently ignore failures */
1610 PERL_UNUSED_VAR(rc);
1614 /* does not return, used only in POPSTACK */
1616 Perl_croak_popstack(void)
1619 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1624 =for apidoc Am|void|warn_sv|SV *baseex
1626 This is an XS interface to Perl's C<warn> function.
1628 C<baseex> is the error message or object. If it is a reference, it
1629 will be used as-is. Otherwise it is used as a string, and if it does
1630 not end with a newline then it will be extended with some indication of
1631 the current location in the code, as described for L</mess_sv>.
1633 The error message or object will by default be written to standard error,
1634 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1636 To warn with a simple string message, the L</warn> function may be
1643 Perl_warn_sv(pTHX_ SV *baseex)
1645 SV *ex = mess_sv(baseex, 0);
1646 PERL_ARGS_ASSERT_WARN_SV;
1647 if (!invoke_exception_hook(ex, TRUE))
1648 write_to_stderr(ex);
1652 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1654 This is an XS interface to Perl's C<warn> function.
1656 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1657 argument list. These are used to generate a string message. If the
1658 message does not end with a newline, then it will be extended with
1659 some indication of the current location in the code, as described for
1662 The error message or object will by default be written to standard error,
1663 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1665 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1671 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1673 SV *ex = vmess(pat, args);
1674 PERL_ARGS_ASSERT_VWARN;
1675 if (!invoke_exception_hook(ex, TRUE))
1676 write_to_stderr(ex);
1680 =for apidoc Am|void|warn|const char *pat|...
1682 This is an XS interface to Perl's C<warn> function.
1684 Take a sprintf-style format pattern and argument list. These are used to
1685 generate a string message. If the message does not end with a newline,
1686 then it will be extended with some indication of the current location
1687 in the code, as described for L</mess_sv>.
1689 The error message or object will by default be written to standard error,
1690 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1692 Unlike with L</croak>, C<pat> is not permitted to be null.
1697 #if defined(PERL_IMPLICIT_CONTEXT)
1699 Perl_warn_nocontext(const char *pat, ...)
1703 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1704 va_start(args, pat);
1708 #endif /* PERL_IMPLICIT_CONTEXT */
1711 Perl_warn(pTHX_ const char *pat, ...)
1714 PERL_ARGS_ASSERT_WARN;
1715 va_start(args, pat);
1720 #if defined(PERL_IMPLICIT_CONTEXT)
1722 Perl_warner_nocontext(U32 err, const char *pat, ...)
1726 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1727 va_start(args, pat);
1728 vwarner(err, pat, &args);
1731 #endif /* PERL_IMPLICIT_CONTEXT */
1734 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1736 PERL_ARGS_ASSERT_CK_WARNER_D;
1738 if (Perl_ckwarn_d(aTHX_ err)) {
1740 va_start(args, pat);
1741 vwarner(err, pat, &args);
1747 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1749 PERL_ARGS_ASSERT_CK_WARNER;
1751 if (Perl_ckwarn(aTHX_ err)) {
1753 va_start(args, pat);
1754 vwarner(err, pat, &args);
1760 Perl_warner(pTHX_ U32 err, const char* pat,...)
1763 PERL_ARGS_ASSERT_WARNER;
1764 va_start(args, pat);
1765 vwarner(err, pat, &args);
1770 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1773 PERL_ARGS_ASSERT_VWARNER;
1774 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1775 SV * const msv = vmess(pat, args);
1777 invoke_exception_hook(msv, FALSE);
1781 Perl_vwarn(aTHX_ pat, args);
1785 /* implements the ckWARN? macros */
1788 Perl_ckwarn(pTHX_ U32 w)
1791 /* If lexical warnings have not been set, use $^W. */
1793 return PL_dowarn & G_WARN_ON;
1795 return ckwarn_common(w);
1798 /* implements the ckWARN?_d macro */
1801 Perl_ckwarn_d(pTHX_ U32 w)
1804 /* If lexical warnings have not been set then default classes warn. */
1808 return ckwarn_common(w);
1812 S_ckwarn_common(pTHX_ U32 w)
1814 if (PL_curcop->cop_warnings == pWARN_ALL)
1817 if (PL_curcop->cop_warnings == pWARN_NONE)
1820 /* Check the assumption that at least the first slot is non-zero. */
1821 assert(unpackWARN1(w));
1823 /* Check the assumption that it is valid to stop as soon as a zero slot is
1825 if (!unpackWARN2(w)) {
1826 assert(!unpackWARN3(w));
1827 assert(!unpackWARN4(w));
1828 } else if (!unpackWARN3(w)) {
1829 assert(!unpackWARN4(w));
1832 /* Right, dealt with all the special cases, which are implemented as non-
1833 pointers, so there is a pointer to a real warnings mask. */
1835 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1837 } while (w >>= WARNshift);
1842 /* Set buffer=NULL to get a new one. */
1844 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1846 const MEM_SIZE len_wanted =
1847 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1848 PERL_UNUSED_CONTEXT;
1849 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1852 (specialWARN(buffer) ?
1853 PerlMemShared_malloc(len_wanted) :
1854 PerlMemShared_realloc(buffer, len_wanted));
1856 Copy(bits, (buffer + 1), size, char);
1857 if (size < WARNsize)
1858 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1862 /* since we've already done strlen() for both nam and val
1863 * we can use that info to make things faster than
1864 * sprintf(s, "%s=%s", nam, val)
1866 #define my_setenv_format(s, nam, nlen, val, vlen) \
1867 Copy(nam, s, nlen, char); \
1869 Copy(val, s+(nlen+1), vlen, char); \
1870 *(s+(nlen+1+vlen)) = '\0'
1872 #ifdef USE_ENVIRON_ARRAY
1873 /* VMS' my_setenv() is in vms.c */
1874 #if !defined(WIN32) && !defined(NETWARE)
1876 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1880 /* only parent thread can modify process environment */
1881 if (PL_curinterp == aTHX)
1884 #ifndef PERL_USE_SAFE_PUTENV
1885 if (!PL_use_safe_putenv) {
1886 /* most putenv()s leak, so we manipulate environ directly */
1888 const I32 len = strlen(nam);
1891 /* where does it go? */
1892 for (i = 0; environ[i]; i++) {
1893 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1897 if (environ == PL_origenviron) { /* need we copy environment? */
1903 while (environ[max])
1905 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1906 for (j=0; j<max; j++) { /* copy environment */
1907 const int len = strlen(environ[j]);
1908 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1909 Copy(environ[j], tmpenv[j], len+1, char);
1912 environ = tmpenv; /* tell exec where it is now */
1915 safesysfree(environ[i]);
1916 while (environ[i]) {
1917 environ[i] = environ[i+1];
1922 if (!environ[i]) { /* does not exist yet */
1923 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1924 environ[i+1] = NULL; /* make sure it's null terminated */
1927 safesysfree(environ[i]);
1931 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1932 /* all that work just for this */
1933 my_setenv_format(environ[i], nam, nlen, val, vlen);
1936 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
1937 # if defined(HAS_UNSETENV)
1939 (void)unsetenv(nam);
1941 (void)setenv(nam, val, 1);
1943 # else /* ! HAS_UNSETENV */
1944 (void)setenv(nam, val, 1);
1945 # endif /* HAS_UNSETENV */
1947 # if defined(HAS_UNSETENV)
1949 if (environ) /* old glibc can crash with null environ */
1950 (void)unsetenv(nam);
1952 const int nlen = strlen(nam);
1953 const int vlen = strlen(val);
1954 char * const new_env =
1955 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1956 my_setenv_format(new_env, nam, nlen, val, vlen);
1957 (void)putenv(new_env);
1959 # else /* ! HAS_UNSETENV */
1961 const int nlen = strlen(nam);
1967 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1968 /* all that work just for this */
1969 my_setenv_format(new_env, nam, nlen, val, vlen);
1970 (void)putenv(new_env);
1971 # endif /* HAS_UNSETENV */
1972 # endif /* __CYGWIN__ */
1973 #ifndef PERL_USE_SAFE_PUTENV
1979 #else /* WIN32 || NETWARE */
1982 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1986 const int nlen = strlen(nam);
1993 Newx(envstr, nlen+vlen+2, char);
1994 my_setenv_format(envstr, nam, nlen, val, vlen);
1995 (void)PerlEnv_putenv(envstr);
1999 #endif /* WIN32 || NETWARE */
2003 #ifdef UNLINK_ALL_VERSIONS
2005 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2009 PERL_ARGS_ASSERT_UNLNK;
2011 while (PerlLIO_unlink(f) >= 0)
2013 return retries ? 0 : -1;
2017 /* this is a drop-in replacement for bcopy() */
2018 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2020 Perl_my_bcopy(const char *from, char *to, I32 len)
2022 char * const retval = to;
2024 PERL_ARGS_ASSERT_MY_BCOPY;
2028 if (from - to >= 0) {
2036 *(--to) = *(--from);
2042 /* this is a drop-in replacement for memset() */
2045 Perl_my_memset(char *loc, I32 ch, I32 len)
2047 char * const retval = loc;
2049 PERL_ARGS_ASSERT_MY_MEMSET;
2059 /* this is a drop-in replacement for bzero() */
2060 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2062 Perl_my_bzero(char *loc, I32 len)
2064 char * const retval = loc;
2066 PERL_ARGS_ASSERT_MY_BZERO;
2076 /* this is a drop-in replacement for memcmp() */
2077 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2079 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2081 const U8 *a = (const U8 *)s1;
2082 const U8 *b = (const U8 *)s2;
2085 PERL_ARGS_ASSERT_MY_MEMCMP;
2090 if ((tmp = *a++ - *b++))
2095 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2098 /* This vsprintf replacement should generally never get used, since
2099 vsprintf was available in both System V and BSD 2.11. (There may
2100 be some cross-compilation or embedded set-ups where it is needed,
2103 If you encounter a problem in this function, it's probably a symptom
2104 that Configure failed to detect your system's vprintf() function.
2105 See the section on "item vsprintf" in the INSTALL file.
2107 This version may compile on systems with BSD-ish <stdio.h>,
2108 but probably won't on others.
2111 #ifdef USE_CHAR_VSPRINTF
2116 vsprintf(char *dest, const char *pat, void *args)
2120 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2121 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2122 FILE_cnt(&fakebuf) = 32767;
2124 /* These probably won't compile -- If you really need
2125 this, you'll have to figure out some other method. */
2126 fakebuf._ptr = dest;
2127 fakebuf._cnt = 32767;
2132 fakebuf._flag = _IOWRT|_IOSTRG;
2133 _doprnt(pat, args, &fakebuf); /* what a kludge */
2134 #if defined(STDIO_PTR_LVALUE)
2135 *(FILE_ptr(&fakebuf)++) = '\0';
2137 /* PerlIO has probably #defined away fputc, but we want it here. */
2139 # undef fputc /* XXX Should really restore it later */
2141 (void)fputc('\0', &fakebuf);
2143 #ifdef USE_CHAR_VSPRINTF
2146 return 0; /* perl doesn't use return value */
2150 #endif /* HAS_VPRINTF */
2153 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2155 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2164 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2166 PERL_FLUSHALL_FOR_CHILD;
2167 This = (*mode == 'w');
2171 taint_proper("Insecure %s%s", "EXEC");
2173 if (PerlProc_pipe(p) < 0)
2175 /* Try for another pipe pair for error return */
2176 if (PerlProc_pipe(pp) >= 0)
2178 while ((pid = PerlProc_fork()) < 0) {
2179 if (errno != EAGAIN) {
2180 PerlLIO_close(p[This]);
2181 PerlLIO_close(p[that]);
2183 PerlLIO_close(pp[0]);
2184 PerlLIO_close(pp[1]);
2188 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2197 /* Close parent's end of error status pipe (if any) */
2199 PerlLIO_close(pp[0]);
2200 #if defined(HAS_FCNTL) && defined(F_SETFD)
2201 /* Close error pipe automatically if exec works */
2202 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2205 /* Now dup our end of _the_ pipe to right position */
2206 if (p[THIS] != (*mode == 'r')) {
2207 PerlLIO_dup2(p[THIS], *mode == 'r');
2208 PerlLIO_close(p[THIS]);
2209 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2210 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2213 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2214 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2215 /* No automatic close - do it by hand */
2222 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2228 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2234 do_execfree(); /* free any memory malloced by child on fork */
2236 PerlLIO_close(pp[1]);
2237 /* Keep the lower of the two fd numbers */
2238 if (p[that] < p[This]) {
2239 PerlLIO_dup2(p[This], p[that]);
2240 PerlLIO_close(p[This]);
2244 PerlLIO_close(p[that]); /* close child's end of pipe */
2246 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2247 SvUPGRADE(sv,SVt_IV);
2249 PL_forkprocess = pid;
2250 /* If we managed to get status pipe check for exec fail */
2251 if (did_pipes && pid > 0) {
2256 while (n < sizeof(int)) {
2257 n1 = PerlLIO_read(pp[0],
2258 (void*)(((char*)&errkid)+n),
2264 PerlLIO_close(pp[0]);
2266 if (n) { /* Error */
2268 PerlLIO_close(p[This]);
2269 if (n != sizeof(int))
2270 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2272 pid2 = wait4pid(pid, &status, 0);
2273 } while (pid2 == -1 && errno == EINTR);
2274 errno = errkid; /* Propagate errno from kid */
2279 PerlLIO_close(pp[0]);
2280 return PerlIO_fdopen(p[This], mode);
2282 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2283 return my_syspopen4(aTHX_ NULL, mode, n, args);
2285 Perl_croak(aTHX_ "List form of piped open not implemented");
2286 return (PerlIO *) NULL;
2291 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2292 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2294 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2301 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2305 PERL_ARGS_ASSERT_MY_POPEN;
2307 PERL_FLUSHALL_FOR_CHILD;
2310 return my_syspopen(aTHX_ cmd,mode);
2313 This = (*mode == 'w');
2315 if (doexec && TAINTING_get) {
2317 taint_proper("Insecure %s%s", "EXEC");
2319 if (PerlProc_pipe(p) < 0)
2321 if (doexec && PerlProc_pipe(pp) >= 0)
2323 while ((pid = PerlProc_fork()) < 0) {
2324 if (errno != EAGAIN) {
2325 PerlLIO_close(p[This]);
2326 PerlLIO_close(p[that]);
2328 PerlLIO_close(pp[0]);
2329 PerlLIO_close(pp[1]);
2332 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2335 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2345 PerlLIO_close(pp[0]);
2346 #if defined(HAS_FCNTL) && defined(F_SETFD)
2347 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2350 if (p[THIS] != (*mode == 'r')) {
2351 PerlLIO_dup2(p[THIS], *mode == 'r');
2352 PerlLIO_close(p[THIS]);
2353 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2354 PerlLIO_close(p[THAT]);
2357 PerlLIO_close(p[THAT]);
2360 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2367 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2372 /* may or may not use the shell */
2373 do_exec3(cmd, pp[1], did_pipes);
2376 #endif /* defined OS2 */
2378 #ifdef PERLIO_USING_CRLF
2379 /* Since we circumvent IO layers when we manipulate low-level
2380 filedescriptors directly, need to manually switch to the
2381 default, binary, low-level mode; see PerlIOBuf_open(). */
2382 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2385 #ifdef PERL_USES_PL_PIDSTATUS
2386 hv_clear(PL_pidstatus); /* we have no children */
2392 do_execfree(); /* free any memory malloced by child on vfork */
2394 PerlLIO_close(pp[1]);
2395 if (p[that] < p[This]) {
2396 PerlLIO_dup2(p[This], p[that]);
2397 PerlLIO_close(p[This]);
2401 PerlLIO_close(p[that]);
2403 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2404 SvUPGRADE(sv,SVt_IV);
2406 PL_forkprocess = pid;
2407 if (did_pipes && pid > 0) {
2412 while (n < sizeof(int)) {
2413 n1 = PerlLIO_read(pp[0],
2414 (void*)(((char*)&errkid)+n),
2420 PerlLIO_close(pp[0]);
2422 if (n) { /* Error */
2424 PerlLIO_close(p[This]);
2425 if (n != sizeof(int))
2426 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2428 pid2 = wait4pid(pid, &status, 0);
2429 } while (pid2 == -1 && errno == EINTR);
2430 errno = errkid; /* Propagate errno from kid */
2435 PerlLIO_close(pp[0]);
2436 return PerlIO_fdopen(p[This], mode);
2440 FILE *djgpp_popen();
2442 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2444 PERL_FLUSHALL_FOR_CHILD;
2445 /* Call system's popen() to get a FILE *, then import it.
2446 used 0 for 2nd parameter to PerlIO_importFILE;
2449 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2452 #if defined(__LIBCATAMOUNT__)
2454 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2461 #endif /* !DOSISH */
2463 /* this is called in parent before the fork() */
2465 Perl_atfork_lock(void)
2468 #if defined(USE_ITHREADS)
2469 /* locks must be held in locking order (if any) */
2471 MUTEX_LOCK(&PL_perlio_mutex);
2474 MUTEX_LOCK(&PL_malloc_mutex);
2480 /* this is called in both parent and child after the fork() */
2482 Perl_atfork_unlock(void)
2485 #if defined(USE_ITHREADS)
2486 /* locks must be released in same order as in atfork_lock() */
2488 MUTEX_UNLOCK(&PL_perlio_mutex);
2491 MUTEX_UNLOCK(&PL_malloc_mutex);
2500 #if defined(HAS_FORK)
2502 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2507 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2508 * handlers elsewhere in the code */
2513 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2514 Perl_croak_nocontext("fork() not available");
2516 #endif /* HAS_FORK */
2521 dup2(int oldfd, int newfd)
2523 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2526 PerlLIO_close(newfd);
2527 return fcntl(oldfd, F_DUPFD, newfd);
2529 #define DUP2_MAX_FDS 256
2530 int fdtmp[DUP2_MAX_FDS];
2536 PerlLIO_close(newfd);
2537 /* good enough for low fd's... */
2538 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2539 if (fdx >= DUP2_MAX_FDS) {
2547 PerlLIO_close(fdtmp[--fdx]);
2554 #ifdef HAS_SIGACTION
2557 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2560 struct sigaction act, oact;
2563 /* only "parent" interpreter can diddle signals */
2564 if (PL_curinterp != aTHX)
2565 return (Sighandler_t) SIG_ERR;
2568 act.sa_handler = (void(*)(int))handler;
2569 sigemptyset(&act.sa_mask);
2572 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2573 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2575 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2576 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2577 act.sa_flags |= SA_NOCLDWAIT;
2579 if (sigaction(signo, &act, &oact) == -1)
2580 return (Sighandler_t) SIG_ERR;
2582 return (Sighandler_t) oact.sa_handler;
2586 Perl_rsignal_state(pTHX_ int signo)
2588 struct sigaction oact;
2589 PERL_UNUSED_CONTEXT;
2591 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2592 return (Sighandler_t) SIG_ERR;
2594 return (Sighandler_t) oact.sa_handler;
2598 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2601 struct sigaction act;
2603 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2606 /* only "parent" interpreter can diddle signals */
2607 if (PL_curinterp != aTHX)
2611 act.sa_handler = (void(*)(int))handler;
2612 sigemptyset(&act.sa_mask);
2615 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2616 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2618 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2619 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2620 act.sa_flags |= SA_NOCLDWAIT;
2622 return sigaction(signo, &act, save);
2626 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2630 /* only "parent" interpreter can diddle signals */
2631 if (PL_curinterp != aTHX)
2635 return sigaction(signo, save, (struct sigaction *)NULL);
2638 #else /* !HAS_SIGACTION */
2641 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2643 #if defined(USE_ITHREADS) && !defined(WIN32)
2644 /* only "parent" interpreter can diddle signals */
2645 if (PL_curinterp != aTHX)
2646 return (Sighandler_t) SIG_ERR;
2649 return PerlProc_signal(signo, handler);
2660 Perl_rsignal_state(pTHX_ int signo)
2663 Sighandler_t oldsig;
2665 #if defined(USE_ITHREADS) && !defined(WIN32)
2666 /* only "parent" interpreter can diddle signals */
2667 if (PL_curinterp != aTHX)
2668 return (Sighandler_t) SIG_ERR;
2672 oldsig = PerlProc_signal(signo, sig_trap);
2673 PerlProc_signal(signo, oldsig);
2675 PerlProc_kill(PerlProc_getpid(), signo);
2680 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2682 #if defined(USE_ITHREADS) && !defined(WIN32)
2683 /* only "parent" interpreter can diddle signals */
2684 if (PL_curinterp != aTHX)
2687 *save = PerlProc_signal(signo, handler);
2688 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2692 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2694 #if defined(USE_ITHREADS) && !defined(WIN32)
2695 /* only "parent" interpreter can diddle signals */
2696 if (PL_curinterp != aTHX)
2699 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2702 #endif /* !HAS_SIGACTION */
2703 #endif /* !PERL_MICRO */
2705 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2706 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2708 Perl_my_pclose(pTHX_ PerlIO *ptr)
2717 const int fd = PerlIO_fileno(ptr);
2720 svp = av_fetch(PL_fdpid,fd,TRUE);
2721 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2725 #if defined(USE_PERLIO)
2726 /* Find out whether the refcount is low enough for us to wait for the
2727 child proc without blocking. */
2728 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2730 should_wait = pid > 0;
2734 if (pid == -1) { /* Opened by popen. */
2735 return my_syspclose(ptr);
2738 close_failed = (PerlIO_close(ptr) == EOF);
2740 if (should_wait) do {
2741 pid2 = wait4pid(pid, &status, 0);
2742 } while (pid2 == -1 && errno == EINTR);
2749 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2754 #if defined(__LIBCATAMOUNT__)
2756 Perl_my_pclose(pTHX_ PerlIO *ptr)
2761 #endif /* !DOSISH */
2763 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2765 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2769 PERL_ARGS_ASSERT_WAIT4PID;
2770 #ifdef PERL_USES_PL_PIDSTATUS
2772 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2773 waitpid() nor wait4() is available, or on OS/2, which
2774 doesn't appear to support waiting for a progress group
2775 member, so we can only treat a 0 pid as an unknown child.
2782 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2783 pid, rather than a string form. */
2784 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2785 if (svp && *svp != &PL_sv_undef) {
2786 *statusp = SvIVX(*svp);
2787 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2795 hv_iterinit(PL_pidstatus);
2796 if ((entry = hv_iternext(PL_pidstatus))) {
2797 SV * const sv = hv_iterval(PL_pidstatus,entry);
2799 const char * const spid = hv_iterkey(entry,&len);
2801 assert (len == sizeof(Pid_t));
2802 memcpy((char *)&pid, spid, len);
2803 *statusp = SvIVX(sv);
2804 /* The hash iterator is currently on this entry, so simply
2805 calling hv_delete would trigger the lazy delete, which on
2806 aggregate does more work, beacuse next call to hv_iterinit()
2807 would spot the flag, and have to call the delete routine,
2808 while in the meantime any new entries can't re-use that
2810 hv_iterinit(PL_pidstatus);
2811 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2818 # ifdef HAS_WAITPID_RUNTIME
2819 if (!HAS_WAITPID_RUNTIME)
2822 result = PerlProc_waitpid(pid,statusp,flags);
2825 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2826 result = wait4(pid,statusp,flags,NULL);
2829 #ifdef PERL_USES_PL_PIDSTATUS
2830 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2835 Perl_croak(aTHX_ "Can't do waitpid with flags");
2837 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2838 pidgone(result,*statusp);
2844 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2847 if (result < 0 && errno == EINTR) {
2849 errno = EINTR; /* reset in case a signal handler changed $! */
2853 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2855 #ifdef PERL_USES_PL_PIDSTATUS
2857 S_pidgone(pTHX_ Pid_t pid, int status)
2861 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2862 SvUPGRADE(sv,SVt_IV);
2863 SvIV_set(sv, status);
2871 int /* Cannot prototype with I32
2873 my_syspclose(PerlIO *ptr)
2876 Perl_my_pclose(pTHX_ PerlIO *ptr)
2879 /* Needs work for PerlIO ! */
2880 FILE * const f = PerlIO_findFILE(ptr);
2881 const I32 result = pclose(f);
2882 PerlIO_releaseFILE(ptr,f);
2890 Perl_my_pclose(pTHX_ PerlIO *ptr)
2892 /* Needs work for PerlIO ! */
2893 FILE * const f = PerlIO_findFILE(ptr);
2894 I32 result = djgpp_pclose(f);
2895 result = (result << 8) & 0xff00;
2896 PerlIO_releaseFILE(ptr,f);
2901 #define PERL_REPEATCPY_LINEAR 4
2903 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2905 PERL_ARGS_ASSERT_REPEATCPY;
2910 croak_memory_wrap();
2913 memset(to, *from, count);
2916 IV items, linear, half;
2918 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2919 for (items = 0; items < linear; ++items) {
2920 const char *q = from;
2922 for (todo = len; todo > 0; todo--)
2927 while (items <= half) {
2928 IV size = items * len;
2929 memcpy(p, to, size);
2935 memcpy(p, to, (count - items) * len);
2941 Perl_same_dirent(pTHX_ const char *a, const char *b)
2943 char *fa = strrchr(a,'/');
2944 char *fb = strrchr(b,'/');
2947 SV * const tmpsv = sv_newmortal();
2949 PERL_ARGS_ASSERT_SAME_DIRENT;
2962 sv_setpvs(tmpsv, ".");
2964 sv_setpvn(tmpsv, a, fa - a);
2965 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2968 sv_setpvs(tmpsv, ".");
2970 sv_setpvn(tmpsv, b, fb - b);
2971 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2973 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2974 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2976 #endif /* !HAS_RENAME */
2979 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2980 const char *const *const search_ext, I32 flags)
2983 const char *xfound = NULL;
2984 char *xfailed = NULL;
2985 char tmpbuf[MAXPATHLEN];
2990 #if defined(DOSISH) && !defined(OS2)
2991 # define SEARCH_EXTS ".bat", ".cmd", NULL
2992 # define MAX_EXT_LEN 4
2995 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2996 # define MAX_EXT_LEN 4
2999 # define SEARCH_EXTS ".pl", ".com", NULL
3000 # define MAX_EXT_LEN 4
3002 /* additional extensions to try in each dir if scriptname not found */
3004 static const char *const exts[] = { SEARCH_EXTS };
3005 const char *const *const ext = search_ext ? search_ext : exts;
3006 int extidx = 0, i = 0;
3007 const char *curext = NULL;
3009 PERL_UNUSED_ARG(search_ext);
3010 # define MAX_EXT_LEN 0
3013 PERL_ARGS_ASSERT_FIND_SCRIPT;
3016 * If dosearch is true and if scriptname does not contain path
3017 * delimiters, search the PATH for scriptname.
3019 * If SEARCH_EXTS is also defined, will look for each
3020 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3021 * while searching the PATH.
3023 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3024 * proceeds as follows:
3025 * If DOSISH or VMSISH:
3026 * + look for ./scriptname{,.foo,.bar}
3027 * + search the PATH for scriptname{,.foo,.bar}
3030 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3031 * this will not look in '.' if it's not in the PATH)
3036 # ifdef ALWAYS_DEFTYPES
3037 len = strlen(scriptname);
3038 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3039 int idx = 0, deftypes = 1;
3042 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3045 int idx = 0, deftypes = 1;
3048 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3050 /* The first time through, just add SEARCH_EXTS to whatever we
3051 * already have, so we can check for default file types. */
3053 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3059 if ((strlen(tmpbuf) + strlen(scriptname)
3060 + MAX_EXT_LEN) >= sizeof tmpbuf)
3061 continue; /* don't search dir with too-long name */
3062 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3066 if (strEQ(scriptname, "-"))
3068 if (dosearch) { /* Look in '.' first. */
3069 const char *cur = scriptname;
3071 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3073 if (strEQ(ext[i++],curext)) {
3074 extidx = -1; /* already has an ext */
3079 DEBUG_p(PerlIO_printf(Perl_debug_log,
3080 "Looking for %s\n",cur));
3081 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3082 && !S_ISDIR(PL_statbuf.st_mode)) {
3090 if (cur == scriptname) {
3091 len = strlen(scriptname);
3092 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3094 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3097 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3098 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3103 if (dosearch && !strchr(scriptname, '/')
3105 && !strchr(scriptname, '\\')
3107 && (s = PerlEnv_getenv("PATH")))
3111 bufend = s + strlen(s);
3112 while (s < bufend) {
3115 && *s != ';'; len++, s++) {
3116 if (len < sizeof tmpbuf)
3119 if (len < sizeof tmpbuf)
3122 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3128 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3129 continue; /* don't search dir with too-long name */
3132 && tmpbuf[len - 1] != '/'
3133 && tmpbuf[len - 1] != '\\'
3136 tmpbuf[len++] = '/';
3137 if (len == 2 && tmpbuf[0] == '.')
3139 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3143 len = strlen(tmpbuf);
3144 if (extidx > 0) /* reset after previous loop */
3148 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3149 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3150 if (S_ISDIR(PL_statbuf.st_mode)) {
3154 } while ( retval < 0 /* not there */
3155 && extidx>=0 && ext[extidx] /* try an extension? */
3156 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3161 if (S_ISREG(PL_statbuf.st_mode)
3162 && cando(S_IRUSR,TRUE,&PL_statbuf)
3163 #if !defined(DOSISH)
3164 && cando(S_IXUSR,TRUE,&PL_statbuf)
3168 xfound = tmpbuf; /* bingo! */
3172 xfailed = savepv(tmpbuf);
3175 if (!xfound && !seen_dot && !xfailed &&
3176 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3177 || S_ISDIR(PL_statbuf.st_mode)))
3179 seen_dot = 1; /* Disable message. */
3181 if (flags & 1) { /* do or die? */
3182 /* diag_listed_as: Can't execute %s */
3183 Perl_croak(aTHX_ "Can't %s %s%s%s",
3184 (xfailed ? "execute" : "find"),
3185 (xfailed ? xfailed : scriptname),
3186 (xfailed ? "" : " on PATH"),
3187 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3192 scriptname = xfound;
3194 return (scriptname ? savepv(scriptname) : NULL);
3197 #ifndef PERL_GET_CONTEXT_DEFINED
3200 Perl_get_context(void)
3203 #if defined(USE_ITHREADS)
3204 # ifdef OLD_PTHREADS_API
3206 int error = pthread_getspecific(PL_thr_key, &t)
3208 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3211 # ifdef I_MACH_CTHREADS
3212 return (void*)cthread_data(cthread_self());
3214 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3223 Perl_set_context(void *t)
3226 PERL_ARGS_ASSERT_SET_CONTEXT;
3227 #if defined(USE_ITHREADS)
3228 # ifdef I_MACH_CTHREADS
3229 cthread_set_data(cthread_self(), t);
3232 const int error = pthread_setspecific(PL_thr_key, t);
3234 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3242 #endif /* !PERL_GET_CONTEXT_DEFINED */
3244 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3253 Perl_get_op_names(pTHX)
3255 PERL_UNUSED_CONTEXT;
3256 return (char **)PL_op_name;
3260 Perl_get_op_descs(pTHX)
3262 PERL_UNUSED_CONTEXT;
3263 return (char **)PL_op_desc;
3267 Perl_get_no_modify(pTHX)
3269 PERL_UNUSED_CONTEXT;
3270 return PL_no_modify;
3274 Perl_get_opargs(pTHX)
3276 PERL_UNUSED_CONTEXT;
3277 return (U32 *)PL_opargs;
3281 Perl_get_ppaddr(pTHX)
3284 PERL_UNUSED_CONTEXT;
3285 return (PPADDR_t*)PL_ppaddr;
3288 #ifndef HAS_GETENV_LEN
3290 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3292 char * const env_trans = PerlEnv_getenv(env_elem);
3293 PERL_UNUSED_CONTEXT;
3294 PERL_ARGS_ASSERT_GETENV_LEN;
3296 *len = strlen(env_trans);
3303 Perl_get_vtbl(pTHX_ int vtbl_id)
3305 PERL_UNUSED_CONTEXT;
3307 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3308 ? NULL : PL_magic_vtables + vtbl_id;
3312 Perl_my_fflush_all(pTHX)
3314 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3315 return PerlIO_flush(NULL);
3317 # if defined(HAS__FWALK)
3318 extern int fflush(FILE *);
3319 /* undocumented, unprototyped, but very useful BSDism */
3320 extern void _fwalk(int (*)(FILE *));
3324 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3326 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3327 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3329 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3330 open_max = sysconf(_SC_OPEN_MAX);
3333 open_max = FOPEN_MAX;
3336 open_max = OPEN_MAX;
3347 for (i = 0; i < open_max; i++)
3348 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3349 STDIO_STREAM_ARRAY[i]._file < open_max &&
3350 STDIO_STREAM_ARRAY[i]._flag)
3351 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3355 SETERRNO(EBADF,RMS_IFI);
3362 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3364 if (ckWARN(WARN_IO)) {
3366 = gv && (isGV_with_GP(gv))
3369 const char * const direction = have == '>' ? "out" : "in";
3371 if (name && HEK_LEN(name))
3372 Perl_warner(aTHX_ packWARN(WARN_IO),
3373 "Filehandle %"HEKf" opened only for %sput",
3376 Perl_warner(aTHX_ packWARN(WARN_IO),
3377 "Filehandle opened only for %sput", direction);
3382 Perl_report_evil_fh(pTHX_ const GV *gv)
3384 const IO *io = gv ? GvIO(gv) : NULL;
3385 const PERL_BITFIELD16 op = PL_op->op_type;
3389 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3391 warn_type = WARN_CLOSED;
3395 warn_type = WARN_UNOPENED;
3398 if (ckWARN(warn_type)) {
3400 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3401 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3402 const char * const pars =
3403 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3404 const char * const func =
3406 (op == OP_READLINE || op == OP_RCATLINE
3407 ? "readline" : /* "<HANDLE>" not nice */
3408 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3410 const char * const type =
3412 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3413 ? "socket" : "filehandle");
3414 const bool have_name = name && SvCUR(name);
3415 Perl_warner(aTHX_ packWARN(warn_type),
3416 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3417 have_name ? " " : "",
3418 SVfARG(have_name ? name : &PL_sv_no));
3419 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3421 aTHX_ packWARN(warn_type),
3422 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3423 func, pars, have_name ? " " : "",
3424 SVfARG(have_name ? name : &PL_sv_no)
3429 /* To workaround core dumps from the uninitialised tm_zone we get the
3430 * system to give us a reasonable struct to copy. This fix means that
3431 * strftime uses the tm_zone and tm_gmtoff values returned by
3432 * localtime(time()). That should give the desired result most of the
3433 * time. But probably not always!
3435 * This does not address tzname aspects of NETaa14816.
3440 # ifndef STRUCT_TM_HASZONE
3441 # define STRUCT_TM_HASZONE
3445 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3446 # ifndef HAS_TM_TM_ZONE
3447 # define HAS_TM_TM_ZONE
3452 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3454 #ifdef HAS_TM_TM_ZONE
3456 const struct tm* my_tm;
3457 PERL_ARGS_ASSERT_INIT_TM;
3459 my_tm = localtime(&now);
3461 Copy(my_tm, ptm, 1, struct tm);
3463 PERL_ARGS_ASSERT_INIT_TM;
3464 PERL_UNUSED_ARG(ptm);
3469 * mini_mktime - normalise struct tm values without the localtime()
3470 * semantics (and overhead) of mktime().
3473 Perl_mini_mktime(pTHX_ struct tm *ptm)
3477 int month, mday, year, jday;
3478 int odd_cent, odd_year;
3479 PERL_UNUSED_CONTEXT;
3481 PERL_ARGS_ASSERT_MINI_MKTIME;
3483 #define DAYS_PER_YEAR 365
3484 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3485 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3486 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3487 #define SECS_PER_HOUR (60*60)
3488 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3489 /* parentheses deliberately absent on these two, otherwise they don't work */
3490 #define MONTH_TO_DAYS 153/5
3491 #define DAYS_TO_MONTH 5/153
3492 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3493 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3494 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3495 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3498 * Year/day algorithm notes:
3500 * With a suitable offset for numeric value of the month, one can find
3501 * an offset into the year by considering months to have 30.6 (153/5) days,
3502 * using integer arithmetic (i.e., with truncation). To avoid too much
3503 * messing about with leap days, we consider January and February to be
3504 * the 13th and 14th month of the previous year. After that transformation,
3505 * we need the month index we use to be high by 1 from 'normal human' usage,
3506 * so the month index values we use run from 4 through 15.
3508 * Given that, and the rules for the Gregorian calendar (leap years are those
3509 * divisible by 4 unless also divisible by 100, when they must be divisible
3510 * by 400 instead), we can simply calculate the number of days since some
3511 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3512 * the days we derive from our month index, and adding in the day of the
3513 * month. The value used here is not adjusted for the actual origin which
3514 * it normally would use (1 January A.D. 1), since we're not exposing it.
3515 * We're only building the value so we can turn around and get the
3516 * normalised values for the year, month, day-of-month, and day-of-year.
3518 * For going backward, we need to bias the value we're using so that we find
3519 * the right year value. (Basically, we don't want the contribution of
3520 * March 1st to the number to apply while deriving the year). Having done
3521 * that, we 'count up' the contribution to the year number by accounting for
3522 * full quadracenturies (400-year periods) with their extra leap days, plus
3523 * the contribution from full centuries (to avoid counting in the lost leap
3524 * days), plus the contribution from full quad-years (to count in the normal
3525 * leap days), plus the leftover contribution from any non-leap years.
3526 * At this point, if we were working with an actual leap day, we'll have 0
3527 * days left over. This is also true for March 1st, however. So, we have
3528 * to special-case that result, and (earlier) keep track of the 'odd'
3529 * century and year contributions. If we got 4 extra centuries in a qcent,
3530 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3531 * Otherwise, we add back in the earlier bias we removed (the 123 from
3532 * figuring in March 1st), find the month index (integer division by 30.6),
3533 * and the remainder is the day-of-month. We then have to convert back to
3534 * 'real' months (including fixing January and February from being 14/15 in
3535 * the previous year to being in the proper year). After that, to get
3536 * tm_yday, we work with the normalised year and get a new yearday value for
3537 * January 1st, which we subtract from the yearday value we had earlier,
3538 * representing the date we've re-built. This is done from January 1
3539 * because tm_yday is 0-origin.
3541 * Since POSIX time routines are only guaranteed to work for times since the
3542 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3543 * applies Gregorian calendar rules even to dates before the 16th century
3544 * doesn't bother me. Besides, you'd need cultural context for a given
3545 * date to know whether it was Julian or Gregorian calendar, and that's
3546 * outside the scope for this routine. Since we convert back based on the
3547 * same rules we used to build the yearday, you'll only get strange results
3548 * for input which needed normalising, or for the 'odd' century years which
3549 * were leap years in the Julian calendar but not in the Gregorian one.
3550 * I can live with that.
3552 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3553 * that's still outside the scope for POSIX time manipulation, so I don't
3557 year = 1900 + ptm->tm_year;
3558 month = ptm->tm_mon;
3559 mday = ptm->tm_mday;
3565 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3566 yearday += month*MONTH_TO_DAYS + mday + jday;
3568 * Note that we don't know when leap-seconds were or will be,
3569 * so we have to trust the user if we get something which looks
3570 * like a sensible leap-second. Wild values for seconds will
3571 * be rationalised, however.
3573 if ((unsigned) ptm->tm_sec <= 60) {
3580 secs += 60 * ptm->tm_min;
3581 secs += SECS_PER_HOUR * ptm->tm_hour;
3583 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3584 /* got negative remainder, but need positive time */
3585 /* back off an extra day to compensate */
3586 yearday += (secs/SECS_PER_DAY)-1;
3587 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3590 yearday += (secs/SECS_PER_DAY);
3591 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3594 else if (secs >= SECS_PER_DAY) {
3595 yearday += (secs/SECS_PER_DAY);
3596 secs %= SECS_PER_DAY;
3598 ptm->tm_hour = secs/SECS_PER_HOUR;
3599 secs %= SECS_PER_HOUR;
3600 ptm->tm_min = secs/60;
3602 ptm->tm_sec += secs;
3603 /* done with time of day effects */
3605 * The algorithm for yearday has (so far) left it high by 428.
3606 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3607 * bias it by 123 while trying to figure out what year it
3608 * really represents. Even with this tweak, the reverse
3609 * translation fails for years before A.D. 0001.
3610 * It would still fail for Feb 29, but we catch that one below.
3612 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3613 yearday -= YEAR_ADJUST;
3614 year = (yearday / DAYS_PER_QCENT) * 400;
3615 yearday %= DAYS_PER_QCENT;
3616 odd_cent = yearday / DAYS_PER_CENT;
3617 year += odd_cent * 100;
3618 yearday %= DAYS_PER_CENT;
3619 year += (yearday / DAYS_PER_QYEAR) * 4;
3620 yearday %= DAYS_PER_QYEAR;
3621 odd_year = yearday / DAYS_PER_YEAR;
3623 yearday %= DAYS_PER_YEAR;
3624 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3629 yearday += YEAR_ADJUST; /* recover March 1st crock */
3630 month = yearday*DAYS_TO_MONTH;
3631 yearday -= month*MONTH_TO_DAYS;
3632 /* recover other leap-year adjustment */
3641 ptm->tm_year = year - 1900;
3643 ptm->tm_mday = yearday;
3644 ptm->tm_mon = month;
3648 ptm->tm_mon = month - 1;
3650 /* re-build yearday based on Jan 1 to get tm_yday */
3652 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3653 yearday += 14*MONTH_TO_DAYS + 1;
3654 ptm->tm_yday = jday - yearday;
3655 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3659 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)
3667 PERL_ARGS_ASSERT_MY_STRFTIME;
3669 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3672 mytm.tm_hour = hour;
3673 mytm.tm_mday = mday;
3675 mytm.tm_year = year;
3676 mytm.tm_wday = wday;
3677 mytm.tm_yday = yday;
3678 mytm.tm_isdst = isdst;
3680 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3681 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3686 #ifdef HAS_TM_TM_GMTOFF
3687 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3689 #ifdef HAS_TM_TM_ZONE
3690 mytm.tm_zone = mytm2.tm_zone;
3695 Newx(buf, buflen, char);
3697 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3698 len = strftime(buf, buflen, fmt, &mytm);
3702 ** The following is needed to handle to the situation where
3703 ** tmpbuf overflows. Basically we want to allocate a buffer
3704 ** and try repeatedly. The reason why it is so complicated
3705 ** is that getting a return value of 0 from strftime can indicate
3706 ** one of the following:
3707 ** 1. buffer overflowed,
3708 ** 2. illegal conversion specifier, or
3709 ** 3. the format string specifies nothing to be returned(not
3710 ** an error). This could be because format is an empty string
3711 ** or it specifies %p that yields an empty string in some locale.
3712 ** If there is a better way to make it portable, go ahead by
3715 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3718 /* Possibly buf overflowed - try again with a bigger buf */
3719 const int fmtlen = strlen(fmt);
3720 int bufsize = fmtlen + buflen;
3722 Renew(buf, bufsize, char);
3725 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
3726 buflen = strftime(buf, bufsize, fmt, &mytm);
3729 if (buflen > 0 && buflen < bufsize)
3731 /* heuristic to prevent out-of-memory errors */
3732 if (bufsize > 100*fmtlen) {
3738 Renew(buf, bufsize, char);
3743 Perl_croak(aTHX_ "panic: no strftime");
3749 #define SV_CWD_RETURN_UNDEF \
3750 sv_setsv(sv, &PL_sv_undef); \
3753 #define SV_CWD_ISDOT(dp) \
3754 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3755 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3758 =head1 Miscellaneous Functions
3760 =for apidoc getcwd_sv
3762 Fill the sv with current working directory
3767 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3768 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3769 * getcwd(3) if available
3770 * Comments from the orignal:
3771 * This is a faster version of getcwd. It's also more dangerous
3772 * because you might chdir out of a directory that you can't chdir
3776 Perl_getcwd_sv(pTHX_ SV *sv)
3782 PERL_ARGS_ASSERT_GETCWD_SV;
3786 char buf[MAXPATHLEN];
3788 /* Some getcwd()s automatically allocate a buffer of the given
3789 * size from the heap if they are given a NULL buffer pointer.
3790 * The problem is that this behaviour is not portable. */
3791 if (getcwd(buf, sizeof(buf) - 1)) {
3796 sv_setsv(sv, &PL_sv_undef);
3804 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3808 SvUPGRADE(sv, SVt_PV);
3810 if (PerlLIO_lstat(".", &statbuf) < 0) {
3811 SV_CWD_RETURN_UNDEF;
3814 orig_cdev = statbuf.st_dev;
3815 orig_cino = statbuf.st_ino;
3825 if (PerlDir_chdir("..") < 0) {
3826 SV_CWD_RETURN_UNDEF;
3828 if (PerlLIO_stat(".", &statbuf) < 0) {
3829 SV_CWD_RETURN_UNDEF;
3832 cdev = statbuf.st_dev;
3833 cino = statbuf.st_ino;
3835 if (odev == cdev && oino == cino) {
3838 if (!(dir = PerlDir_open("."))) {
3839 SV_CWD_RETURN_UNDEF;
3842 while ((dp = PerlDir_read(dir)) != NULL) {
3844 namelen = dp->d_namlen;
3846 namelen = strlen(dp->d_name);
3849 if (SV_CWD_ISDOT(dp)) {
3853 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3854 SV_CWD_RETURN_UNDEF;
3857 tdev = statbuf.st_dev;
3858 tino = statbuf.st_ino;
3859 if (tino == oino && tdev == odev) {
3865 SV_CWD_RETURN_UNDEF;
3868 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3869 SV_CWD_RETURN_UNDEF;
3872 SvGROW(sv, pathlen + namelen + 1);
3876 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3879 /* prepend current directory to the front */
3881 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3882 pathlen += (namelen + 1);
3884 #ifdef VOID_CLOSEDIR
3887 if (PerlDir_close(dir) < 0) {
3888 SV_CWD_RETURN_UNDEF;
3894 SvCUR_set(sv, pathlen);
3898 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3899 SV_CWD_RETURN_UNDEF;
3902 if (PerlLIO_stat(".", &statbuf) < 0) {
3903 SV_CWD_RETURN_UNDEF;
3906 cdev = statbuf.st_dev;
3907 cino = statbuf.st_ino;
3909 if (cdev != orig_cdev || cino != orig_cino) {
3910 Perl_croak(aTHX_ "Unstable directory path, "
3911 "current directory changed unexpectedly");
3924 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
3925 # define EMULATE_SOCKETPAIR_UDP
3928 #ifdef EMULATE_SOCKETPAIR_UDP
3930 S_socketpair_udp (int fd[2]) {
3932 /* Fake a datagram socketpair using UDP to localhost. */
3933 int sockets[2] = {-1, -1};
3934 struct sockaddr_in addresses[2];
3936 Sock_size_t size = sizeof(struct sockaddr_in);
3937 unsigned short port;
3940 memset(&addresses, 0, sizeof(addresses));
3943 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
3944 if (sockets[i] == -1)
3945 goto tidy_up_and_fail;
3947 addresses[i].sin_family = AF_INET;
3948 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
3949 addresses[i].sin_port = 0; /* kernel choses port. */
3950 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
3951 sizeof(struct sockaddr_in)) == -1)
3952 goto tidy_up_and_fail;
3955 /* Now have 2 UDP sockets. Find out which port each is connected to, and
3956 for each connect the other socket to it. */
3959 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
3961 goto tidy_up_and_fail;
3962 if (size != sizeof(struct sockaddr_in))
3963 goto abort_tidy_up_and_fail;
3964 /* !1 is 0, !0 is 1 */
3965 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
3966 sizeof(struct sockaddr_in)) == -1)
3967 goto tidy_up_and_fail;
3970 /* Now we have 2 sockets connected to each other. I don't trust some other
3971 process not to have already sent a packet to us (by random) so send
3972 a packet from each to the other. */
3975 /* I'm going to send my own port number. As a short.
3976 (Who knows if someone somewhere has sin_port as a bitfield and needs
3977 this routine. (I'm assuming crays have socketpair)) */
3978 port = addresses[i].sin_port;
3979 got = PerlLIO_write(sockets[i], &port, sizeof(port));
3980 if (got != sizeof(port)) {
3982 goto tidy_up_and_fail;
3983 goto abort_tidy_up_and_fail;
3987 /* Packets sent. I don't trust them to have arrived though.
3988 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
3989 connect to localhost will use a second kernel thread. In 2.6 the
3990 first thread running the connect() returns before the second completes,
3991 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
3992 returns 0. Poor programs have tripped up. One poor program's authors'
3993 had a 50-1 reverse stock split. Not sure how connected these were.)
3994 So I don't trust someone not to have an unpredictable UDP stack.
3998 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
3999 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4003 FD_SET((unsigned int)sockets[0], &rset);
4004 FD_SET((unsigned int)sockets[1], &rset);
4006 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4007 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4008 || !FD_ISSET(sockets[1], &rset)) {
4009 /* I hope this is portable and appropriate. */
4011 goto tidy_up_and_fail;
4012 goto abort_tidy_up_and_fail;
4016 /* And the paranoia department even now doesn't trust it to have arrive
4017 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4019 struct sockaddr_in readfrom;
4020 unsigned short buffer[2];
4025 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4026 sizeof(buffer), MSG_DONTWAIT,
4027 (struct sockaddr *) &readfrom, &size);
4029 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4031 (struct sockaddr *) &readfrom, &size);
4035 goto tidy_up_and_fail;
4036 if (got != sizeof(port)
4037 || size != sizeof(struct sockaddr_in)
4038 /* Check other socket sent us its port. */
4039 || buffer[0] != (unsigned short) addresses[!i].sin_port
4040 /* Check kernel says we got the datagram from that socket */
4041 || readfrom.sin_family != addresses[!i].sin_family
4042 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4043 || readfrom.sin_port != addresses[!i].sin_port)
4044 goto abort_tidy_up_and_fail;
4047 /* My caller (my_socketpair) has validated that this is non-NULL */
4050 /* I hereby declare this connection open. May God bless all who cross
4054 abort_tidy_up_and_fail:
4055 errno = ECONNABORTED;
4059 if (sockets[0] != -1)
4060 PerlLIO_close(sockets[0]);
4061 if (sockets[1] != -1)
4062 PerlLIO_close(sockets[1]);
4067 #endif /* EMULATE_SOCKETPAIR_UDP */
4069 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4071 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4072 /* Stevens says that family must be AF_LOCAL, protocol 0.
4073 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4078 struct sockaddr_in listen_addr;
4079 struct sockaddr_in connect_addr;
4084 || family != AF_UNIX
4087 errno = EAFNOSUPPORT;
4095 #ifdef EMULATE_SOCKETPAIR_UDP
4096 if (type == SOCK_DGRAM)
4097 return S_socketpair_udp(fd);
4100 aTHXa(PERL_GET_THX);
4101 listener = PerlSock_socket(AF_INET, type, 0);
4104 memset(&listen_addr, 0, sizeof(listen_addr));
4105 listen_addr.sin_family = AF_INET;
4106 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4107 listen_addr.sin_port = 0; /* kernel choses port. */
4108 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4109 sizeof(listen_addr)) == -1)
4110 goto tidy_up_and_fail;
4111 if (PerlSock_listen(listener, 1) == -1)
4112 goto tidy_up_and_fail;
4114 connector = PerlSock_socket(AF_INET, type, 0);
4115 if (connector == -1)
4116 goto tidy_up_and_fail;
4117 /* We want to find out the port number to connect to. */
4118 size = sizeof(connect_addr);
4119 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4121 goto tidy_up_and_fail;
4122 if (size != sizeof(connect_addr))
4123 goto abort_tidy_up_and_fail;
4124 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4125 sizeof(connect_addr)) == -1)
4126 goto tidy_up_and_fail;
4128 size = sizeof(listen_addr);
4129 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4132 goto tidy_up_and_fail;
4133 if (size != sizeof(listen_addr))
4134 goto abort_tidy_up_and_fail;
4135 PerlLIO_close(listener);
4136 /* Now check we are talking to ourself by matching port and host on the
4138 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4140 goto tidy_up_and_fail;
4141 if (size != sizeof(connect_addr)
4142 || listen_addr.sin_family != connect_addr.sin_family
4143 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4144 || listen_addr.sin_port != connect_addr.sin_port) {
4145 goto abort_tidy_up_and_fail;
4151 abort_tidy_up_and_fail:
4153 errno = ECONNABORTED; /* This would be the standard thing to do. */
4155 # ifdef ECONNREFUSED
4156 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4158 errno = ETIMEDOUT; /* Desperation time. */
4165 PerlLIO_close(listener);
4166 if (connector != -1)
4167 PerlLIO_close(connector);
4169 PerlLIO_close(acceptor);
4175 /* In any case have a stub so that there's code corresponding
4176 * to the my_socketpair in embed.fnc. */
4178 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4179 #ifdef HAS_SOCKETPAIR
4180 return socketpair(family, type, protocol, fd);
4189 =for apidoc sv_nosharing
4191 Dummy routine which "shares" an SV when there is no sharing module present.
4192 Or "locks" it. Or "unlocks" it. In other
4193 words, ignores its single SV argument.
4194 Exists to avoid test for a NULL function pointer and because it could
4195 potentially warn under some level of strict-ness.
4201 Perl_sv_nosharing(pTHX_ SV *sv)
4203 PERL_UNUSED_CONTEXT;
4204 PERL_UNUSED_ARG(sv);
4209 =for apidoc sv_destroyable
4211 Dummy routine which reports that object can be destroyed when there is no
4212 sharing module present. It ignores its single SV argument, and returns
4213 'true'. Exists to avoid test for a NULL function pointer and because it
4214 could potentially warn under some level of strict-ness.
4220 Perl_sv_destroyable(pTHX_ SV *sv)
4222 PERL_UNUSED_CONTEXT;
4223 PERL_UNUSED_ARG(sv);
4228 Perl_parse_unicode_opts(pTHX_ const char **popt)
4230 const char *p = *popt;
4233 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4237 opt = (U32) atoi(p);
4240 if (*p && *p != '\n' && *p != '\r') {
4241 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4243 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4249 case PERL_UNICODE_STDIN:
4250 opt |= PERL_UNICODE_STDIN_FLAG; break;
4251 case PERL_UNICODE_STDOUT:
4252 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4253 case PERL_UNICODE_STDERR:
4254 opt |= PERL_UNICODE_STDERR_FLAG; break;
4255 case PERL_UNICODE_STD:
4256 opt |= PERL_UNICODE_STD_FLAG; break;
4257 case PERL_UNICODE_IN:
4258 opt |= PERL_UNICODE_IN_FLAG; break;
4259 case PERL_UNICODE_OUT:
4260 opt |= PERL_UNICODE_OUT_FLAG; break;
4261 case PERL_UNICODE_INOUT:
4262 opt |= PERL_UNICODE_INOUT_FLAG; break;
4263 case PERL_UNICODE_LOCALE:
4264 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4265 case PERL_UNICODE_ARGV:
4266 opt |= PERL_UNICODE_ARGV_FLAG; break;
4267 case PERL_UNICODE_UTF8CACHEASSERT:
4268 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4270 if (*p != '\n' && *p != '\r') {
4271 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4274 "Unknown Unicode option letter '%c'", *p);
4281 opt = PERL_UNICODE_DEFAULT_FLAGS;
4283 the_end_of_the_opts_parser:
4285 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4286 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4287 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4295 # include <starlet.h>
4303 * This is really just a quick hack which grabs various garbage
4304 * values. It really should be a real hash algorithm which
4305 * spreads the effect of every input bit onto every output bit,
4306 * if someone who knows about such things would bother to write it.
4307 * Might be a good idea to add that function to CORE as well.
4308 * No numbers below come from careful analysis or anything here,
4309 * except they are primes and SEED_C1 > 1E6 to get a full-width
4310 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4311 * probably be bigger too.
4314 # define SEED_C1 1000003
4315 #define SEED_C4 73819
4317 # define SEED_C1 25747
4318 #define SEED_C4 20639
4322 #define SEED_C5 26107
4324 #ifndef PERL_NO_DEV_RANDOM
4329 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4330 * in 100-ns units, typically incremented ever 10 ms. */
4331 unsigned int when[2];
4333 # ifdef HAS_GETTIMEOFDAY
4334 struct timeval when;
4340 /* This test is an escape hatch, this symbol isn't set by Configure. */
4341 #ifndef PERL_NO_DEV_RANDOM
4342 #ifndef PERL_RANDOM_DEVICE
4343 /* /dev/random isn't used by default because reads from it will block
4344 * if there isn't enough entropy available. You can compile with
4345 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4346 * is enough real entropy to fill the seed. */
4347 # define PERL_RANDOM_DEVICE "/dev/urandom"
4349 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4351 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4360 _ckvmssts(sys$gettim(when));
4361 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4363 # ifdef HAS_GETTIMEOFDAY
4364 PerlProc_gettimeofday(&when,NULL);
4365 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4368 u = (U32)SEED_C1 * when;
4371 u += SEED_C3 * (U32)PerlProc_getpid();
4372 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4373 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4374 u += SEED_C5 * (U32)PTR2UV(&when);
4380 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4386 PERL_ARGS_ASSERT_GET_HASH_SEED;
4388 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4391 #ifndef USE_HASH_SEED_EXPLICIT
4393 /* ignore leading spaces */
4394 while (isSPACE(*env_pv))
4396 #ifdef USE_PERL_PERTURB_KEYS
4397 /* if they set it to "0" we disable key traversal randomization completely */
4398 if (strEQ(env_pv,"0")) {
4399 PL_hash_rand_bits_enabled= 0;
4401 /* otherwise switch to deterministic mode */
4402 PL_hash_rand_bits_enabled= 2;
4405 /* ignore a leading 0x... if it is there */
4406 if (env_pv[0] == '0' && env_pv[1] == 'x')
4409 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4410 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4411 if ( isXDIGIT(*env_pv)) {
4412 seed_buffer[i] |= READ_XDIGIT(env_pv);
4415 while (isSPACE(*env_pv))
4418 if (*env_pv && !isXDIGIT(*env_pv)) {
4419 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4421 /* should we check for unparsed crap? */
4422 /* should we warn about unused hex? */
4423 /* should we warn about insufficient hex? */
4428 (void)seedDrand01((Rand_seed_t)seed());
4430 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4431 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4434 #ifdef USE_PERL_PERTURB_KEYS
4435 { /* initialize PL_hash_rand_bits from the hash seed.
4436 * This value is highly volatile, it is updated every
4437 * hash insert, and is used as part of hash bucket chain
4438 * randomization and hash iterator randomization. */
4439 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4440 for( i = 0; i < sizeof(UV) ; i++ ) {
4441 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4442 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4445 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4447 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4448 PL_hash_rand_bits_enabled= 0;
4449 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4450 PL_hash_rand_bits_enabled= 1;
4451 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4452 PL_hash_rand_bits_enabled= 2;
4454 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4460 #ifdef PERL_GLOBAL_STRUCT
4462 #define PERL_GLOBAL_STRUCT_INIT
4463 #include "opcode.h" /* the ppaddr and check */
4466 Perl_init_global_struct(pTHX)
4468 struct perl_vars *plvarsp = NULL;
4469 # ifdef PERL_GLOBAL_STRUCT
4470 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4471 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4472 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4473 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4474 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4478 plvarsp = PL_VarsPtr;
4479 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4484 # define PERLVAR(prefix,var,type) /**/
4485 # define PERLVARA(prefix,var,n,type) /**/
4486 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4487 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4488 # include "perlvars.h"
4493 # ifdef PERL_GLOBAL_STRUCT
4496 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4497 if (!plvarsp->Gppaddr)
4501 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4502 if (!plvarsp->Gcheck)
4504 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4505 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4507 # ifdef PERL_SET_VARS
4508 PERL_SET_VARS(plvarsp);
4510 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4511 plvarsp->Gsv_placeholder.sv_flags = 0;
4512 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4514 # undef PERL_GLOBAL_STRUCT_INIT
4519 #endif /* PERL_GLOBAL_STRUCT */
4521 #ifdef PERL_GLOBAL_STRUCT
4524 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4526 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4527 # ifdef PERL_GLOBAL_STRUCT
4528 # ifdef PERL_UNSET_VARS
4529 PERL_UNSET_VARS(plvarsp);
4531 free(plvarsp->Gppaddr);
4532 free(plvarsp->Gcheck);
4533 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4539 #endif /* PERL_GLOBAL_STRUCT */
4543 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
4544 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4545 * given, and you supply your own implementation.
4547 * The default implementation reads a single env var, PERL_MEM_LOG,
4548 * expecting one or more of the following:
4550 * \d+ - fd fd to write to : must be 1st (atoi)
4551 * 'm' - memlog was PERL_MEM_LOG=1
4552 * 's' - svlog was PERL_SV_LOG=1
4553 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
4555 * This makes the logger controllable enough that it can reasonably be
4556 * added to the system perl.
4559 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4560 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4562 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4564 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4565 * writes to. In the default logger, this is settable at runtime.
4567 #ifndef PERL_MEM_LOG_FD
4568 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4571 #ifndef PERL_MEM_LOG_NOIMPL
4573 # ifdef DEBUG_LEAKING_SCALARS
4574 # define SV_LOG_SERIAL_FMT " [%lu]"
4575 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
4577 # define SV_LOG_SERIAL_FMT
4578 # define _SV_LOG_SERIAL_ARG(sv)
4582 S_mem_log_common(enum mem_log_type mlt, const UV n,
4583 const UV typesize, const char *type_name, const SV *sv,
4584 Malloc_t oldalloc, Malloc_t newalloc,
4585 const char *filename, const int linenumber,
4586 const char *funcname)
4590 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4592 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4595 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4597 /* We can't use SVs or PerlIO for obvious reasons,
4598 * so we'll use stdio and low-level IO instead. */
4599 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4601 # ifdef HAS_GETTIMEOFDAY
4602 # define MEM_LOG_TIME_FMT "%10d.%06d: "
4603 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
4605 gettimeofday(&tv, 0);
4607 # define MEM_LOG_TIME_FMT "%10d: "
4608 # define MEM_LOG_TIME_ARG (int)when
4612 /* If there are other OS specific ways of hires time than
4613 * gettimeofday() (see ext/Time-HiRes), the easiest way is
4614 * probably that they would be used to fill in the struct
4618 int fd = atoi(pmlenv);
4620 fd = PERL_MEM_LOG_FD;
4622 if (strchr(pmlenv, 't')) {
4623 len = my_snprintf(buf, sizeof(buf),
4624 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4625 PerlLIO_write(fd, buf, len);
4629 len = my_snprintf(buf, sizeof(buf),
4630 "alloc: %s:%d:%s: %"IVdf" %"UVuf
4631 " %s = %"IVdf": %"UVxf"\n",
4632 filename, linenumber, funcname, n, typesize,
4633 type_name, n * typesize, PTR2UV(newalloc));
4636 len = my_snprintf(buf, sizeof(buf),
4637 "realloc: %s:%d:%s: %"IVdf" %"UVuf
4638 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
4639 filename, linenumber, funcname, n, typesize,
4640 type_name, n * typesize, PTR2UV(oldalloc),
4644 len = my_snprintf(buf, sizeof(buf),
4645 "free: %s:%d:%s: %"UVxf"\n",
4646 filename, linenumber, funcname,
4651 len = my_snprintf(buf, sizeof(buf),
4652 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
4653 mlt == MLT_NEW_SV ? "new" : "del",
4654 filename, linenumber, funcname,
4655 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4660 PerlLIO_write(fd, buf, len);
4664 #endif /* !PERL_MEM_LOG_NOIMPL */
4666 #ifndef PERL_MEM_LOG_NOIMPL
4668 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
4669 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
4671 /* this is suboptimal, but bug compatible. User is providing their
4672 own implementation, but is getting these functions anyway, and they
4673 do nothing. But _NOIMPL users should be able to cope or fix */
4675 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
4676 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
4680 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
4682 const char *filename, const int linenumber,
4683 const char *funcname)
4685 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
4686 NULL, NULL, newalloc,
4687 filename, linenumber, funcname);
4692 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
4693 Malloc_t oldalloc, Malloc_t newalloc,
4694 const char *filename, const int linenumber,
4695 const char *funcname)
4697 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
4698 NULL, oldalloc, newalloc,
4699 filename, linenumber, funcname);
4704 Perl_mem_log_free(Malloc_t oldalloc,
4705 const char *filename, const int linenumber,
4706 const char *funcname)
4708 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
4709 filename, linenumber, funcname);
4714 Perl_mem_log_new_sv(const SV *sv,
4715 const char *filename, const int linenumber,
4716 const char *funcname)
4718 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
4719 filename, linenumber, funcname);
4723 Perl_mem_log_del_sv(const SV *sv,
4724 const char *filename, const int linenumber,
4725 const char *funcname)
4727 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
4728 filename, linenumber, funcname);
4731 #endif /* PERL_MEM_LOG */
4734 =for apidoc my_sprintf
4736 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
4737 the length of the string written to the buffer. Only rare pre-ANSI systems
4738 need the wrapper function - usually this is a direct call to C<sprintf>.
4742 #ifndef SPRINTF_RETURNS_STRLEN
4744 Perl_my_sprintf(char *buffer, const char* pat, ...)
4747 PERL_ARGS_ASSERT_MY_SPRINTF;
4748 va_start(args, pat);
4749 vsprintf(buffer, pat, args);
4751 return strlen(buffer);
4756 =for apidoc my_snprintf
4758 The C library C<snprintf> functionality, if available and
4759 standards-compliant (uses C<vsnprintf>, actually). However, if the
4760 C<vsnprintf> is not available, will unfortunately use the unsafe
4761 C<vsprintf> which can overrun the buffer (there is an overrun check,
4762 but that may be too late). Consider using C<sv_vcatpvf> instead, or
4763 getting C<vsnprintf>.
4768 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
4772 PERL_ARGS_ASSERT_MY_SNPRINTF;
4773 va_start(ap, format);
4774 #ifdef HAS_VSNPRINTF
4775 retval = vsnprintf(buffer, len, format, ap);
4777 retval = vsprintf(buffer, format, ap);
4780 /* vsprintf() shows failure with < 0 */
4782 #ifdef HAS_VSNPRINTF
4783 /* vsnprintf() shows failure with >= len */
4785 (len > 0 && (Size_t)retval >= len)
4788 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
4793 =for apidoc my_vsnprintf
4795 The C library C<vsnprintf> if available and standards-compliant.
4796 However, if if the C<vsnprintf> is not available, will unfortunately
4797 use the unsafe C<vsprintf> which can overrun the buffer (there is an
4798 overrun check, but that may be too late). Consider using
4799 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
4804 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
4810 PERL_ARGS_ASSERT_MY_VSNPRINTF;
4812 Perl_va_copy(ap, apc);
4813 # ifdef HAS_VSNPRINTF
4814 retval = vsnprintf(buffer, len, format, apc);
4816 retval = vsprintf(buffer, format, apc);
4819 # ifdef HAS_VSNPRINTF
4820 retval = vsnprintf(buffer, len, format, ap);
4822 retval = vsprintf(buffer, format, ap);
4824 #endif /* #ifdef NEED_VA_COPY */
4825 /* vsprintf() shows failure with < 0 */
4827 #ifdef HAS_VSNPRINTF
4828 /* vsnprintf() shows failure with >= len */
4830 (len > 0 && (Size_t)retval >= len)
4833 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
4838 Perl_my_clearenv(pTHX)
4841 #if ! defined(PERL_MICRO)
4842 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
4844 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
4845 # if defined(USE_ENVIRON_ARRAY)
4846 # if defined(USE_ITHREADS)
4847 /* only the parent thread can clobber the process environment */
4848 if (PL_curinterp == aTHX)
4849 # endif /* USE_ITHREADS */
4851 # if ! defined(PERL_USE_SAFE_PUTENV)
4852 if ( !PL_use_safe_putenv) {
4854 if (environ == PL_origenviron)
4855 environ = (char**)safesysmalloc(sizeof(char*));
4857 for (i = 0; environ[i]; i++)
4858 (void)safesysfree(environ[i]);
4861 # else /* PERL_USE_SAFE_PUTENV */
4862 # if defined(HAS_CLEARENV)
4864 # elif defined(HAS_UNSETENV)
4865 int bsiz = 80; /* Most envvar names will be shorter than this. */
4866 char *buf = (char*)safesysmalloc(bsiz);
4867 while (*environ != NULL) {
4868 char *e = strchr(*environ, '=');
4869 int l = e ? e - *environ : (int)strlen(*environ);
4871 (void)safesysfree(buf);
4872 bsiz = l + 1; /* + 1 for the \0. */
4873 buf = (char*)safesysmalloc(bsiz);
4875 memcpy(buf, *environ, l);
4877 (void)unsetenv(buf);
4879 (void)safesysfree(buf);
4880 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
4881 /* Just null environ and accept the leakage. */
4883 # endif /* HAS_CLEARENV || HAS_UNSETENV */
4884 # endif /* ! PERL_USE_SAFE_PUTENV */
4886 # endif /* USE_ENVIRON_ARRAY */
4887 # endif /* PERL_IMPLICIT_SYS || WIN32 */
4888 #endif /* PERL_MICRO */
4891 #ifdef PERL_IMPLICIT_CONTEXT
4893 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
4894 the global PL_my_cxt_index is incremented, and that value is assigned to
4895 that module's static my_cxt_index (who's address is passed as an arg).
4896 Then, for each interpreter this function is called for, it makes sure a
4897 void* slot is available to hang the static data off, by allocating or
4898 extending the interpreter's PL_my_cxt_list array */
4900 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
4902 Perl_my_cxt_init(pTHX_ int *index, size_t size)
4906 PERL_ARGS_ASSERT_MY_CXT_INIT;
4908 /* this module hasn't been allocated an index yet */
4909 #if defined(USE_ITHREADS)
4910 MUTEX_LOCK(&PL_my_ctx_mutex);
4912 *index = PL_my_cxt_index++;
4913 #if defined(USE_ITHREADS)
4914 MUTEX_UNLOCK(&PL_my_ctx_mutex);
4918 /* make sure the array is big enough */
4919 if (PL_my_cxt_size <= *index) {
4920 if (PL_my_cxt_size) {
4921 while (PL_my_cxt_size <= *index)
4922 PL_my_cxt_size *= 2;
4923 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
4926 PL_my_cxt_size = 16;
4927 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
4930 /* newSV() allocates one more than needed */
4931 p = (void*)SvPVX(newSV(size-1));
4932 PL_my_cxt_list[*index] = p;
4933 Zero(p, size, char);
4937 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
4940 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
4945 PERL_ARGS_ASSERT_MY_CXT_INDEX;
4947 for (index = 0; index < PL_my_cxt_index; index++) {
4948 const char *key = PL_my_cxt_keys[index];
4949 /* try direct pointer compare first - there are chances to success,
4950 * and it's much faster.
4952 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
4959 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
4965 PERL_ARGS_ASSERT_MY_CXT_INIT;
4967 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
4969 /* this module hasn't been allocated an index yet */
4970 #if defined(USE_ITHREADS)
4971 MUTEX_LOCK(&PL_my_ctx_mutex);
4973 index = PL_my_cxt_index++;
4974 #if defined(USE_ITHREADS)
4975 MUTEX_UNLOCK(&PL_my_ctx_mutex);
4979 /* make sure the array is big enough */
4980 if (PL_my_cxt_size <= index) {
4981 int old_size = PL_my_cxt_size;
4983 if (PL_my_cxt_size) {
4984 while (PL_my_cxt_size <= index)
4985 PL_my_cxt_size *= 2;
4986 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
4987 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
4990 PL_my_cxt_size = 16;
4991 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
4992 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
4994 for (i = old_size; i < PL_my_cxt_size; i++) {
4995 PL_my_cxt_keys[i] = 0;
4996 PL_my_cxt_list[i] = 0;
4999 PL_my_cxt_keys[index] = my_cxt_key;
5000 /* newSV() allocates one more than needed */
5001 p = (void*)SvPVX(newSV(size-1));
5002 PL_my_cxt_list[index] = p;
5003 Zero(p, size, char);
5006 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5007 #endif /* PERL_IMPLICIT_CONTEXT */
5010 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5014 const char *vn = NULL;
5015 SV *const module = PL_stack_base[ax];
5017 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5019 if (items >= 2) /* version supplied as bootstrap arg */
5020 sv = PL_stack_base[ax + 1];
5022 /* XXX GV_ADDWARN */
5024 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5025 if (!sv || !SvOK(sv)) {
5027 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5031 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5032 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5033 ? sv : sv_2mortal(new_version(sv));
5034 xssv = upg_version(xssv, 0);
5035 if ( vcmp(pmsv,xssv) ) {
5036 SV *string = vstringify(xssv);
5037 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5038 " does not match ", module, string);
5040 SvREFCNT_dec(string);
5041 string = vstringify(pmsv);
5044 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5047 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
5049 SvREFCNT_dec(string);
5051 Perl_sv_2mortal(aTHX_ xpt);
5052 Perl_croak_sv(aTHX_ xpt);
5058 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
5062 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
5065 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
5067 /* This might croak */
5068 compver = upg_version(compver, 0);
5069 /* This should never croak */
5070 runver = new_version(PL_apiversion);
5071 if (vcmp(compver, runver)) {
5072 SV *compver_string = vstringify(compver);
5073 SV *runver_string = vstringify(runver);
5074 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
5075 " of %"SVf" does not match %"SVf,
5076 compver_string, module, runver_string);
5077 Perl_sv_2mortal(aTHX_ xpt);
5079 SvREFCNT_dec(compver_string);
5080 SvREFCNT_dec(runver_string);
5082 SvREFCNT_dec(runver);
5084 Perl_croak_sv(aTHX_ xpt);
5088 =for apidoc my_strlcat
5090 The C library C<strlcat> if available, or a Perl implementation of it.
5091 This operates on C NUL-terminated strings.
5093 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
5094 most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
5095 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5096 practice this should not happen as it means that either C<size> is incorrect or
5097 that C<dst> is not a proper NUL-terminated string).
5099 Note that C<size> is the full size of the destination buffer and
5100 the result is guaranteed to be NUL-terminated if there is room. Note that room
5101 for the NUL should be included in C<size>.
5105 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
5109 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5111 Size_t used, length, copy;
5114 length = strlen(src);
5115 if (size > 0 && used < size - 1) {
5116 copy = (length >= size - used) ? size - used - 1 : length;
5117 memcpy(dst + used, src, copy);
5118 dst[used + copy] = '\0';
5120 return used + length;
5126 =for apidoc my_strlcpy
5128 The C library C<strlcpy> if available, or a Perl implementation of it.
5129 This operates on C NUL-terminated strings.
5131 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5132 to C<dst>, NUL-terminating the result if C<size> is not 0.
5136 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
5140 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5142 Size_t length, copy;
5144 length = strlen(src);
5146 copy = (length >= size) ? size - 1 : length;
5147 memcpy(dst, src, copy);
5154 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5155 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5156 long _ftol( double ); /* Defined by VC6 C libs. */
5157 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5160 PERL_STATIC_INLINE bool
5161 S_gv_has_usable_name(pTHX_ GV *gv)
5165 && HvENAME(GvSTASH(gv))
5166 && (gvp = (GV **)hv_fetch(
5167 GvSTASH(gv), GvNAME(gv),
5168 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
5174 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5177 SV * const dbsv = GvSVn(PL_DBsub);
5178 const bool save_taint = TAINT_get;
5180 /* When we are called from pp_goto (svp is null),
5181 * we do not care about using dbsv to call CV;
5182 * it's for informational purposes only.
5185 PERL_ARGS_ASSERT_GET_DB_SUB;
5189 if (!PERLDB_SUB_NN) {
5193 gv_efullname3(dbsv, gv, NULL);
5195 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5196 || strEQ(GvNAME(gv), "END")
5197 || ( /* Could be imported, and old sub redefined. */
5198 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5200 !( (SvTYPE(*svp) == SVt_PVGV)
5201 && (GvCV((const GV *)*svp) == cv)
5202 /* Use GV from the stack as a fallback. */
5203 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
5207 /* GV is potentially non-unique, or contain different CV. */
5208 SV * const tmp = newRV(MUTABLE_SV(cv));
5209 sv_setsv(dbsv, tmp);
5213 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5214 sv_catpvs(dbsv, "::");
5216 dbsv, GvNAME(gv), GvNAMELEN(gv),
5217 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
5222 const int type = SvTYPE(dbsv);
5223 if (type < SVt_PVIV && type != SVt_IV)
5224 sv_upgrade(dbsv, SVt_PVIV);
5225 (void)SvIOK_on(dbsv);
5226 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5228 TAINT_IF(save_taint);
5229 #ifdef NO_TAINT_SUPPORT
5230 PERL_UNUSED_VAR(save_taint);
5235 Perl_my_dirfd(pTHX_ DIR * dir) {
5237 /* Most dirfd implementations have problems when passed NULL. */
5242 #elif defined(HAS_DIR_DD_FD)
5245 Perl_die(aTHX_ PL_no_func, "dirfd");
5246 assert(0); /* NOT REACHED */
5252 Perl_get_re_arg(pTHX_ SV *sv) {
5258 sv = MUTABLE_SV(SvRV(sv));
5259 if (SvTYPE(sv) == SVt_REGEXP)
5260 return (REGEXP*) sv;
5267 * This code is derived from drand48() implementation from FreeBSD,
5268 * found in lib/libc/gen/_rand48.c.
5270 * The U64 implementation is original, based on the POSIX
5271 * specification for drand48().
5275 * Copyright (c) 1993 Martin Birgmeier
5276 * All rights reserved.
5278 * You may redistribute unmodified or modified versions of this source
5279 * code provided that the above copyright notice and this and the
5280 * following conditions are retained.
5282 * This software is provided ``as is'', and comes with no warranties
5283 * of any kind. I shall in no event be liable for anything that happens
5284 * to anyone/anything when using this software.
5287 #define FREEBSD_DRAND48_SEED_0 (0x330e)
5289 #ifdef PERL_DRAND48_QUAD
5291 #define DRAND48_MULT U64_CONST(0x5deece66d)
5292 #define DRAND48_ADD 0xb
5293 #define DRAND48_MASK U64_CONST(0xffffffffffff)
5297 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
5298 #define FREEBSD_DRAND48_SEED_2 (0x1234)
5299 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
5300 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
5301 #define FREEBSD_DRAND48_MULT_2 (0x0005)
5302 #define FREEBSD_DRAND48_ADD (0x000b)
5304 const unsigned short _rand48_mult[3] = {
5305 FREEBSD_DRAND48_MULT_0,
5306 FREEBSD_DRAND48_MULT_1,
5307 FREEBSD_DRAND48_MULT_2
5309 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5314 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5316 PERL_ARGS_ASSERT_DRAND48_INIT_R;
5318 #ifdef PERL_DRAND48_QUAD
5319 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
5321 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5322 random_state->seed[1] = (U16) seed;
5323 random_state->seed[2] = (U16) (seed >> 16);
5328 Perl_drand48_r(perl_drand48_t *random_state)
5330 PERL_ARGS_ASSERT_DRAND48_R;
5332 #ifdef PERL_DRAND48_QUAD
5333 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5336 return ldexp((double)*random_state, -48);
5342 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5343 + (U32) _rand48_add;
5344 temp[0] = (U16) accu; /* lower 16 bits */
5345 accu >>= sizeof(U16) * 8;
5346 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5347 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5348 temp[1] = (U16) accu; /* middle 16 bits */
5349 accu >>= sizeof(U16) * 8;
5350 accu += _rand48_mult[0] * random_state->seed[2]
5351 + _rand48_mult[1] * random_state->seed[1]
5352 + _rand48_mult[2] * random_state->seed[0];
5353 random_state->seed[0] = temp[0];
5354 random_state->seed[1] = temp[1];
5355 random_state->seed[2] = (U16) accu;
5357 return ldexp((double) random_state->seed[0], -48) +
5358 ldexp((double) random_state->seed[1], -32) +
5359 ldexp((double) random_state->seed[2], -16);
5367 * c-indentation-style: bsd
5369 * indent-tabs-mode: nil
5372 * ex: set ts=8 sts=4 sw=4 et: