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
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
81 PerlIO_printf(Perl_error_log,
82 "Allocation too large: %lx\n", size) FLUSH;
85 #endif /* HAS_64K_LIMIT */
86 #ifdef PERL_TRACK_MEMPOOL
90 if ((SSize_t)size < 0)
91 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
93 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
94 PERL_ALLOC_CHECK(ptr);
96 #ifdef PERL_TRACK_MEMPOOL
97 struct perl_memory_debug_header *const header
98 = (struct perl_memory_debug_header *)ptr;
102 PoisonNew(((char *)ptr), size, char);
105 #ifdef PERL_TRACK_MEMPOOL
106 header->interpreter = aTHX;
107 /* Link us into the list. */
108 header->prev = &PL_memory_debug_header;
109 header->next = PL_memory_debug_header.next;
110 PL_memory_debug_header.next = header;
111 header->next->prev = header;
115 ptr = (Malloc_t)((char*)ptr+sTHX);
117 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
121 #ifndef ALWAYS_NEED_THX
133 /* paranoid version of system's realloc() */
136 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
138 #ifdef ALWAYS_NEED_THX
142 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
143 Malloc_t PerlMem_realloc();
144 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
148 PerlIO_printf(Perl_error_log,
149 "Reallocation too large: %lx\n", size) FLUSH;
152 #endif /* HAS_64K_LIMIT */
159 return safesysmalloc(size);
160 #ifdef PERL_TRACK_MEMPOOL
161 where = (Malloc_t)((char*)where-sTHX);
164 struct perl_memory_debug_header *const header
165 = (struct perl_memory_debug_header *)where;
167 if (header->interpreter != aTHX) {
168 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
169 header->interpreter, aTHX);
171 assert(header->next->prev == header);
172 assert(header->prev->next == header);
174 if (header->size > size) {
175 const MEM_SIZE freed_up = header->size - size;
176 char *start_of_freed = ((char *)where) + size;
177 PoisonFree(start_of_freed, freed_up, char);
184 if ((SSize_t)size < 0)
185 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
187 ptr = (Malloc_t)PerlMem_realloc(where,size);
188 PERL_ALLOC_CHECK(ptr);
190 /* MUST do this fixup first, before doing ANYTHING else, as anything else
191 might allocate memory/free/move memory, and until we do the fixup, it
192 may well be chasing (and writing to) free memory. */
193 #ifdef PERL_TRACK_MEMPOOL
195 struct perl_memory_debug_header *const header
196 = (struct perl_memory_debug_header *)ptr;
199 if (header->size < size) {
200 const MEM_SIZE fresh = size - header->size;
201 char *start_of_fresh = ((char *)ptr) + size;
202 PoisonNew(start_of_fresh, fresh, char);
206 header->next->prev = header;
207 header->prev->next = header;
209 ptr = (Malloc_t)((char*)ptr+sTHX);
213 /* In particular, must do that fixup above before logging anything via
214 *printf(), as it can reallocate memory, which can cause SEGVs. */
216 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
217 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
224 #ifndef ALWAYS_NEED_THX
236 /* safe version of system's free() */
239 Perl_safesysfree(Malloc_t where)
241 #ifdef ALWAYS_NEED_THX
246 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
248 #ifdef PERL_TRACK_MEMPOOL
249 where = (Malloc_t)((char*)where-sTHX);
251 struct perl_memory_debug_header *const header
252 = (struct perl_memory_debug_header *)where;
254 if (header->interpreter != aTHX) {
255 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
256 header->interpreter, aTHX);
259 Perl_croak_nocontext("panic: duplicate free");
262 Perl_croak_nocontext("panic: bad free, header->next==NULL");
263 if (header->next->prev != header || header->prev->next != header) {
264 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
265 "header=%p, ->prev->next=%p",
266 header->next->prev, header,
269 /* Unlink us from the chain. */
270 header->next->prev = header->prev;
271 header->prev->next = header->next;
273 PoisonNew(where, header->size, char);
275 /* Trigger the duplicate free warning. */
283 /* safe version of system's calloc() */
286 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
288 #ifdef ALWAYS_NEED_THX
292 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
293 MEM_SIZE total_size = 0;
296 /* Even though calloc() for zero bytes is strange, be robust. */
297 if (size && (count <= MEM_SIZE_MAX / size)) {
298 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
299 total_size = size * count;
304 #ifdef PERL_TRACK_MEMPOOL
305 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
311 if (total_size > 0xffff) {
312 PerlIO_printf(Perl_error_log,
313 "Allocation too large: %lx\n", total_size) FLUSH;
316 #endif /* HAS_64K_LIMIT */
318 if ((SSize_t)size < 0 || (SSize_t)count < 0)
319 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
320 (UV)size, (UV)count);
322 #ifdef PERL_TRACK_MEMPOOL
323 /* Have to use malloc() because we've added some space for our tracking
325 /* malloc(0) is non-portable. */
326 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
328 /* Use calloc() because it might save a memset() if the memory is fresh
329 and clean from the OS. */
331 ptr = (Malloc_t)PerlMem_calloc(count, size);
332 else /* calloc(0) is non-portable. */
333 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
335 PERL_ALLOC_CHECK(ptr);
336 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));
338 #ifdef PERL_TRACK_MEMPOOL
340 struct perl_memory_debug_header *const header
341 = (struct perl_memory_debug_header *)ptr;
343 memset((void*)ptr, 0, total_size);
344 header->interpreter = aTHX;
345 /* Link us into the list. */
346 header->prev = &PL_memory_debug_header;
347 header->next = PL_memory_debug_header.next;
348 PL_memory_debug_header.next = header;
349 header->next->prev = header;
351 header->size = total_size;
353 ptr = (Malloc_t)((char*)ptr+sTHX);
359 #ifndef ALWAYS_NEED_THX
368 /* These must be defined when not using Perl's malloc for binary
373 Malloc_t Perl_malloc (MEM_SIZE nbytes)
376 return (Malloc_t)PerlMem_malloc(nbytes);
379 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
382 return (Malloc_t)PerlMem_calloc(elements, size);
385 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
388 return (Malloc_t)PerlMem_realloc(where, nbytes);
391 Free_t Perl_mfree (Malloc_t where)
399 /* copy a string up to some (non-backslashed) delimiter, if any */
402 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
406 PERL_ARGS_ASSERT_DELIMCPY;
408 for (tolen = 0; from < fromend; from++, tolen++) {
410 if (from[1] != delim) {
417 else if (*from == delim)
428 /* return ptr to little string in big string, NULL if not found */
429 /* This routine was donated by Corey Satten. */
432 Perl_instr(const char *big, const char *little)
435 PERL_ARGS_ASSERT_INSTR;
437 /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
440 return strstr((char*)big, (char*)little);
443 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond
444 * the final character desired to be checked */
447 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
449 PERL_ARGS_ASSERT_NINSTR;
453 const char first = *little;
455 bigend -= lend - little++;
457 while (big <= bigend) {
458 if (*big++ == first) {
459 for (x=big,s=little; s < lend; x++,s++) {
463 return (char*)(big-1);
470 /* reverse of the above--find last substring */
473 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
476 const I32 first = *little;
477 const char * const littleend = lend;
479 PERL_ARGS_ASSERT_RNINSTR;
481 if (little >= littleend)
482 return (char*)bigend;
484 big = bigend - (littleend - little++);
485 while (big >= bigbeg) {
489 for (x=big+2,s=little; s < littleend; /**/ ) {
498 return (char*)(big+1);
503 /* As a space optimization, we do not compile tables for strings of length
504 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
505 special-cased in fbm_instr().
507 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
510 =head1 Miscellaneous Functions
512 =for apidoc fbm_compile
514 Analyses the string in order to make fast searches on it using fbm_instr()
515 -- the Boyer-Moore algorithm.
521 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
529 PERL_DEB( STRLEN rarest = 0 );
531 PERL_ARGS_ASSERT_FBM_COMPILE;
533 if (isGV_with_GP(sv) || SvROK(sv))
539 if (flags & FBMcf_TAIL) {
540 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
541 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
542 if (mg && mg->mg_len >= 0)
545 if (!SvPOK(sv) || SvNIOKp(sv))
546 s = (U8*)SvPV_force_mutable(sv, len);
547 else s = (U8 *)SvPV_mutable(sv, len);
548 if (len == 0) /* TAIL might be on a zero-length string. */
550 SvUPGRADE(sv, SVt_PVMG);
555 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
556 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
557 to call SvVALID_off() if the scalar was assigned to.
559 The comment itself (and "deeper magic" below) date back to
560 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
562 where the magic (presumably) was that the scalar had a BM table hidden
565 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
566 the table instead of the previous (somewhat hacky) approach of co-opting
567 the string buffer and storing it after the string. */
569 assert(!mg_find(sv, PERL_MAGIC_bm));
570 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
574 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
576 const U8 mlen = (len>255) ? 255 : (U8)len;
577 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
580 Newx(table, 256, U8);
581 memset((void*)table, mlen, 256);
582 mg->mg_ptr = (char *)table;
585 s += len - 1; /* last char */
588 if (table[*s] == mlen)
594 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
595 for (i = 0; i < len; i++) {
596 if (PL_freq[s[i]] < frequency) {
597 PERL_DEB( rarest = i );
598 frequency = PL_freq[s[i]];
601 BmUSEFUL(sv) = 100; /* Initial value */
602 if (flags & FBMcf_TAIL)
604 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
605 s[rarest], (UV)rarest));
608 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
609 /* If SvTAIL is actually due to \Z or \z, this gives false positives
613 =for apidoc fbm_instr
615 Returns the location of the SV in the string delimited by C<big> and
616 C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
617 does not have to be fbm_compiled, but the search will not be as fast
624 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
628 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
629 STRLEN littlelen = l;
630 const I32 multiline = flags & FBMrf_MULTILINE;
632 PERL_ARGS_ASSERT_FBM_INSTR;
634 if ((STRLEN)(bigend - big) < littlelen) {
635 if ( SvTAIL(littlestr)
636 && ((STRLEN)(bigend - big) == littlelen - 1)
638 || (*big == *little &&
639 memEQ((char *)big, (char *)little, littlelen - 1))))
644 switch (littlelen) { /* Special cases for 0, 1 and 2 */
646 return (char*)big; /* Cannot be SvTAIL! */
648 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
649 /* Know that bigend != big. */
650 if (bigend[-1] == '\n')
651 return (char *)(bigend - 1);
652 return (char *) bigend;
660 if (SvTAIL(littlestr))
661 return (char *) bigend;
664 if (SvTAIL(littlestr) && !multiline) {
665 if (bigend[-1] == '\n' && bigend[-2] == *little)
666 return (char*)bigend - 2;
667 if (bigend[-1] == *little)
668 return (char*)bigend - 1;
672 /* This should be better than FBM if c1 == c2, and almost
673 as good otherwise: maybe better since we do less indirection.
674 And we save a lot of memory by caching no table. */
675 const unsigned char c1 = little[0];
676 const unsigned char c2 = little[1];
681 while (s <= bigend) {
691 goto check_1char_anchor;
702 goto check_1char_anchor;
705 while (s <= bigend) {
710 goto check_1char_anchor;
719 check_1char_anchor: /* One char and anchor! */
720 if (SvTAIL(littlestr) && (*bigend == *little))
721 return (char *)bigend; /* bigend is already decremented. */
724 break; /* Only lengths 0 1 and 2 have special-case code. */
727 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
728 s = bigend - littlelen;
729 if (s >= big && bigend[-1] == '\n' && *s == *little
730 /* Automatically of length > 2 */
731 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
733 return (char*)s; /* how sweet it is */
736 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
738 return (char*)s + 1; /* how sweet it is */
742 if (!SvVALID(littlestr)) {
743 char * const b = ninstr((char*)big,(char*)bigend,
744 (char*)little, (char*)little + littlelen);
746 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
747 /* Chop \n from littlestr: */
748 s = bigend - littlelen + 1;
750 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
760 if (littlelen > (STRLEN)(bigend - big))
764 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
765 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
766 const unsigned char *oldlittle;
768 --littlelen; /* Last char found by table lookup */
771 little += littlelen; /* last char */
777 if ((tmp = table[*s])) {
778 if ((s += tmp) < bigend)
782 else { /* less expensive than calling strncmp() */
783 unsigned char * const olds = s;
788 if (*--s == *--little)
790 s = olds + 1; /* here we pay the price for failure */
792 if (s < bigend) /* fake up continue to outer loop */
802 && memEQ((char *)(bigend - littlelen),
803 (char *)(oldlittle - littlelen), littlelen) )
804 return (char*)bigend - littlelen;
810 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
813 PERL_ARGS_ASSERT_SCREAMINSTR;
814 PERL_UNUSED_ARG(bigstr);
815 PERL_UNUSED_ARG(littlestr);
816 PERL_UNUSED_ARG(start_shift);
817 PERL_UNUSED_ARG(end_shift);
818 PERL_UNUSED_ARG(old_posp);
819 PERL_UNUSED_ARG(last);
821 /* This function must only ever be called on a scalar with study magic,
822 but those do not happen any more. */
823 Perl_croak(aTHX_ "panic: screaminstr");
830 Returns true if the leading len bytes of the strings s1 and s2 are the same
831 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
832 match themselves and their opposite case counterparts. Non-cased and non-ASCII
833 range bytes match only themselves.
840 Perl_foldEQ(const char *s1, const char *s2, I32 len)
842 const U8 *a = (const U8 *)s1;
843 const U8 *b = (const U8 *)s2;
845 PERL_ARGS_ASSERT_FOLDEQ;
850 if (*a != *b && *a != PL_fold[*b])
857 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
859 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
860 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
861 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
862 * does it check that the strings each have at least 'len' characters */
864 const U8 *a = (const U8 *)s1;
865 const U8 *b = (const U8 *)s2;
867 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
872 if (*a != *b && *a != PL_fold_latin1[*b]) {
881 =for apidoc foldEQ_locale
883 Returns true if the leading len bytes of the strings s1 and s2 are the same
884 case-insensitively in the current locale; false otherwise.
890 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
893 const U8 *a = (const U8 *)s1;
894 const U8 *b = (const U8 *)s2;
896 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
901 if (*a != *b && *a != PL_fold_locale[*b])
908 /* copy a string to a safe spot */
911 =head1 Memory Management
915 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
916 string which is a duplicate of C<pv>. The size of the string is
917 determined by C<strlen()>. The memory allocated for the new string can
918 be freed with the C<Safefree()> function.
924 Perl_savepv(pTHX_ const char *pv)
931 const STRLEN pvlen = strlen(pv)+1;
932 Newx(newaddr, pvlen, char);
933 return (char*)memcpy(newaddr, pv, pvlen);
937 /* same thing but with a known length */
942 Perl's version of what C<strndup()> would be if it existed. Returns a
943 pointer to a newly allocated string which is a duplicate of the first
944 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
945 the new string can be freed with the C<Safefree()> function.
951 Perl_savepvn(pTHX_ const char *pv, I32 len)
958 Newx(newaddr,len+1,char);
959 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
961 /* might not be null terminated */
963 return (char *) CopyD(pv,newaddr,len,char);
966 return (char *) ZeroD(newaddr,len+1,char);
971 =for apidoc savesharedpv
973 A version of C<savepv()> which allocates the duplicate string in memory
974 which is shared between threads.
979 Perl_savesharedpv(pTHX_ const char *pv)
986 pvlen = strlen(pv)+1;
987 newaddr = (char*)PerlMemShared_malloc(pvlen);
991 return (char*)memcpy(newaddr, pv, pvlen);
995 =for apidoc savesharedpvn
997 A version of C<savepvn()> which allocates the duplicate string in memory
998 which is shared between threads. (With the specific difference that a NULL
999 pointer is not acceptable)
1004 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1006 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1008 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1013 newaddr[len] = '\0';
1014 return (char*)memcpy(newaddr, pv, len);
1018 =for apidoc savesvpv
1020 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1021 the passed in SV using C<SvPV()>
1027 Perl_savesvpv(pTHX_ SV *sv)
1030 const char * const pv = SvPV_const(sv, len);
1033 PERL_ARGS_ASSERT_SAVESVPV;
1036 Newx(newaddr,len,char);
1037 return (char *) CopyD(pv,newaddr,len,char);
1041 =for apidoc savesharedsvpv
1043 A version of C<savesharedpv()> which allocates the duplicate string in
1044 memory which is shared between threads.
1050 Perl_savesharedsvpv(pTHX_ SV *sv)
1053 const char * const pv = SvPV_const(sv, len);
1055 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1057 return savesharedpvn(pv, len);
1060 /* the SV for Perl_form() and mess() is not kept in an arena */
1069 if (PL_phase != PERL_PHASE_DESTRUCT)
1070 return newSVpvs_flags("", SVs_TEMP);
1075 /* Create as PVMG now, to avoid any upgrading later */
1077 Newxz(any, 1, XPVMG);
1078 SvFLAGS(sv) = SVt_PVMG;
1079 SvANY(sv) = (void*)any;
1081 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1086 #if defined(PERL_IMPLICIT_CONTEXT)
1088 Perl_form_nocontext(const char* pat, ...)
1093 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1094 va_start(args, pat);
1095 retval = vform(pat, &args);
1099 #endif /* PERL_IMPLICIT_CONTEXT */
1102 =head1 Miscellaneous Functions
1105 Takes a sprintf-style format pattern and conventional
1106 (non-SV) arguments and returns the formatted string.
1108 (char *) Perl_form(pTHX_ const char* pat, ...)
1110 can be used any place a string (char *) is required:
1112 char * s = Perl_form("%d.%d",major,minor);
1114 Uses a single private buffer so if you want to format several strings you
1115 must explicitly copy the earlier strings away (and free the copies when you
1122 Perl_form(pTHX_ const char* pat, ...)
1126 PERL_ARGS_ASSERT_FORM;
1127 va_start(args, pat);
1128 retval = vform(pat, &args);
1134 Perl_vform(pTHX_ const char *pat, va_list *args)
1136 SV * const sv = mess_alloc();
1137 PERL_ARGS_ASSERT_VFORM;
1138 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1143 =for apidoc Am|SV *|mess|const char *pat|...
1145 Take a sprintf-style format pattern and argument list. These are used to
1146 generate a string message. If the message does not end with a newline,
1147 then it will be extended with some indication of the current location
1148 in the code, as described for L</mess_sv>.
1150 Normally, the resulting message is returned in a new mortal SV.
1151 During global destruction a single SV may be shared between uses of
1157 #if defined(PERL_IMPLICIT_CONTEXT)
1159 Perl_mess_nocontext(const char *pat, ...)
1164 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1165 va_start(args, pat);
1166 retval = vmess(pat, &args);
1170 #endif /* PERL_IMPLICIT_CONTEXT */
1173 Perl_mess(pTHX_ const char *pat, ...)
1177 PERL_ARGS_ASSERT_MESS;
1178 va_start(args, pat);
1179 retval = vmess(pat, &args);
1185 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1189 /* Look for curop starting from o. cop is the last COP we've seen. */
1190 /* opnext means that curop is actually the ->op_next of the op we are
1193 PERL_ARGS_ASSERT_CLOSEST_COP;
1195 if (!o || !curop || (
1196 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1200 if (o->op_flags & OPf_KIDS) {
1202 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1205 /* If the OP_NEXTSTATE has been optimised away we can still use it
1206 * the get the file and line number. */
1208 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1209 cop = (const COP *)kid;
1211 /* Keep searching, and return when we've found something. */
1213 new_cop = closest_cop(cop, kid, curop, opnext);
1219 /* Nothing found. */
1225 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1227 Expands a message, intended for the user, to include an indication of
1228 the current location in the code, if the message does not already appear
1231 C<basemsg> is the initial message or object. If it is a reference, it
1232 will be used as-is and will be the result of this function. Otherwise it
1233 is used as a string, and if it already ends with a newline, it is taken
1234 to be complete, and the result of this function will be the same string.
1235 If the message does not end with a newline, then a segment such as C<at
1236 foo.pl line 37> will be appended, and possibly other clauses indicating
1237 the current state of execution. The resulting message will end with a
1240 Normally, the resulting message is returned in a new mortal SV.
1241 During global destruction a single SV may be shared between uses of this
1242 function. If C<consume> is true, then the function is permitted (but not
1243 required) to modify and return C<basemsg> instead of allocating a new SV.
1249 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1254 PERL_ARGS_ASSERT_MESS_SV;
1256 if (SvROK(basemsg)) {
1262 sv_setsv(sv, basemsg);
1267 if (SvPOK(basemsg) && consume) {
1272 sv_copypv(sv, basemsg);
1275 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1277 * Try and find the file and line for PL_op. This will usually be
1278 * PL_curcop, but it might be a cop that has been optimised away. We
1279 * can try to find such a cop by searching through the optree starting
1280 * from the sibling of PL_curcop.
1284 closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
1289 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1290 OutCopFILE(cop), (IV)CopLINE(cop));
1291 /* Seems that GvIO() can be untrustworthy during global destruction. */
1292 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1293 && IoLINES(GvIOp(PL_last_in_gv)))
1296 const bool line_mode = (RsSIMPLE(PL_rs) &&
1297 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1298 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1299 SVfARG(PL_last_in_gv == PL_argvgv
1301 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1302 line_mode ? "line" : "chunk",
1303 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1305 if (PL_phase == PERL_PHASE_DESTRUCT)
1306 sv_catpvs(sv, " during global destruction");
1307 sv_catpvs(sv, ".\n");
1313 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1315 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1316 argument list. These are used to generate a string message. If the
1317 message does not end with a newline, then it will be extended with
1318 some indication of the current location in the code, as described for
1321 Normally, the resulting message is returned in a new mortal SV.
1322 During global destruction a single SV may be shared between uses of
1329 Perl_vmess(pTHX_ const char *pat, va_list *args)
1332 SV * const sv = mess_alloc();
1334 PERL_ARGS_ASSERT_VMESS;
1336 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1337 return mess_sv(sv, 1);
1341 Perl_write_to_stderr(pTHX_ SV* msv)
1347 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1349 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1350 && (io = GvIO(PL_stderrgv))
1351 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1352 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1353 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1356 /* SFIO can really mess with your errno */
1359 PerlIO * const serr = Perl_error_log;
1361 do_print(msv, serr);
1362 (void)PerlIO_flush(serr);
1370 =head1 Warning and Dieing
1373 /* Common code used in dieing and warning */
1376 S_with_queued_errors(pTHX_ SV *ex)
1378 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1379 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1380 sv_catsv(PL_errors, ex);
1381 ex = sv_mortalcopy(PL_errors);
1382 SvCUR_set(PL_errors, 0);
1388 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1394 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1395 /* sv_2cv might call Perl_croak() or Perl_warner() */
1396 SV * const oldhook = *hook;
1404 cv = sv_2cv(oldhook, &stash, &gv, 0);
1406 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1416 exarg = newSVsv(ex);
1417 SvREADONLY_on(exarg);
1420 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1424 call_sv(MUTABLE_SV(cv), G_DISCARD);
1433 =for apidoc Am|OP *|die_sv|SV *baseex
1435 Behaves the same as L</croak_sv>, except for the return type.
1436 It should be used only where the C<OP *> return type is required.
1437 The function never actually returns.
1443 Perl_die_sv(pTHX_ SV *baseex)
1445 PERL_ARGS_ASSERT_DIE_SV;
1447 assert(0); /* NOTREACHED */
1452 =for apidoc Am|OP *|die|const char *pat|...
1454 Behaves the same as L</croak>, except for the return type.
1455 It should be used only where the C<OP *> return type is required.
1456 The function never actually returns.
1461 #if defined(PERL_IMPLICIT_CONTEXT)
1463 Perl_die_nocontext(const char* pat, ...)
1467 va_start(args, pat);
1469 assert(0); /* NOTREACHED */
1473 #endif /* PERL_IMPLICIT_CONTEXT */
1476 Perl_die(pTHX_ const char* pat, ...)
1479 va_start(args, pat);
1481 assert(0); /* NOTREACHED */
1487 =for apidoc Am|void|croak_sv|SV *baseex
1489 This is an XS interface to Perl's C<die> function.
1491 C<baseex> is the error message or object. If it is a reference, it
1492 will be used as-is. Otherwise it is used as a string, and if it does
1493 not end with a newline then it will be extended with some indication of
1494 the current location in the code, as described for L</mess_sv>.
1496 The error message or object will be used as an exception, by default
1497 returning control to the nearest enclosing C<eval>, but subject to
1498 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1499 function never returns normally.
1501 To die with a simple string message, the L</croak> function may be
1508 Perl_croak_sv(pTHX_ SV *baseex)
1510 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1511 PERL_ARGS_ASSERT_CROAK_SV;
1512 invoke_exception_hook(ex, FALSE);
1517 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1519 This is an XS interface to Perl's C<die> function.
1521 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1522 argument list. These are used to generate a string message. If the
1523 message does not end with a newline, then it will be extended with
1524 some indication of the current location in the code, as described for
1527 The error message will be used as an exception, by default
1528 returning control to the nearest enclosing C<eval>, but subject to
1529 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1530 function never returns normally.
1532 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1533 (C<$@>) will be used as an error message or object instead of building an
1534 error message from arguments. If you want to throw a non-string object,
1535 or build an error message in an SV yourself, it is preferable to use
1536 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1542 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1544 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1545 invoke_exception_hook(ex, FALSE);
1550 =for apidoc Am|void|croak|const char *pat|...
1552 This is an XS interface to Perl's C<die> function.
1554 Take a sprintf-style format pattern and argument list. These are used to
1555 generate a string message. If the message does not end with a newline,
1556 then it will be extended with some indication of the current location
1557 in the code, as described for L</mess_sv>.
1559 The error message will be used as an exception, by default
1560 returning control to the nearest enclosing C<eval>, but subject to
1561 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1562 function never returns normally.
1564 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1565 (C<$@>) will be used as an error message or object instead of building an
1566 error message from arguments. If you want to throw a non-string object,
1567 or build an error message in an SV yourself, it is preferable to use
1568 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1573 #if defined(PERL_IMPLICIT_CONTEXT)
1575 Perl_croak_nocontext(const char *pat, ...)
1579 va_start(args, pat);
1581 assert(0); /* NOTREACHED */
1584 #endif /* PERL_IMPLICIT_CONTEXT */
1587 Perl_croak(pTHX_ const char *pat, ...)
1590 va_start(args, pat);
1592 assert(0); /* NOTREACHED */
1597 =for apidoc Am|void|croak_no_modify
1599 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1600 terser object code than using C<Perl_croak>. Less code used on exception code
1601 paths reduces CPU cache pressure.
1607 Perl_croak_no_modify()
1609 Perl_croak_nocontext( "%s", PL_no_modify);
1612 /* does not return, used in util.c perlio.c and win32.c
1613 This is typically called when malloc returns NULL.
1620 /* Can't use PerlIO to write as it allocates memory */
1621 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1622 PL_no_mem, sizeof(PL_no_mem)-1);
1626 /* does not return, used only in POPSTACK */
1628 Perl_croak_popstack(void)
1631 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1636 =for apidoc Am|void|warn_sv|SV *baseex
1638 This is an XS interface to Perl's C<warn> function.
1640 C<baseex> is the error message or object. If it is a reference, it
1641 will be used as-is. Otherwise it is used as a string, and if it does
1642 not end with a newline then it will be extended with some indication of
1643 the current location in the code, as described for L</mess_sv>.
1645 The error message or object will by default be written to standard error,
1646 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1648 To warn with a simple string message, the L</warn> function may be
1655 Perl_warn_sv(pTHX_ SV *baseex)
1657 SV *ex = mess_sv(baseex, 0);
1658 PERL_ARGS_ASSERT_WARN_SV;
1659 if (!invoke_exception_hook(ex, TRUE))
1660 write_to_stderr(ex);
1664 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1666 This is an XS interface to Perl's C<warn> function.
1668 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1669 argument list. These are used to generate a string message. If the
1670 message does not end with a newline, then it will be extended with
1671 some indication of the current location in the code, as described for
1674 The error message or object will by default be written to standard error,
1675 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1677 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1683 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1685 SV *ex = vmess(pat, args);
1686 PERL_ARGS_ASSERT_VWARN;
1687 if (!invoke_exception_hook(ex, TRUE))
1688 write_to_stderr(ex);
1692 =for apidoc Am|void|warn|const char *pat|...
1694 This is an XS interface to Perl's C<warn> function.
1696 Take a sprintf-style format pattern and argument list. These are used to
1697 generate a string message. If the message does not end with a newline,
1698 then it will be extended with some indication of the current location
1699 in the code, as described for L</mess_sv>.
1701 The error message or object will by default be written to standard error,
1702 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1704 Unlike with L</croak>, C<pat> is not permitted to be null.
1709 #if defined(PERL_IMPLICIT_CONTEXT)
1711 Perl_warn_nocontext(const char *pat, ...)
1715 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1716 va_start(args, pat);
1720 #endif /* PERL_IMPLICIT_CONTEXT */
1723 Perl_warn(pTHX_ const char *pat, ...)
1726 PERL_ARGS_ASSERT_WARN;
1727 va_start(args, pat);
1732 #if defined(PERL_IMPLICIT_CONTEXT)
1734 Perl_warner_nocontext(U32 err, const char *pat, ...)
1738 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1739 va_start(args, pat);
1740 vwarner(err, pat, &args);
1743 #endif /* PERL_IMPLICIT_CONTEXT */
1746 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1748 PERL_ARGS_ASSERT_CK_WARNER_D;
1750 if (Perl_ckwarn_d(aTHX_ err)) {
1752 va_start(args, pat);
1753 vwarner(err, pat, &args);
1759 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1761 PERL_ARGS_ASSERT_CK_WARNER;
1763 if (Perl_ckwarn(aTHX_ err)) {
1765 va_start(args, pat);
1766 vwarner(err, pat, &args);
1772 Perl_warner(pTHX_ U32 err, const char* pat,...)
1775 PERL_ARGS_ASSERT_WARNER;
1776 va_start(args, pat);
1777 vwarner(err, pat, &args);
1782 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1785 PERL_ARGS_ASSERT_VWARNER;
1786 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1787 SV * const msv = vmess(pat, args);
1789 invoke_exception_hook(msv, FALSE);
1793 Perl_vwarn(aTHX_ pat, args);
1797 /* implements the ckWARN? macros */
1800 Perl_ckwarn(pTHX_ U32 w)
1803 /* If lexical warnings have not been set, use $^W. */
1805 return PL_dowarn & G_WARN_ON;
1807 return ckwarn_common(w);
1810 /* implements the ckWARN?_d macro */
1813 Perl_ckwarn_d(pTHX_ U32 w)
1816 /* If lexical warnings have not been set then default classes warn. */
1820 return ckwarn_common(w);
1824 S_ckwarn_common(pTHX_ U32 w)
1826 if (PL_curcop->cop_warnings == pWARN_ALL)
1829 if (PL_curcop->cop_warnings == pWARN_NONE)
1832 /* Check the assumption that at least the first slot is non-zero. */
1833 assert(unpackWARN1(w));
1835 /* Check the assumption that it is valid to stop as soon as a zero slot is
1837 if (!unpackWARN2(w)) {
1838 assert(!unpackWARN3(w));
1839 assert(!unpackWARN4(w));
1840 } else if (!unpackWARN3(w)) {
1841 assert(!unpackWARN4(w));
1844 /* Right, dealt with all the special cases, which are implemented as non-
1845 pointers, so there is a pointer to a real warnings mask. */
1847 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1849 } while (w >>= WARNshift);
1854 /* Set buffer=NULL to get a new one. */
1856 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1858 const MEM_SIZE len_wanted =
1859 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1860 PERL_UNUSED_CONTEXT;
1861 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1864 (specialWARN(buffer) ?
1865 PerlMemShared_malloc(len_wanted) :
1866 PerlMemShared_realloc(buffer, len_wanted));
1868 Copy(bits, (buffer + 1), size, char);
1869 if (size < WARNsize)
1870 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1874 /* since we've already done strlen() for both nam and val
1875 * we can use that info to make things faster than
1876 * sprintf(s, "%s=%s", nam, val)
1878 #define my_setenv_format(s, nam, nlen, val, vlen) \
1879 Copy(nam, s, nlen, char); \
1881 Copy(val, s+(nlen+1), vlen, char); \
1882 *(s+(nlen+1+vlen)) = '\0'
1884 #ifdef USE_ENVIRON_ARRAY
1885 /* VMS' my_setenv() is in vms.c */
1886 #if !defined(WIN32) && !defined(NETWARE)
1888 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1892 /* only parent thread can modify process environment */
1893 if (PL_curinterp == aTHX)
1896 #ifndef PERL_USE_SAFE_PUTENV
1897 if (!PL_use_safe_putenv) {
1898 /* most putenv()s leak, so we manipulate environ directly */
1900 const I32 len = strlen(nam);
1903 /* where does it go? */
1904 for (i = 0; environ[i]; i++) {
1905 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1909 if (environ == PL_origenviron) { /* need we copy environment? */
1915 while (environ[max])
1917 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1918 for (j=0; j<max; j++) { /* copy environment */
1919 const int len = strlen(environ[j]);
1920 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1921 Copy(environ[j], tmpenv[j], len+1, char);
1924 environ = tmpenv; /* tell exec where it is now */
1927 safesysfree(environ[i]);
1928 while (environ[i]) {
1929 environ[i] = environ[i+1];
1934 if (!environ[i]) { /* does not exist yet */
1935 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1936 environ[i+1] = NULL; /* make sure it's null terminated */
1939 safesysfree(environ[i]);
1943 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1944 /* all that work just for this */
1945 my_setenv_format(environ[i], nam, nlen, val, vlen);
1948 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
1949 # if defined(HAS_UNSETENV)
1951 (void)unsetenv(nam);
1953 (void)setenv(nam, val, 1);
1955 # else /* ! HAS_UNSETENV */
1956 (void)setenv(nam, val, 1);
1957 # endif /* HAS_UNSETENV */
1959 # if defined(HAS_UNSETENV)
1961 if (environ) /* old glibc can crash with null environ */
1962 (void)unsetenv(nam);
1964 const int nlen = strlen(nam);
1965 const int vlen = strlen(val);
1966 char * const new_env =
1967 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1968 my_setenv_format(new_env, nam, nlen, val, vlen);
1969 (void)putenv(new_env);
1971 # else /* ! HAS_UNSETENV */
1973 const int nlen = strlen(nam);
1979 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1980 /* all that work just for this */
1981 my_setenv_format(new_env, nam, nlen, val, vlen);
1982 (void)putenv(new_env);
1983 # endif /* HAS_UNSETENV */
1984 # endif /* __CYGWIN__ */
1985 #ifndef PERL_USE_SAFE_PUTENV
1991 #else /* WIN32 || NETWARE */
1994 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1998 const int nlen = strlen(nam);
2005 Newx(envstr, nlen+vlen+2, char);
2006 my_setenv_format(envstr, nam, nlen, val, vlen);
2007 (void)PerlEnv_putenv(envstr);
2011 #endif /* WIN32 || NETWARE */
2015 #ifdef UNLINK_ALL_VERSIONS
2017 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2021 PERL_ARGS_ASSERT_UNLNK;
2023 while (PerlLIO_unlink(f) >= 0)
2025 return retries ? 0 : -1;
2029 /* this is a drop-in replacement for bcopy() */
2030 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2032 Perl_my_bcopy(const char *from, char *to, I32 len)
2034 char * const retval = to;
2036 PERL_ARGS_ASSERT_MY_BCOPY;
2040 if (from - to >= 0) {
2048 *(--to) = *(--from);
2054 /* this is a drop-in replacement for memset() */
2057 Perl_my_memset(char *loc, I32 ch, I32 len)
2059 char * const retval = loc;
2061 PERL_ARGS_ASSERT_MY_MEMSET;
2071 /* this is a drop-in replacement for bzero() */
2072 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2074 Perl_my_bzero(char *loc, I32 len)
2076 char * const retval = loc;
2078 PERL_ARGS_ASSERT_MY_BZERO;
2088 /* this is a drop-in replacement for memcmp() */
2089 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2091 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2093 const U8 *a = (const U8 *)s1;
2094 const U8 *b = (const U8 *)s2;
2097 PERL_ARGS_ASSERT_MY_MEMCMP;
2102 if ((tmp = *a++ - *b++))
2107 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2110 /* This vsprintf replacement should generally never get used, since
2111 vsprintf was available in both System V and BSD 2.11. (There may
2112 be some cross-compilation or embedded set-ups where it is needed,
2115 If you encounter a problem in this function, it's probably a symptom
2116 that Configure failed to detect your system's vprintf() function.
2117 See the section on "item vsprintf" in the INSTALL file.
2119 This version may compile on systems with BSD-ish <stdio.h>,
2120 but probably won't on others.
2123 #ifdef USE_CHAR_VSPRINTF
2128 vsprintf(char *dest, const char *pat, void *args)
2132 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2133 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2134 FILE_cnt(&fakebuf) = 32767;
2136 /* These probably won't compile -- If you really need
2137 this, you'll have to figure out some other method. */
2138 fakebuf._ptr = dest;
2139 fakebuf._cnt = 32767;
2144 fakebuf._flag = _IOWRT|_IOSTRG;
2145 _doprnt(pat, args, &fakebuf); /* what a kludge */
2146 #if defined(STDIO_PTR_LVALUE)
2147 *(FILE_ptr(&fakebuf)++) = '\0';
2149 /* PerlIO has probably #defined away fputc, but we want it here. */
2151 # undef fputc /* XXX Should really restore it later */
2153 (void)fputc('\0', &fakebuf);
2155 #ifdef USE_CHAR_VSPRINTF
2158 return 0; /* perl doesn't use return value */
2162 #endif /* HAS_VPRINTF */
2165 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2167 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2176 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2178 PERL_FLUSHALL_FOR_CHILD;
2179 This = (*mode == 'w');
2183 taint_proper("Insecure %s%s", "EXEC");
2185 if (PerlProc_pipe(p) < 0)
2187 /* Try for another pipe pair for error return */
2188 if (PerlProc_pipe(pp) >= 0)
2190 while ((pid = PerlProc_fork()) < 0) {
2191 if (errno != EAGAIN) {
2192 PerlLIO_close(p[This]);
2193 PerlLIO_close(p[that]);
2195 PerlLIO_close(pp[0]);
2196 PerlLIO_close(pp[1]);
2200 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2209 /* Close parent's end of error status pipe (if any) */
2211 PerlLIO_close(pp[0]);
2212 #if defined(HAS_FCNTL) && defined(F_SETFD)
2213 /* Close error pipe automatically if exec works */
2214 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2217 /* Now dup our end of _the_ pipe to right position */
2218 if (p[THIS] != (*mode == 'r')) {
2219 PerlLIO_dup2(p[THIS], *mode == 'r');
2220 PerlLIO_close(p[THIS]);
2221 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2222 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2225 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2226 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2227 /* No automatic close - do it by hand */
2234 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2240 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2246 do_execfree(); /* free any memory malloced by child on fork */
2248 PerlLIO_close(pp[1]);
2249 /* Keep the lower of the two fd numbers */
2250 if (p[that] < p[This]) {
2251 PerlLIO_dup2(p[This], p[that]);
2252 PerlLIO_close(p[This]);
2256 PerlLIO_close(p[that]); /* close child's end of pipe */
2258 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2259 SvUPGRADE(sv,SVt_IV);
2261 PL_forkprocess = pid;
2262 /* If we managed to get status pipe check for exec fail */
2263 if (did_pipes && pid > 0) {
2268 while (n < sizeof(int)) {
2269 n1 = PerlLIO_read(pp[0],
2270 (void*)(((char*)&errkid)+n),
2276 PerlLIO_close(pp[0]);
2278 if (n) { /* Error */
2280 PerlLIO_close(p[This]);
2281 if (n != sizeof(int))
2282 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2284 pid2 = wait4pid(pid, &status, 0);
2285 } while (pid2 == -1 && errno == EINTR);
2286 errno = errkid; /* Propagate errno from kid */
2291 PerlLIO_close(pp[0]);
2292 return PerlIO_fdopen(p[This], mode);
2294 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2295 return my_syspopen4(aTHX_ NULL, mode, n, args);
2297 Perl_croak(aTHX_ "List form of piped open not implemented");
2298 return (PerlIO *) NULL;
2303 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2304 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2306 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2313 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2317 PERL_ARGS_ASSERT_MY_POPEN;
2319 PERL_FLUSHALL_FOR_CHILD;
2322 return my_syspopen(aTHX_ cmd,mode);
2325 This = (*mode == 'w');
2327 if (doexec && TAINTING_get) {
2329 taint_proper("Insecure %s%s", "EXEC");
2331 if (PerlProc_pipe(p) < 0)
2333 if (doexec && PerlProc_pipe(pp) >= 0)
2335 while ((pid = PerlProc_fork()) < 0) {
2336 if (errno != EAGAIN) {
2337 PerlLIO_close(p[This]);
2338 PerlLIO_close(p[that]);
2340 PerlLIO_close(pp[0]);
2341 PerlLIO_close(pp[1]);
2344 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2347 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2357 PerlLIO_close(pp[0]);
2358 #if defined(HAS_FCNTL) && defined(F_SETFD)
2359 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2362 if (p[THIS] != (*mode == 'r')) {
2363 PerlLIO_dup2(p[THIS], *mode == 'r');
2364 PerlLIO_close(p[THIS]);
2365 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2366 PerlLIO_close(p[THAT]);
2369 PerlLIO_close(p[THAT]);
2372 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2379 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2384 /* may or may not use the shell */
2385 do_exec3(cmd, pp[1], did_pipes);
2388 #endif /* defined OS2 */
2390 #ifdef PERLIO_USING_CRLF
2391 /* Since we circumvent IO layers when we manipulate low-level
2392 filedescriptors directly, need to manually switch to the
2393 default, binary, low-level mode; see PerlIOBuf_open(). */
2394 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2397 #ifdef PERL_USES_PL_PIDSTATUS
2398 hv_clear(PL_pidstatus); /* we have no children */
2404 do_execfree(); /* free any memory malloced by child on vfork */
2406 PerlLIO_close(pp[1]);
2407 if (p[that] < p[This]) {
2408 PerlLIO_dup2(p[This], p[that]);
2409 PerlLIO_close(p[This]);
2413 PerlLIO_close(p[that]);
2415 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2416 SvUPGRADE(sv,SVt_IV);
2418 PL_forkprocess = pid;
2419 if (did_pipes && pid > 0) {
2424 while (n < sizeof(int)) {
2425 n1 = PerlLIO_read(pp[0],
2426 (void*)(((char*)&errkid)+n),
2432 PerlLIO_close(pp[0]);
2434 if (n) { /* Error */
2436 PerlLIO_close(p[This]);
2437 if (n != sizeof(int))
2438 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2440 pid2 = wait4pid(pid, &status, 0);
2441 } while (pid2 == -1 && errno == EINTR);
2442 errno = errkid; /* Propagate errno from kid */
2447 PerlLIO_close(pp[0]);
2448 return PerlIO_fdopen(p[This], mode);
2452 FILE *djgpp_popen();
2454 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2456 PERL_FLUSHALL_FOR_CHILD;
2457 /* Call system's popen() to get a FILE *, then import it.
2458 used 0 for 2nd parameter to PerlIO_importFILE;
2461 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2464 #if defined(__LIBCATAMOUNT__)
2466 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2473 #endif /* !DOSISH */
2475 /* this is called in parent before the fork() */
2477 Perl_atfork_lock(void)
2480 #if defined(USE_ITHREADS)
2481 /* locks must be held in locking order (if any) */
2483 MUTEX_LOCK(&PL_perlio_mutex);
2486 MUTEX_LOCK(&PL_malloc_mutex);
2492 /* this is called in both parent and child after the fork() */
2494 Perl_atfork_unlock(void)
2497 #if defined(USE_ITHREADS)
2498 /* locks must be released in same order as in atfork_lock() */
2500 MUTEX_UNLOCK(&PL_perlio_mutex);
2503 MUTEX_UNLOCK(&PL_malloc_mutex);
2512 #if defined(HAS_FORK)
2514 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2519 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2520 * handlers elsewhere in the code */
2525 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2526 Perl_croak_nocontext("fork() not available");
2528 #endif /* HAS_FORK */
2533 Perl_dump_fds(pTHX_ const char *const s)
2538 PERL_ARGS_ASSERT_DUMP_FDS;
2540 PerlIO_printf(Perl_debug_log,"%s", s);
2541 for (fd = 0; fd < 32; fd++) {
2542 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2543 PerlIO_printf(Perl_debug_log," %d",fd);
2545 PerlIO_printf(Perl_debug_log,"\n");
2548 #endif /* DUMP_FDS */
2552 dup2(int oldfd, int newfd)
2554 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2557 PerlLIO_close(newfd);
2558 return fcntl(oldfd, F_DUPFD, newfd);
2560 #define DUP2_MAX_FDS 256
2561 int fdtmp[DUP2_MAX_FDS];
2567 PerlLIO_close(newfd);
2568 /* good enough for low fd's... */
2569 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2570 if (fdx >= DUP2_MAX_FDS) {
2578 PerlLIO_close(fdtmp[--fdx]);
2585 #ifdef HAS_SIGACTION
2588 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2591 struct sigaction act, oact;
2594 /* only "parent" interpreter can diddle signals */
2595 if (PL_curinterp != aTHX)
2596 return (Sighandler_t) SIG_ERR;
2599 act.sa_handler = (void(*)(int))handler;
2600 sigemptyset(&act.sa_mask);
2603 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2604 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2606 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2607 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2608 act.sa_flags |= SA_NOCLDWAIT;
2610 if (sigaction(signo, &act, &oact) == -1)
2611 return (Sighandler_t) SIG_ERR;
2613 return (Sighandler_t) oact.sa_handler;
2617 Perl_rsignal_state(pTHX_ int signo)
2619 struct sigaction oact;
2620 PERL_UNUSED_CONTEXT;
2622 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2623 return (Sighandler_t) SIG_ERR;
2625 return (Sighandler_t) oact.sa_handler;
2629 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2632 struct sigaction act;
2634 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2637 /* only "parent" interpreter can diddle signals */
2638 if (PL_curinterp != aTHX)
2642 act.sa_handler = (void(*)(int))handler;
2643 sigemptyset(&act.sa_mask);
2646 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2647 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2649 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2650 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2651 act.sa_flags |= SA_NOCLDWAIT;
2653 return sigaction(signo, &act, save);
2657 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2661 /* only "parent" interpreter can diddle signals */
2662 if (PL_curinterp != aTHX)
2666 return sigaction(signo, save, (struct sigaction *)NULL);
2669 #else /* !HAS_SIGACTION */
2672 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2674 #if defined(USE_ITHREADS) && !defined(WIN32)
2675 /* only "parent" interpreter can diddle signals */
2676 if (PL_curinterp != aTHX)
2677 return (Sighandler_t) SIG_ERR;
2680 return PerlProc_signal(signo, handler);
2691 Perl_rsignal_state(pTHX_ int signo)
2694 Sighandler_t oldsig;
2696 #if defined(USE_ITHREADS) && !defined(WIN32)
2697 /* only "parent" interpreter can diddle signals */
2698 if (PL_curinterp != aTHX)
2699 return (Sighandler_t) SIG_ERR;
2703 oldsig = PerlProc_signal(signo, sig_trap);
2704 PerlProc_signal(signo, oldsig);
2706 PerlProc_kill(PerlProc_getpid(), signo);
2711 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2713 #if defined(USE_ITHREADS) && !defined(WIN32)
2714 /* only "parent" interpreter can diddle signals */
2715 if (PL_curinterp != aTHX)
2718 *save = PerlProc_signal(signo, handler);
2719 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2723 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2725 #if defined(USE_ITHREADS) && !defined(WIN32)
2726 /* only "parent" interpreter can diddle signals */
2727 if (PL_curinterp != aTHX)
2730 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2733 #endif /* !HAS_SIGACTION */
2734 #endif /* !PERL_MICRO */
2736 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2737 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2739 Perl_my_pclose(pTHX_ PerlIO *ptr)
2748 const int fd = PerlIO_fileno(ptr);
2751 /* Find out whether the refcount is low enough for us to wait for the
2752 child proc without blocking. */
2753 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
2755 const bool should_wait = 1;
2758 svp = av_fetch(PL_fdpid,fd,TRUE);
2759 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2763 if (pid == -1) { /* Opened by popen. */
2764 return my_syspclose(ptr);
2767 close_failed = (PerlIO_close(ptr) == EOF);
2769 if (should_wait) do {
2770 pid2 = wait4pid(pid, &status, 0);
2771 } while (pid2 == -1 && errno == EINTR);
2778 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2783 #if defined(__LIBCATAMOUNT__)
2785 Perl_my_pclose(pTHX_ PerlIO *ptr)
2790 #endif /* !DOSISH */
2792 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2794 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2798 PERL_ARGS_ASSERT_WAIT4PID;
2801 #ifdef PERL_USES_PL_PIDSTATUS
2804 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2805 pid, rather than a string form. */
2806 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2807 if (svp && *svp != &PL_sv_undef) {
2808 *statusp = SvIVX(*svp);
2809 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2817 hv_iterinit(PL_pidstatus);
2818 if ((entry = hv_iternext(PL_pidstatus))) {
2819 SV * const sv = hv_iterval(PL_pidstatus,entry);
2821 const char * const spid = hv_iterkey(entry,&len);
2823 assert (len == sizeof(Pid_t));
2824 memcpy((char *)&pid, spid, len);
2825 *statusp = SvIVX(sv);
2826 /* The hash iterator is currently on this entry, so simply
2827 calling hv_delete would trigger the lazy delete, which on
2828 aggregate does more work, beacuse next call to hv_iterinit()
2829 would spot the flag, and have to call the delete routine,
2830 while in the meantime any new entries can't re-use that
2832 hv_iterinit(PL_pidstatus);
2833 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2840 # ifdef HAS_WAITPID_RUNTIME
2841 if (!HAS_WAITPID_RUNTIME)
2844 result = PerlProc_waitpid(pid,statusp,flags);
2847 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2848 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2851 #ifdef PERL_USES_PL_PIDSTATUS
2852 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2857 Perl_croak(aTHX_ "Can't do waitpid with flags");
2859 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2860 pidgone(result,*statusp);
2866 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2869 if (result < 0 && errno == EINTR) {
2871 errno = EINTR; /* reset in case a signal handler changed $! */
2875 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2877 #ifdef PERL_USES_PL_PIDSTATUS
2879 S_pidgone(pTHX_ Pid_t pid, int status)
2883 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2884 SvUPGRADE(sv,SVt_IV);
2885 SvIV_set(sv, status);
2893 int /* Cannot prototype with I32
2895 my_syspclose(PerlIO *ptr)
2898 Perl_my_pclose(pTHX_ PerlIO *ptr)
2901 /* Needs work for PerlIO ! */
2902 FILE * const f = PerlIO_findFILE(ptr);
2903 const I32 result = pclose(f);
2904 PerlIO_releaseFILE(ptr,f);
2912 Perl_my_pclose(pTHX_ PerlIO *ptr)
2914 /* Needs work for PerlIO ! */
2915 FILE * const f = PerlIO_findFILE(ptr);
2916 I32 result = djgpp_pclose(f);
2917 result = (result << 8) & 0xff00;
2918 PerlIO_releaseFILE(ptr,f);
2923 #define PERL_REPEATCPY_LINEAR 4
2925 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2927 PERL_ARGS_ASSERT_REPEATCPY;
2932 croak_memory_wrap();
2935 memset(to, *from, count);
2938 IV items, linear, half;
2940 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2941 for (items = 0; items < linear; ++items) {
2942 const char *q = from;
2944 for (todo = len; todo > 0; todo--)
2949 while (items <= half) {
2950 IV size = items * len;
2951 memcpy(p, to, size);
2957 memcpy(p, to, (count - items) * len);
2963 Perl_same_dirent(pTHX_ const char *a, const char *b)
2965 char *fa = strrchr(a,'/');
2966 char *fb = strrchr(b,'/');
2969 SV * const tmpsv = sv_newmortal();
2971 PERL_ARGS_ASSERT_SAME_DIRENT;
2984 sv_setpvs(tmpsv, ".");
2986 sv_setpvn(tmpsv, a, fa - a);
2987 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2990 sv_setpvs(tmpsv, ".");
2992 sv_setpvn(tmpsv, b, fb - b);
2993 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2995 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2996 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2998 #endif /* !HAS_RENAME */
3001 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3002 const char *const *const search_ext, I32 flags)
3005 const char *xfound = NULL;
3006 char *xfailed = NULL;
3007 char tmpbuf[MAXPATHLEN];
3012 #if defined(DOSISH) && !defined(OS2)
3013 # define SEARCH_EXTS ".bat", ".cmd", NULL
3014 # define MAX_EXT_LEN 4
3017 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3018 # define MAX_EXT_LEN 4
3021 # define SEARCH_EXTS ".pl", ".com", NULL
3022 # define MAX_EXT_LEN 4
3024 /* additional extensions to try in each dir if scriptname not found */
3026 static const char *const exts[] = { SEARCH_EXTS };
3027 const char *const *const ext = search_ext ? search_ext : exts;
3028 int extidx = 0, i = 0;
3029 const char *curext = NULL;
3031 PERL_UNUSED_ARG(search_ext);
3032 # define MAX_EXT_LEN 0
3035 PERL_ARGS_ASSERT_FIND_SCRIPT;
3038 * If dosearch is true and if scriptname does not contain path
3039 * delimiters, search the PATH for scriptname.
3041 * If SEARCH_EXTS is also defined, will look for each
3042 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3043 * while searching the PATH.
3045 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3046 * proceeds as follows:
3047 * If DOSISH or VMSISH:
3048 * + look for ./scriptname{,.foo,.bar}
3049 * + search the PATH for scriptname{,.foo,.bar}
3052 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3053 * this will not look in '.' if it's not in the PATH)
3058 # ifdef ALWAYS_DEFTYPES
3059 len = strlen(scriptname);
3060 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3061 int idx = 0, deftypes = 1;
3064 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3067 int idx = 0, deftypes = 1;
3070 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3072 /* The first time through, just add SEARCH_EXTS to whatever we
3073 * already have, so we can check for default file types. */
3075 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3081 if ((strlen(tmpbuf) + strlen(scriptname)
3082 + MAX_EXT_LEN) >= sizeof tmpbuf)
3083 continue; /* don't search dir with too-long name */
3084 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3088 if (strEQ(scriptname, "-"))
3090 if (dosearch) { /* Look in '.' first. */
3091 const char *cur = scriptname;
3093 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3095 if (strEQ(ext[i++],curext)) {
3096 extidx = -1; /* already has an ext */
3101 DEBUG_p(PerlIO_printf(Perl_debug_log,
3102 "Looking for %s\n",cur));
3103 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3104 && !S_ISDIR(PL_statbuf.st_mode)) {
3112 if (cur == scriptname) {
3113 len = strlen(scriptname);
3114 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3116 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3119 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3120 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3125 if (dosearch && !strchr(scriptname, '/')
3127 && !strchr(scriptname, '\\')
3129 && (s = PerlEnv_getenv("PATH")))
3133 bufend = s + strlen(s);
3134 while (s < bufend) {
3137 && *s != ';'; len++, s++) {
3138 if (len < sizeof tmpbuf)
3141 if (len < sizeof tmpbuf)
3144 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3150 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3151 continue; /* don't search dir with too-long name */
3154 && tmpbuf[len - 1] != '/'
3155 && tmpbuf[len - 1] != '\\'
3158 tmpbuf[len++] = '/';
3159 if (len == 2 && tmpbuf[0] == '.')
3161 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3165 len = strlen(tmpbuf);
3166 if (extidx > 0) /* reset after previous loop */
3170 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3171 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3172 if (S_ISDIR(PL_statbuf.st_mode)) {
3176 } while ( retval < 0 /* not there */
3177 && extidx>=0 && ext[extidx] /* try an extension? */
3178 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3183 if (S_ISREG(PL_statbuf.st_mode)
3184 && cando(S_IRUSR,TRUE,&PL_statbuf)
3185 #if !defined(DOSISH)
3186 && cando(S_IXUSR,TRUE,&PL_statbuf)
3190 xfound = tmpbuf; /* bingo! */
3194 xfailed = savepv(tmpbuf);
3197 if (!xfound && !seen_dot && !xfailed &&
3198 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3199 || S_ISDIR(PL_statbuf.st_mode)))
3201 seen_dot = 1; /* Disable message. */
3203 if (flags & 1) { /* do or die? */
3204 /* diag_listed_as: Can't execute %s */
3205 Perl_croak(aTHX_ "Can't %s %s%s%s",
3206 (xfailed ? "execute" : "find"),
3207 (xfailed ? xfailed : scriptname),
3208 (xfailed ? "" : " on PATH"),
3209 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3214 scriptname = xfound;
3216 return (scriptname ? savepv(scriptname) : NULL);
3219 #ifndef PERL_GET_CONTEXT_DEFINED
3222 Perl_get_context(void)
3225 #if defined(USE_ITHREADS)
3226 # ifdef OLD_PTHREADS_API
3228 int error = pthread_getspecific(PL_thr_key, &t)
3230 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3233 # ifdef I_MACH_CTHREADS
3234 return (void*)cthread_data(cthread_self());
3236 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3245 Perl_set_context(void *t)
3248 PERL_ARGS_ASSERT_SET_CONTEXT;
3249 #if defined(USE_ITHREADS)
3250 # ifdef I_MACH_CTHREADS
3251 cthread_set_data(cthread_self(), t);
3254 const int error = pthread_setspecific(PL_thr_key, t);
3256 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3264 #endif /* !PERL_GET_CONTEXT_DEFINED */
3266 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3275 Perl_get_op_names(pTHX)
3277 PERL_UNUSED_CONTEXT;
3278 return (char **)PL_op_name;
3282 Perl_get_op_descs(pTHX)
3284 PERL_UNUSED_CONTEXT;
3285 return (char **)PL_op_desc;
3289 Perl_get_no_modify(pTHX)
3291 PERL_UNUSED_CONTEXT;
3292 return PL_no_modify;
3296 Perl_get_opargs(pTHX)
3298 PERL_UNUSED_CONTEXT;
3299 return (U32 *)PL_opargs;
3303 Perl_get_ppaddr(pTHX)
3306 PERL_UNUSED_CONTEXT;
3307 return (PPADDR_t*)PL_ppaddr;
3310 #ifndef HAS_GETENV_LEN
3312 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3314 char * const env_trans = PerlEnv_getenv(env_elem);
3315 PERL_UNUSED_CONTEXT;
3316 PERL_ARGS_ASSERT_GETENV_LEN;
3318 *len = strlen(env_trans);
3325 Perl_get_vtbl(pTHX_ int vtbl_id)
3327 PERL_UNUSED_CONTEXT;
3329 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3330 ? NULL : PL_magic_vtables + vtbl_id;
3334 Perl_my_fflush_all(pTHX)
3336 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3337 return PerlIO_flush(NULL);
3339 # if defined(HAS__FWALK)
3340 extern int fflush(FILE *);
3341 /* undocumented, unprototyped, but very useful BSDism */
3342 extern void _fwalk(int (*)(FILE *));
3346 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3348 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3349 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3351 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3352 open_max = sysconf(_SC_OPEN_MAX);
3355 open_max = FOPEN_MAX;
3358 open_max = OPEN_MAX;
3369 for (i = 0; i < open_max; i++)
3370 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3371 STDIO_STREAM_ARRAY[i]._file < open_max &&
3372 STDIO_STREAM_ARRAY[i]._flag)
3373 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3377 SETERRNO(EBADF,RMS_IFI);
3384 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3386 if (ckWARN(WARN_IO)) {
3388 = gv && (isGV_with_GP(gv))
3391 const char * const direction = have == '>' ? "out" : "in";
3393 if (name && HEK_LEN(name))
3394 Perl_warner(aTHX_ packWARN(WARN_IO),
3395 "Filehandle %"HEKf" opened only for %sput",
3398 Perl_warner(aTHX_ packWARN(WARN_IO),
3399 "Filehandle opened only for %sput", direction);
3404 Perl_report_evil_fh(pTHX_ const GV *gv)
3406 const IO *io = gv ? GvIO(gv) : NULL;
3407 const PERL_BITFIELD16 op = PL_op->op_type;
3411 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3413 warn_type = WARN_CLOSED;
3417 warn_type = WARN_UNOPENED;
3420 if (ckWARN(warn_type)) {
3422 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3423 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3424 const char * const pars =
3425 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3426 const char * const func =
3428 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3429 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3431 const char * const type =
3433 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3434 ? "socket" : "filehandle");
3435 const bool have_name = name && SvCUR(name);
3436 Perl_warner(aTHX_ packWARN(warn_type),
3437 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3438 have_name ? " " : "",
3439 SVfARG(have_name ? name : &PL_sv_no));
3440 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3442 aTHX_ packWARN(warn_type),
3443 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3444 func, pars, have_name ? " " : "",
3445 SVfARG(have_name ? name : &PL_sv_no)
3450 /* To workaround core dumps from the uninitialised tm_zone we get the
3451 * system to give us a reasonable struct to copy. This fix means that
3452 * strftime uses the tm_zone and tm_gmtoff values returned by
3453 * localtime(time()). That should give the desired result most of the
3454 * time. But probably not always!
3456 * This does not address tzname aspects of NETaa14816.
3461 # ifndef STRUCT_TM_HASZONE
3462 # define STRUCT_TM_HASZONE
3466 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3467 # ifndef HAS_TM_TM_ZONE
3468 # define HAS_TM_TM_ZONE
3473 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3475 #ifdef HAS_TM_TM_ZONE
3477 const struct tm* my_tm;
3478 PERL_ARGS_ASSERT_INIT_TM;
3480 my_tm = localtime(&now);
3482 Copy(my_tm, ptm, 1, struct tm);
3484 PERL_ARGS_ASSERT_INIT_TM;
3485 PERL_UNUSED_ARG(ptm);
3490 * mini_mktime - normalise struct tm values without the localtime()
3491 * semantics (and overhead) of mktime().
3494 Perl_mini_mktime(pTHX_ struct tm *ptm)
3498 int month, mday, year, jday;
3499 int odd_cent, odd_year;
3500 PERL_UNUSED_CONTEXT;
3502 PERL_ARGS_ASSERT_MINI_MKTIME;
3504 #define DAYS_PER_YEAR 365
3505 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3506 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3507 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3508 #define SECS_PER_HOUR (60*60)
3509 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3510 /* parentheses deliberately absent on these two, otherwise they don't work */
3511 #define MONTH_TO_DAYS 153/5
3512 #define DAYS_TO_MONTH 5/153
3513 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3514 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3515 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3516 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3519 * Year/day algorithm notes:
3521 * With a suitable offset for numeric value of the month, one can find
3522 * an offset into the year by considering months to have 30.6 (153/5) days,
3523 * using integer arithmetic (i.e., with truncation). To avoid too much
3524 * messing about with leap days, we consider January and February to be
3525 * the 13th and 14th month of the previous year. After that transformation,
3526 * we need the month index we use to be high by 1 from 'normal human' usage,
3527 * so the month index values we use run from 4 through 15.
3529 * Given that, and the rules for the Gregorian calendar (leap years are those
3530 * divisible by 4 unless also divisible by 100, when they must be divisible
3531 * by 400 instead), we can simply calculate the number of days since some
3532 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3533 * the days we derive from our month index, and adding in the day of the
3534 * month. The value used here is not adjusted for the actual origin which
3535 * it normally would use (1 January A.D. 1), since we're not exposing it.
3536 * We're only building the value so we can turn around and get the
3537 * normalised values for the year, month, day-of-month, and day-of-year.
3539 * For going backward, we need to bias the value we're using so that we find
3540 * the right year value. (Basically, we don't want the contribution of
3541 * March 1st to the number to apply while deriving the year). Having done
3542 * that, we 'count up' the contribution to the year number by accounting for
3543 * full quadracenturies (400-year periods) with their extra leap days, plus
3544 * the contribution from full centuries (to avoid counting in the lost leap
3545 * days), plus the contribution from full quad-years (to count in the normal
3546 * leap days), plus the leftover contribution from any non-leap years.
3547 * At this point, if we were working with an actual leap day, we'll have 0
3548 * days left over. This is also true for March 1st, however. So, we have
3549 * to special-case that result, and (earlier) keep track of the 'odd'
3550 * century and year contributions. If we got 4 extra centuries in a qcent,
3551 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3552 * Otherwise, we add back in the earlier bias we removed (the 123 from
3553 * figuring in March 1st), find the month index (integer division by 30.6),
3554 * and the remainder is the day-of-month. We then have to convert back to
3555 * 'real' months (including fixing January and February from being 14/15 in
3556 * the previous year to being in the proper year). After that, to get
3557 * tm_yday, we work with the normalised year and get a new yearday value for
3558 * January 1st, which we subtract from the yearday value we had earlier,
3559 * representing the date we've re-built. This is done from January 1
3560 * because tm_yday is 0-origin.
3562 * Since POSIX time routines are only guaranteed to work for times since the
3563 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3564 * applies Gregorian calendar rules even to dates before the 16th century
3565 * doesn't bother me. Besides, you'd need cultural context for a given
3566 * date to know whether it was Julian or Gregorian calendar, and that's
3567 * outside the scope for this routine. Since we convert back based on the
3568 * same rules we used to build the yearday, you'll only get strange results
3569 * for input which needed normalising, or for the 'odd' century years which
3570 * were leap years in the Julian calendar but not in the Gregorian one.
3571 * I can live with that.
3573 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3574 * that's still outside the scope for POSIX time manipulation, so I don't
3578 year = 1900 + ptm->tm_year;
3579 month = ptm->tm_mon;
3580 mday = ptm->tm_mday;
3586 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3587 yearday += month*MONTH_TO_DAYS + mday + jday;
3589 * Note that we don't know when leap-seconds were or will be,
3590 * so we have to trust the user if we get something which looks
3591 * like a sensible leap-second. Wild values for seconds will
3592 * be rationalised, however.
3594 if ((unsigned) ptm->tm_sec <= 60) {
3601 secs += 60 * ptm->tm_min;
3602 secs += SECS_PER_HOUR * ptm->tm_hour;
3604 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3605 /* got negative remainder, but need positive time */
3606 /* back off an extra day to compensate */
3607 yearday += (secs/SECS_PER_DAY)-1;
3608 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3611 yearday += (secs/SECS_PER_DAY);
3612 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3615 else if (secs >= SECS_PER_DAY) {
3616 yearday += (secs/SECS_PER_DAY);
3617 secs %= SECS_PER_DAY;
3619 ptm->tm_hour = secs/SECS_PER_HOUR;
3620 secs %= SECS_PER_HOUR;
3621 ptm->tm_min = secs/60;
3623 ptm->tm_sec += secs;
3624 /* done with time of day effects */
3626 * The algorithm for yearday has (so far) left it high by 428.
3627 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3628 * bias it by 123 while trying to figure out what year it
3629 * really represents. Even with this tweak, the reverse
3630 * translation fails for years before A.D. 0001.
3631 * It would still fail for Feb 29, but we catch that one below.
3633 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3634 yearday -= YEAR_ADJUST;
3635 year = (yearday / DAYS_PER_QCENT) * 400;
3636 yearday %= DAYS_PER_QCENT;
3637 odd_cent = yearday / DAYS_PER_CENT;
3638 year += odd_cent * 100;
3639 yearday %= DAYS_PER_CENT;
3640 year += (yearday / DAYS_PER_QYEAR) * 4;
3641 yearday %= DAYS_PER_QYEAR;
3642 odd_year = yearday / DAYS_PER_YEAR;
3644 yearday %= DAYS_PER_YEAR;
3645 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3650 yearday += YEAR_ADJUST; /* recover March 1st crock */
3651 month = yearday*DAYS_TO_MONTH;
3652 yearday -= month*MONTH_TO_DAYS;
3653 /* recover other leap-year adjustment */
3662 ptm->tm_year = year - 1900;
3664 ptm->tm_mday = yearday;
3665 ptm->tm_mon = month;
3669 ptm->tm_mon = month - 1;
3671 /* re-build yearday based on Jan 1 to get tm_yday */
3673 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3674 yearday += 14*MONTH_TO_DAYS + 1;
3675 ptm->tm_yday = jday - yearday;
3676 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3680 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)
3688 PERL_ARGS_ASSERT_MY_STRFTIME;
3690 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3693 mytm.tm_hour = hour;
3694 mytm.tm_mday = mday;
3696 mytm.tm_year = year;
3697 mytm.tm_wday = wday;
3698 mytm.tm_yday = yday;
3699 mytm.tm_isdst = isdst;
3701 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3702 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3707 #ifdef HAS_TM_TM_GMTOFF
3708 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3710 #ifdef HAS_TM_TM_ZONE
3711 mytm.tm_zone = mytm2.tm_zone;
3716 Newx(buf, buflen, char);
3717 len = strftime(buf, buflen, fmt, &mytm);
3719 ** The following is needed to handle to the situation where
3720 ** tmpbuf overflows. Basically we want to allocate a buffer
3721 ** and try repeatedly. The reason why it is so complicated
3722 ** is that getting a return value of 0 from strftime can indicate
3723 ** one of the following:
3724 ** 1. buffer overflowed,
3725 ** 2. illegal conversion specifier, or
3726 ** 3. the format string specifies nothing to be returned(not
3727 ** an error). This could be because format is an empty string
3728 ** or it specifies %p that yields an empty string in some locale.
3729 ** If there is a better way to make it portable, go ahead by
3732 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3735 /* Possibly buf overflowed - try again with a bigger buf */
3736 const int fmtlen = strlen(fmt);
3737 int bufsize = fmtlen + buflen;
3739 Renew(buf, bufsize, char);
3741 buflen = strftime(buf, bufsize, fmt, &mytm);
3742 if (buflen > 0 && buflen < bufsize)
3744 /* heuristic to prevent out-of-memory errors */
3745 if (bufsize > 100*fmtlen) {
3751 Renew(buf, bufsize, char);
3756 Perl_croak(aTHX_ "panic: no strftime");
3762 #define SV_CWD_RETURN_UNDEF \
3763 sv_setsv(sv, &PL_sv_undef); \
3766 #define SV_CWD_ISDOT(dp) \
3767 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3768 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3771 =head1 Miscellaneous Functions
3773 =for apidoc getcwd_sv
3775 Fill the sv with current working directory
3780 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3781 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3782 * getcwd(3) if available
3783 * Comments from the orignal:
3784 * This is a faster version of getcwd. It's also more dangerous
3785 * because you might chdir out of a directory that you can't chdir
3789 Perl_getcwd_sv(pTHX_ SV *sv)
3793 #ifndef INCOMPLETE_TAINTS
3797 PERL_ARGS_ASSERT_GETCWD_SV;
3801 char buf[MAXPATHLEN];
3803 /* Some getcwd()s automatically allocate a buffer of the given
3804 * size from the heap if they are given a NULL buffer pointer.
3805 * The problem is that this behaviour is not portable. */
3806 if (getcwd(buf, sizeof(buf) - 1)) {
3811 sv_setsv(sv, &PL_sv_undef);
3819 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3823 SvUPGRADE(sv, SVt_PV);
3825 if (PerlLIO_lstat(".", &statbuf) < 0) {
3826 SV_CWD_RETURN_UNDEF;
3829 orig_cdev = statbuf.st_dev;
3830 orig_cino = statbuf.st_ino;
3840 if (PerlDir_chdir("..") < 0) {
3841 SV_CWD_RETURN_UNDEF;
3843 if (PerlLIO_stat(".", &statbuf) < 0) {
3844 SV_CWD_RETURN_UNDEF;
3847 cdev = statbuf.st_dev;
3848 cino = statbuf.st_ino;
3850 if (odev == cdev && oino == cino) {
3853 if (!(dir = PerlDir_open("."))) {
3854 SV_CWD_RETURN_UNDEF;
3857 while ((dp = PerlDir_read(dir)) != NULL) {
3859 namelen = dp->d_namlen;
3861 namelen = strlen(dp->d_name);
3864 if (SV_CWD_ISDOT(dp)) {
3868 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3869 SV_CWD_RETURN_UNDEF;
3872 tdev = statbuf.st_dev;
3873 tino = statbuf.st_ino;
3874 if (tino == oino && tdev == odev) {
3880 SV_CWD_RETURN_UNDEF;
3883 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3884 SV_CWD_RETURN_UNDEF;
3887 SvGROW(sv, pathlen + namelen + 1);
3891 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3894 /* prepend current directory to the front */
3896 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3897 pathlen += (namelen + 1);
3899 #ifdef VOID_CLOSEDIR
3902 if (PerlDir_close(dir) < 0) {
3903 SV_CWD_RETURN_UNDEF;
3909 SvCUR_set(sv, pathlen);
3913 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3914 SV_CWD_RETURN_UNDEF;
3917 if (PerlLIO_stat(".", &statbuf) < 0) {
3918 SV_CWD_RETURN_UNDEF;
3921 cdev = statbuf.st_dev;
3922 cino = statbuf.st_ino;
3924 if (cdev != orig_cdev || cino != orig_cino) {
3925 Perl_croak(aTHX_ "Unstable directory path, "
3926 "current directory changed unexpectedly");
3937 #define VERSION_MAX 0x7FFFFFFF
3940 =for apidoc prescan_version
3942 Validate that a given string can be parsed as a version object, but doesn't
3943 actually perform the parsing. Can use either strict or lax validation rules.
3944 Can optionally set a number of hint variables to save the parsing code
3945 some time when tokenizing.
3950 Perl_prescan_version(pTHX_ const char *s, bool strict,
3951 const char **errstr,
3952 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3953 bool qv = (sqv ? *sqv : FALSE);
3955 int saw_decimal = 0;
3959 PERL_ARGS_ASSERT_PRESCAN_VERSION;
3961 if (qv && isDIGIT(*d))
3962 goto dotted_decimal_version;
3964 if (*d == 'v') { /* explicit v-string */
3969 else { /* degenerate v-string */
3970 /* requires v1.2.3 */
3971 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3974 dotted_decimal_version:
3975 if (strict && d[0] == '0' && isDIGIT(d[1])) {
3976 /* no leading zeros allowed */
3977 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3980 while (isDIGIT(*d)) /* integer part */
3986 d++; /* decimal point */
3991 /* require v1.2.3 */
3992 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3995 goto version_prescan_finish;
4002 while (isDIGIT(*d)) { /* just keep reading */
4004 while (isDIGIT(*d)) {
4006 /* maximum 3 digits between decimal */
4007 if (strict && j > 3) {
4008 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4013 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4016 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4021 else if (*d == '.') {
4023 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4028 else if (!isDIGIT(*d)) {
4034 if (strict && i < 2) {
4035 /* requires v1.2.3 */
4036 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4039 } /* end if dotted-decimal */
4041 { /* decimal versions */
4042 int j = 0; /* may need this later */
4043 /* special strict case for leading '.' or '0' */
4046 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4048 if (*d == '0' && isDIGIT(d[1])) {
4049 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4053 /* and we never support negative versions */
4055 BADVERSION(s,errstr,"Invalid version format (negative version number)");
4058 /* consume all of the integer part */
4062 /* look for a fractional part */
4064 /* we found it, so consume it */
4068 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4071 BADVERSION(s,errstr,"Invalid version format (version required)");
4073 /* found just an integer */
4074 goto version_prescan_finish;
4076 else if ( d == s ) {
4077 /* didn't find either integer or period */
4078 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4080 else if (*d == '_') {
4081 /* underscore can't come after integer part */
4083 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4085 else if (isDIGIT(d[1])) {
4086 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4089 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4093 /* anything else after integer part is just invalid data */
4094 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4097 /* scan the fractional part after the decimal point*/
4099 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4100 /* strict or lax-but-not-the-end */
4101 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4104 while (isDIGIT(*d)) {
4106 if (*d == '.' && isDIGIT(d[-1])) {
4108 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4111 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4113 d = (char *)s; /* start all over again */
4115 goto dotted_decimal_version;
4119 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4122 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4124 if ( ! isDIGIT(d[1]) ) {
4125 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4134 version_prescan_finish:
4138 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4139 /* trailing non-numeric data */
4140 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4148 *ssaw_decimal = saw_decimal;
4155 =for apidoc scan_version
4157 Returns a pointer to the next character after the parsed
4158 version string, as well as upgrading the passed in SV to
4161 Function must be called with an already existing SV like
4164 s = scan_version(s, SV *sv, bool qv);
4166 Performs some preprocessing to the string to ensure that
4167 it has the correct characteristics of a version. Flags the
4168 object if it contains an underscore (which denotes this
4169 is an alpha version). The boolean qv denotes that the version
4170 should be interpreted as if it had multiple decimals, even if
4177 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4179 const char *start = s;
4182 const char *errstr = NULL;
4183 int saw_decimal = 0;
4190 PERL_ARGS_ASSERT_SCAN_VERSION;
4192 while (isSPACE(*s)) /* leading whitespace is OK */
4195 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4197 /* "undef" is a special case and not an error */
4198 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4200 Perl_croak(aTHX_ "%s", errstr);
4209 /* Now that we are through the prescan, start creating the object */
4211 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4212 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4214 #ifndef NODEFAULT_SHAREKEYS
4215 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4219 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4221 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4222 if ( !qv && width < 3 )
4223 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4225 while (isDIGIT(*pos))
4227 if (!isALPHA(*pos)) {
4233 /* this is atoi() that delimits on underscores */
4234 const char *end = pos;
4238 /* the following if() will only be true after the decimal
4239 * point of a version originally created with a bare
4240 * floating point number, i.e. not quoted in any way
4242 if ( !qv && s > start && saw_decimal == 1 ) {
4246 rev += (*s - '0') * mult;
4248 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4249 || (PERL_ABS(rev) > VERSION_MAX )) {
4250 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4251 "Integer overflow in version %d",VERSION_MAX);
4262 while (--end >= s) {
4264 rev += (*end - '0') * mult;
4266 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4267 || (PERL_ABS(rev) > VERSION_MAX )) {
4268 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4269 "Integer overflow in version");
4278 /* Append revision */
4279 av_push(av, newSViv(rev));
4284 else if ( *pos == '.' )
4286 else if ( *pos == '_' && isDIGIT(pos[1]) )
4288 else if ( *pos == ',' && isDIGIT(pos[1]) )
4290 else if ( isDIGIT(*pos) )
4297 while ( isDIGIT(*pos) )
4302 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4310 if ( qv ) { /* quoted versions always get at least three terms*/
4311 SSize_t len = av_len(av);
4312 /* This for loop appears to trigger a compiler bug on OS X, as it
4313 loops infinitely. Yes, len is negative. No, it makes no sense.
4314 Compiler in question is:
4315 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4316 for ( len = 2 - len; len > 0; len-- )
4317 av_push(MUTABLE_AV(sv), newSViv(0));
4321 av_push(av, newSViv(0));
4324 /* need to save off the current version string for later */
4326 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4327 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4328 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4330 else if ( s > start ) {
4331 SV * orig = newSVpvn(start,s-start);
4332 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4333 /* need to insert a v to be consistent */
4334 sv_insert(orig, 0, 0, "v", 1);
4336 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4339 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4340 av_push(av, newSViv(0));
4343 /* And finally, store the AV in the hash */
4344 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4346 /* fix RT#19517 - special case 'undef' as string */
4347 if ( *s == 'u' && strEQ(s,"undef") ) {
4355 =for apidoc new_version
4357 Returns a new version object based on the passed in SV:
4359 SV *sv = new_version(SV *ver);
4361 Does not alter the passed in ver SV. See "upg_version" if you
4362 want to upgrade the SV.
4368 Perl_new_version(pTHX_ SV *ver)
4371 SV * const rv = newSV(0);
4372 PERL_ARGS_ASSERT_NEW_VERSION;
4373 if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4374 /* can just copy directly */
4377 AV * const av = newAV();
4379 /* This will get reblessed later if a derived class*/
4380 SV * const hv = newSVrv(rv, "version");
4381 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4382 #ifndef NODEFAULT_SHAREKEYS
4383 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4389 /* Begin copying all of the elements */
4390 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4391 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4393 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4394 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4396 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4398 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4399 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4402 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4404 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4405 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4408 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4409 /* This will get reblessed later if a derived class*/
4410 for ( key = 0; key <= av_len(sav); key++ )
4412 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4413 av_push(av, newSViv(rev));
4416 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4421 const MAGIC* const mg = SvVSTRING_mg(ver);
4422 if ( mg ) { /* already a v-string */
4423 const STRLEN len = mg->mg_len;
4424 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4425 sv_setpvn(rv,version,len);
4426 /* this is for consistency with the pure Perl class */
4427 if ( isDIGIT(*version) )
4428 sv_insert(rv, 0, 0, "v", 1);
4433 sv_setsv(rv,ver); /* make a duplicate */
4438 return upg_version(rv, FALSE);
4442 =for apidoc upg_version
4444 In-place upgrade of the supplied SV to a version object.
4446 SV *sv = upg_version(SV *sv, bool qv);
4448 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4449 to force this SV to be interpreted as an "extended" version.
4455 Perl_upg_version(pTHX_ SV *ver, bool qv)
4457 const char *version, *s;
4462 PERL_ARGS_ASSERT_UPG_VERSION;
4464 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4468 /* may get too much accuracy */
4470 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4472 #ifdef USE_LOCALE_NUMERIC
4474 if (! PL_numeric_standard) {
4475 loc = savepv(setlocale(LC_NUMERIC, NULL));
4476 setlocale(LC_NUMERIC, "C");
4480 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4481 buf = SvPV(sv, len);
4484 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4487 #ifdef USE_LOCALE_NUMERIC
4489 setlocale(LC_NUMERIC, loc);
4493 while (buf[len-1] == '0' && len > 0) len--;
4494 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4495 version = savepvn(buf, len);
4499 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4500 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4504 else /* must be a string or something like a string */
4507 version = savepv(SvPV(ver,len));
4509 # if PERL_VERSION > 5
4510 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4511 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4512 /* may be a v-string */
4513 char *testv = (char *)version;
4515 for (tlen=0; tlen < len; tlen++, testv++) {
4516 /* if one of the characters is non-text assume v-string */
4517 if (testv[0] < ' ') {
4518 SV * const nsv = sv_newmortal();
4521 int saw_decimal = 0;
4522 sv_setpvf(nsv,"v%vd",ver);
4523 pos = nver = savepv(SvPV_nolen(nsv));
4525 /* scan the resulting formatted string */
4526 pos++; /* skip the leading 'v' */
4527 while ( *pos == '.' || isDIGIT(*pos) ) {
4533 /* is definitely a v-string */
4534 if ( saw_decimal >= 2 ) {
4546 s = scan_version(version, ver, qv);
4548 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4549 "Version string '%s' contains invalid data; "
4550 "ignoring: '%s'", version, s);
4558 Validates that the SV contains valid internal structure for a version object.
4559 It may be passed either the version object (RV) or the hash itself (HV). If
4560 the structure is valid, it returns the HV. If the structure is invalid,
4563 SV *hv = vverify(sv);
4565 Note that it only confirms the bare minimum structure (so as not to get
4566 confused by derived classes which may contain additional hash entries):
4570 =item * The SV is an HV or a reference to an HV
4572 =item * The hash contains a "version" key
4574 =item * The "version" key has a reference to an AV as its value
4582 Perl_vverify(pTHX_ SV *vs)
4586 PERL_ARGS_ASSERT_VVERIFY;
4591 /* see if the appropriate elements exist */
4592 if ( SvTYPE(vs) == SVt_PVHV
4593 && hv_exists(MUTABLE_HV(vs), "version", 7)
4594 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4595 && SvTYPE(sv) == SVt_PVAV )
4604 Accepts a version object and returns the normalized floating
4605 point representation. Call like:
4609 NOTE: you can pass either the object directly or the SV
4610 contained within the RV.
4612 The SV returned has a refcount of 1.
4618 Perl_vnumify(pTHX_ SV *vs)
4627 PERL_ARGS_ASSERT_VNUMIFY;
4629 /* extract the HV from the object */
4632 Perl_croak(aTHX_ "Invalid version object");
4634 /* see if various flags exist */
4635 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4637 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4638 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4643 /* attempt to retrieve the version array */
4644 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4645 return newSVpvs("0");
4651 return newSVpvs("0");
4654 digit = SvIV(*av_fetch(av, 0, 0));
4655 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4656 for ( i = 1 ; i < len ; i++ )
4658 digit = SvIV(*av_fetch(av, i, 0));
4660 const int denom = (width == 2 ? 10 : 100);
4661 const div_t term = div((int)PERL_ABS(digit),denom);
4662 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4665 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4671 digit = SvIV(*av_fetch(av, len, 0));
4672 if ( alpha && width == 3 ) /* alpha version */
4674 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4678 sv_catpvs(sv, "000");
4686 Accepts a version object and returns the normalized string
4687 representation. Call like:
4691 NOTE: you can pass either the object directly or the SV
4692 contained within the RV.
4694 The SV returned has a refcount of 1.
4700 Perl_vnormal(pTHX_ SV *vs)
4707 PERL_ARGS_ASSERT_VNORMAL;
4709 /* extract the HV from the object */
4712 Perl_croak(aTHX_ "Invalid version object");
4714 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4716 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4721 return newSVpvs("");
4723 digit = SvIV(*av_fetch(av, 0, 0));
4724 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4725 for ( i = 1 ; i < len ; i++ ) {
4726 digit = SvIV(*av_fetch(av, i, 0));
4727 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4732 /* handle last digit specially */
4733 digit = SvIV(*av_fetch(av, len, 0));
4735 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4737 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4740 if ( len <= 2 ) { /* short version, must be at least three */
4741 for ( len = 2 - len; len != 0; len-- )
4748 =for apidoc vstringify
4750 In order to maintain maximum compatibility with earlier versions
4751 of Perl, this function will return either the floating point
4752 notation or the multiple dotted notation, depending on whether
4753 the original version contained 1 or more dots, respectively.
4755 The SV returned has a refcount of 1.
4761 Perl_vstringify(pTHX_ SV *vs)
4763 PERL_ARGS_ASSERT_VSTRINGIFY;
4765 /* extract the HV from the object */
4768 Perl_croak(aTHX_ "Invalid version object");
4770 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
4772 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4776 return &PL_sv_undef;
4779 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4789 Version object aware cmp. Both operands must already have been
4790 converted into version objects.
4796 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4800 bool lalpha = FALSE;
4801 bool ralpha = FALSE;
4806 PERL_ARGS_ASSERT_VCMP;
4808 /* extract the HVs from the objects */
4811 if ( ! ( lhv && rhv ) )
4812 Perl_croak(aTHX_ "Invalid version object");
4814 /* get the left hand term */
4815 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4816 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4819 /* and the right hand term */
4820 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4821 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4829 while ( i <= m && retval == 0 )
4831 left = SvIV(*av_fetch(lav,i,0));
4832 right = SvIV(*av_fetch(rav,i,0));
4840 /* tiebreaker for alpha with identical terms */
4841 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4843 if ( lalpha && !ralpha )
4847 else if ( ralpha && !lalpha)
4853 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4857 while ( i <= r && retval == 0 )
4859 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4860 retval = -1; /* not a match after all */
4866 while ( i <= l && retval == 0 )
4868 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4869 retval = +1; /* not a match after all */
4877 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4878 # define EMULATE_SOCKETPAIR_UDP
4881 #ifdef EMULATE_SOCKETPAIR_UDP
4883 S_socketpair_udp (int fd[2]) {
4885 /* Fake a datagram socketpair using UDP to localhost. */
4886 int sockets[2] = {-1, -1};
4887 struct sockaddr_in addresses[2];
4889 Sock_size_t size = sizeof(struct sockaddr_in);
4890 unsigned short port;
4893 memset(&addresses, 0, sizeof(addresses));
4896 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4897 if (sockets[i] == -1)
4898 goto tidy_up_and_fail;
4900 addresses[i].sin_family = AF_INET;
4901 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4902 addresses[i].sin_port = 0; /* kernel choses port. */
4903 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4904 sizeof(struct sockaddr_in)) == -1)
4905 goto tidy_up_and_fail;
4908 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4909 for each connect the other socket to it. */
4912 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4914 goto tidy_up_and_fail;
4915 if (size != sizeof(struct sockaddr_in))
4916 goto abort_tidy_up_and_fail;
4917 /* !1 is 0, !0 is 1 */
4918 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4919 sizeof(struct sockaddr_in)) == -1)
4920 goto tidy_up_and_fail;
4923 /* Now we have 2 sockets connected to each other. I don't trust some other
4924 process not to have already sent a packet to us (by random) so send
4925 a packet from each to the other. */
4928 /* I'm going to send my own port number. As a short.
4929 (Who knows if someone somewhere has sin_port as a bitfield and needs
4930 this routine. (I'm assuming crays have socketpair)) */
4931 port = addresses[i].sin_port;
4932 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4933 if (got != sizeof(port)) {
4935 goto tidy_up_and_fail;
4936 goto abort_tidy_up_and_fail;
4940 /* Packets sent. I don't trust them to have arrived though.
4941 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4942 connect to localhost will use a second kernel thread. In 2.6 the
4943 first thread running the connect() returns before the second completes,
4944 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4945 returns 0. Poor programs have tripped up. One poor program's authors'
4946 had a 50-1 reverse stock split. Not sure how connected these were.)
4947 So I don't trust someone not to have an unpredictable UDP stack.
4951 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4952 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4956 FD_SET((unsigned int)sockets[0], &rset);
4957 FD_SET((unsigned int)sockets[1], &rset);
4959 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4960 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4961 || !FD_ISSET(sockets[1], &rset)) {
4962 /* I hope this is portable and appropriate. */
4964 goto tidy_up_and_fail;
4965 goto abort_tidy_up_and_fail;
4969 /* And the paranoia department even now doesn't trust it to have arrive
4970 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4972 struct sockaddr_in readfrom;
4973 unsigned short buffer[2];
4978 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4979 sizeof(buffer), MSG_DONTWAIT,
4980 (struct sockaddr *) &readfrom, &size);
4982 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4984 (struct sockaddr *) &readfrom, &size);
4988 goto tidy_up_and_fail;
4989 if (got != sizeof(port)
4990 || size != sizeof(struct sockaddr_in)
4991 /* Check other socket sent us its port. */
4992 || buffer[0] != (unsigned short) addresses[!i].sin_port
4993 /* Check kernel says we got the datagram from that socket */
4994 || readfrom.sin_family != addresses[!i].sin_family
4995 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4996 || readfrom.sin_port != addresses[!i].sin_port)
4997 goto abort_tidy_up_and_fail;
5000 /* My caller (my_socketpair) has validated that this is non-NULL */
5003 /* I hereby declare this connection open. May God bless all who cross
5007 abort_tidy_up_and_fail:
5008 errno = ECONNABORTED;
5012 if (sockets[0] != -1)
5013 PerlLIO_close(sockets[0]);
5014 if (sockets[1] != -1)
5015 PerlLIO_close(sockets[1]);
5020 #endif /* EMULATE_SOCKETPAIR_UDP */
5022 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5024 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5025 /* Stevens says that family must be AF_LOCAL, protocol 0.
5026 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5031 struct sockaddr_in listen_addr;
5032 struct sockaddr_in connect_addr;
5037 || family != AF_UNIX
5040 errno = EAFNOSUPPORT;
5048 #ifdef EMULATE_SOCKETPAIR_UDP
5049 if (type == SOCK_DGRAM)
5050 return S_socketpair_udp(fd);
5053 aTHXa(PERL_GET_THX);
5054 listener = PerlSock_socket(AF_INET, type, 0);
5057 memset(&listen_addr, 0, sizeof(listen_addr));
5058 listen_addr.sin_family = AF_INET;
5059 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5060 listen_addr.sin_port = 0; /* kernel choses port. */
5061 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5062 sizeof(listen_addr)) == -1)
5063 goto tidy_up_and_fail;
5064 if (PerlSock_listen(listener, 1) == -1)
5065 goto tidy_up_and_fail;
5067 connector = PerlSock_socket(AF_INET, type, 0);
5068 if (connector == -1)
5069 goto tidy_up_and_fail;
5070 /* We want to find out the port number to connect to. */
5071 size = sizeof(connect_addr);
5072 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5074 goto tidy_up_and_fail;
5075 if (size != sizeof(connect_addr))
5076 goto abort_tidy_up_and_fail;
5077 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5078 sizeof(connect_addr)) == -1)
5079 goto tidy_up_and_fail;
5081 size = sizeof(listen_addr);
5082 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5085 goto tidy_up_and_fail;
5086 if (size != sizeof(listen_addr))
5087 goto abort_tidy_up_and_fail;
5088 PerlLIO_close(listener);
5089 /* Now check we are talking to ourself by matching port and host on the
5091 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5093 goto tidy_up_and_fail;
5094 if (size != sizeof(connect_addr)
5095 || listen_addr.sin_family != connect_addr.sin_family
5096 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5097 || listen_addr.sin_port != connect_addr.sin_port) {
5098 goto abort_tidy_up_and_fail;
5104 abort_tidy_up_and_fail:
5106 errno = ECONNABORTED; /* This would be the standard thing to do. */
5108 # ifdef ECONNREFUSED
5109 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5111 errno = ETIMEDOUT; /* Desperation time. */
5118 PerlLIO_close(listener);
5119 if (connector != -1)
5120 PerlLIO_close(connector);
5122 PerlLIO_close(acceptor);
5128 /* In any case have a stub so that there's code corresponding
5129 * to the my_socketpair in embed.fnc. */
5131 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5132 #ifdef HAS_SOCKETPAIR
5133 return socketpair(family, type, protocol, fd);
5142 =for apidoc sv_nosharing
5144 Dummy routine which "shares" an SV when there is no sharing module present.
5145 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5146 Exists to avoid test for a NULL function pointer and because it could
5147 potentially warn under some level of strict-ness.
5153 Perl_sv_nosharing(pTHX_ SV *sv)
5155 PERL_UNUSED_CONTEXT;
5156 PERL_UNUSED_ARG(sv);
5161 =for apidoc sv_destroyable
5163 Dummy routine which reports that object can be destroyed when there is no
5164 sharing module present. It ignores its single SV argument, and returns
5165 'true'. Exists to avoid test for a NULL function pointer and because it
5166 could potentially warn under some level of strict-ness.
5172 Perl_sv_destroyable(pTHX_ SV *sv)
5174 PERL_UNUSED_CONTEXT;
5175 PERL_UNUSED_ARG(sv);
5180 Perl_parse_unicode_opts(pTHX_ const char **popt)
5182 const char *p = *popt;
5185 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5189 opt = (U32) atoi(p);
5192 if (*p && *p != '\n' && *p != '\r') {
5193 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5195 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5201 case PERL_UNICODE_STDIN:
5202 opt |= PERL_UNICODE_STDIN_FLAG; break;
5203 case PERL_UNICODE_STDOUT:
5204 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5205 case PERL_UNICODE_STDERR:
5206 opt |= PERL_UNICODE_STDERR_FLAG; break;
5207 case PERL_UNICODE_STD:
5208 opt |= PERL_UNICODE_STD_FLAG; break;
5209 case PERL_UNICODE_IN:
5210 opt |= PERL_UNICODE_IN_FLAG; break;
5211 case PERL_UNICODE_OUT:
5212 opt |= PERL_UNICODE_OUT_FLAG; break;
5213 case PERL_UNICODE_INOUT:
5214 opt |= PERL_UNICODE_INOUT_FLAG; break;
5215 case PERL_UNICODE_LOCALE:
5216 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5217 case PERL_UNICODE_ARGV:
5218 opt |= PERL_UNICODE_ARGV_FLAG; break;
5219 case PERL_UNICODE_UTF8CACHEASSERT:
5220 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5222 if (*p != '\n' && *p != '\r') {
5223 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5226 "Unknown Unicode option letter '%c'", *p);
5233 opt = PERL_UNICODE_DEFAULT_FLAGS;
5235 the_end_of_the_opts_parser:
5237 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5238 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5239 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5247 # include <starlet.h>
5255 * This is really just a quick hack which grabs various garbage
5256 * values. It really should be a real hash algorithm which
5257 * spreads the effect of every input bit onto every output bit,
5258 * if someone who knows about such things would bother to write it.
5259 * Might be a good idea to add that function to CORE as well.
5260 * No numbers below come from careful analysis or anything here,
5261 * except they are primes and SEED_C1 > 1E6 to get a full-width
5262 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5263 * probably be bigger too.
5266 # define SEED_C1 1000003
5267 #define SEED_C4 73819
5269 # define SEED_C1 25747
5270 #define SEED_C4 20639
5274 #define SEED_C5 26107
5276 #ifndef PERL_NO_DEV_RANDOM
5281 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5282 * in 100-ns units, typically incremented ever 10 ms. */
5283 unsigned int when[2];
5285 # ifdef HAS_GETTIMEOFDAY
5286 struct timeval when;
5292 /* This test is an escape hatch, this symbol isn't set by Configure. */
5293 #ifndef PERL_NO_DEV_RANDOM
5294 #ifndef PERL_RANDOM_DEVICE
5295 /* /dev/random isn't used by default because reads from it will block
5296 * if there isn't enough entropy available. You can compile with
5297 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5298 * is enough real entropy to fill the seed. */
5299 # define PERL_RANDOM_DEVICE "/dev/urandom"
5301 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5303 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5312 _ckvmssts(sys$gettim(when));
5313 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5315 # ifdef HAS_GETTIMEOFDAY
5316 PerlProc_gettimeofday(&when,NULL);
5317 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5320 u = (U32)SEED_C1 * when;
5323 u += SEED_C3 * (U32)PerlProc_getpid();
5324 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5325 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5326 u += SEED_C5 * (U32)PTR2UV(&when);
5332 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
5338 PERL_ARGS_ASSERT_GET_HASH_SEED;
5340 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
5343 #ifndef USE_HASH_SEED_EXPLICIT
5345 /* ignore leading spaces */
5346 while (isSPACE(*env_pv))
5348 #ifdef USE_PERL_PERTURB_KEYS
5349 /* if they set it to "0" we disable key traversal randomization completely */
5350 if (strEQ(env_pv,"0")) {
5351 PL_hash_rand_bits_enabled= 0;
5353 /* otherwise switch to deterministic mode */
5354 PL_hash_rand_bits_enabled= 2;
5357 /* ignore a leading 0x... if it is there */
5358 if (env_pv[0] == '0' && env_pv[1] == 'x')
5361 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
5362 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
5363 if ( isXDIGIT(*env_pv)) {
5364 seed_buffer[i] |= READ_XDIGIT(env_pv);
5367 while (isSPACE(*env_pv))
5370 if (*env_pv && !isXDIGIT(*env_pv)) {
5371 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
5373 /* should we check for unparsed crap? */
5374 /* should we warn about unused hex? */
5375 /* should we warn about insufficient hex? */
5380 (void)seedDrand01((Rand_seed_t)seed());
5382 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
5383 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
5386 #ifdef USE_PERL_PERTURB_KEYS
5387 { /* initialize PL_hash_rand_bits from the hash seed.
5388 * This value is highly volatile, it is updated every
5389 * hash insert, and is used as part of hash bucket chain
5390 * randomization and hash iterator randomization. */
5391 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
5392 for( i = 0; i < sizeof(UV) ; i++ ) {
5393 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
5394 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
5397 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
5399 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
5400 PL_hash_rand_bits_enabled= 0;
5401 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
5402 PL_hash_rand_bits_enabled= 1;
5403 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
5404 PL_hash_rand_bits_enabled= 2;
5406 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
5412 #ifdef PERL_GLOBAL_STRUCT
5414 #define PERL_GLOBAL_STRUCT_INIT
5415 #include "opcode.h" /* the ppaddr and check */
5418 Perl_init_global_struct(pTHX)
5420 struct perl_vars *plvarsp = NULL;
5421 # ifdef PERL_GLOBAL_STRUCT
5422 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5423 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5424 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5425 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5426 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5430 plvarsp = PL_VarsPtr;
5431 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5436 # define PERLVAR(prefix,var,type) /**/
5437 # define PERLVARA(prefix,var,n,type) /**/
5438 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5439 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5440 # include "perlvars.h"
5445 # ifdef PERL_GLOBAL_STRUCT
5448 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5449 if (!plvarsp->Gppaddr)
5453 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5454 if (!plvarsp->Gcheck)
5456 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5457 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5459 # ifdef PERL_SET_VARS
5460 PERL_SET_VARS(plvarsp);
5462 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5463 plvarsp->Gsv_placeholder.sv_flags = 0;
5464 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
5466 # undef PERL_GLOBAL_STRUCT_INIT
5471 #endif /* PERL_GLOBAL_STRUCT */
5473 #ifdef PERL_GLOBAL_STRUCT
5476 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5478 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5479 # ifdef PERL_GLOBAL_STRUCT
5480 # ifdef PERL_UNSET_VARS
5481 PERL_UNSET_VARS(plvarsp);
5483 free(plvarsp->Gppaddr);
5484 free(plvarsp->Gcheck);
5485 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5491 #endif /* PERL_GLOBAL_STRUCT */
5495 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5496 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5497 * given, and you supply your own implementation.
5499 * The default implementation reads a single env var, PERL_MEM_LOG,
5500 * expecting one or more of the following:
5502 * \d+ - fd fd to write to : must be 1st (atoi)
5503 * 'm' - memlog was PERL_MEM_LOG=1
5504 * 's' - svlog was PERL_SV_LOG=1
5505 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5507 * This makes the logger controllable enough that it can reasonably be
5508 * added to the system perl.
5511 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5512 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5514 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5516 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5517 * writes to. In the default logger, this is settable at runtime.
5519 #ifndef PERL_MEM_LOG_FD
5520 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5523 #ifndef PERL_MEM_LOG_NOIMPL
5525 # ifdef DEBUG_LEAKING_SCALARS
5526 # define SV_LOG_SERIAL_FMT " [%lu]"
5527 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5529 # define SV_LOG_SERIAL_FMT
5530 # define _SV_LOG_SERIAL_ARG(sv)
5534 S_mem_log_common(enum mem_log_type mlt, const UV n,
5535 const UV typesize, const char *type_name, const SV *sv,
5536 Malloc_t oldalloc, Malloc_t newalloc,
5537 const char *filename, const int linenumber,
5538 const char *funcname)
5542 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5544 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5547 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5549 /* We can't use SVs or PerlIO for obvious reasons,
5550 * so we'll use stdio and low-level IO instead. */
5551 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5553 # ifdef HAS_GETTIMEOFDAY
5554 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5555 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5557 gettimeofday(&tv, 0);
5559 # define MEM_LOG_TIME_FMT "%10d: "
5560 # define MEM_LOG_TIME_ARG (int)when
5564 /* If there are other OS specific ways of hires time than
5565 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5566 * probably that they would be used to fill in the struct
5570 int fd = atoi(pmlenv);
5572 fd = PERL_MEM_LOG_FD;
5574 if (strchr(pmlenv, 't')) {
5575 len = my_snprintf(buf, sizeof(buf),
5576 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5577 PerlLIO_write(fd, buf, len);
5581 len = my_snprintf(buf, sizeof(buf),
5582 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5583 " %s = %"IVdf": %"UVxf"\n",
5584 filename, linenumber, funcname, n, typesize,
5585 type_name, n * typesize, PTR2UV(newalloc));
5588 len = my_snprintf(buf, sizeof(buf),
5589 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5590 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5591 filename, linenumber, funcname, n, typesize,
5592 type_name, n * typesize, PTR2UV(oldalloc),
5596 len = my_snprintf(buf, sizeof(buf),
5597 "free: %s:%d:%s: %"UVxf"\n",
5598 filename, linenumber, funcname,
5603 len = my_snprintf(buf, sizeof(buf),
5604 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5605 mlt == MLT_NEW_SV ? "new" : "del",
5606 filename, linenumber, funcname,
5607 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5612 PerlLIO_write(fd, buf, len);
5616 #endif /* !PERL_MEM_LOG_NOIMPL */
5618 #ifndef PERL_MEM_LOG_NOIMPL
5620 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5621 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5623 /* this is suboptimal, but bug compatible. User is providing their
5624 own implementation, but is getting these functions anyway, and they
5625 do nothing. But _NOIMPL users should be able to cope or fix */
5627 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5628 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5632 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5634 const char *filename, const int linenumber,
5635 const char *funcname)
5637 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5638 NULL, NULL, newalloc,
5639 filename, linenumber, funcname);
5644 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5645 Malloc_t oldalloc, Malloc_t newalloc,
5646 const char *filename, const int linenumber,
5647 const char *funcname)
5649 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5650 NULL, oldalloc, newalloc,
5651 filename, linenumber, funcname);
5656 Perl_mem_log_free(Malloc_t oldalloc,
5657 const char *filename, const int linenumber,
5658 const char *funcname)
5660 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5661 filename, linenumber, funcname);
5666 Perl_mem_log_new_sv(const SV *sv,
5667 const char *filename, const int linenumber,
5668 const char *funcname)
5670 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5671 filename, linenumber, funcname);
5675 Perl_mem_log_del_sv(const SV *sv,
5676 const char *filename, const int linenumber,
5677 const char *funcname)
5679 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5680 filename, linenumber, funcname);
5683 #endif /* PERL_MEM_LOG */
5686 =for apidoc my_sprintf
5688 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5689 the length of the string written to the buffer. Only rare pre-ANSI systems
5690 need the wrapper function - usually this is a direct call to C<sprintf>.
5694 #ifndef SPRINTF_RETURNS_STRLEN
5696 Perl_my_sprintf(char *buffer, const char* pat, ...)
5699 PERL_ARGS_ASSERT_MY_SPRINTF;
5700 va_start(args, pat);
5701 vsprintf(buffer, pat, args);
5703 return strlen(buffer);
5708 =for apidoc my_snprintf
5710 The C library C<snprintf> functionality, if available and
5711 standards-compliant (uses C<vsnprintf>, actually). However, if the
5712 C<vsnprintf> is not available, will unfortunately use the unsafe
5713 C<vsprintf> which can overrun the buffer (there is an overrun check,
5714 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5715 getting C<vsnprintf>.
5720 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5724 PERL_ARGS_ASSERT_MY_SNPRINTF;
5725 va_start(ap, format);
5726 #ifdef HAS_VSNPRINTF
5727 retval = vsnprintf(buffer, len, format, ap);
5729 retval = vsprintf(buffer, format, ap);
5732 /* vsprintf() shows failure with < 0 */
5734 #ifdef HAS_VSNPRINTF
5735 /* vsnprintf() shows failure with >= len */
5737 (len > 0 && (Size_t)retval >= len)
5740 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5745 =for apidoc my_vsnprintf
5747 The C library C<vsnprintf> if available and standards-compliant.
5748 However, if if the C<vsnprintf> is not available, will unfortunately
5749 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5750 overrun check, but that may be too late). Consider using
5751 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5756 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5762 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5764 Perl_va_copy(ap, apc);
5765 # ifdef HAS_VSNPRINTF
5766 retval = vsnprintf(buffer, len, format, apc);
5768 retval = vsprintf(buffer, format, apc);
5771 # ifdef HAS_VSNPRINTF
5772 retval = vsnprintf(buffer, len, format, ap);
5774 retval = vsprintf(buffer, format, ap);
5776 #endif /* #ifdef NEED_VA_COPY */
5777 /* vsprintf() shows failure with < 0 */
5779 #ifdef HAS_VSNPRINTF
5780 /* vsnprintf() shows failure with >= len */
5782 (len > 0 && (Size_t)retval >= len)
5785 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5790 Perl_my_clearenv(pTHX)
5793 #if ! defined(PERL_MICRO)
5794 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5796 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5797 # if defined(USE_ENVIRON_ARRAY)
5798 # if defined(USE_ITHREADS)
5799 /* only the parent thread can clobber the process environment */
5800 if (PL_curinterp == aTHX)
5801 # endif /* USE_ITHREADS */
5803 # if ! defined(PERL_USE_SAFE_PUTENV)
5804 if ( !PL_use_safe_putenv) {
5806 if (environ == PL_origenviron)
5807 environ = (char**)safesysmalloc(sizeof(char*));
5809 for (i = 0; environ[i]; i++)
5810 (void)safesysfree(environ[i]);
5813 # else /* PERL_USE_SAFE_PUTENV */
5814 # if defined(HAS_CLEARENV)
5816 # elif defined(HAS_UNSETENV)
5817 int bsiz = 80; /* Most envvar names will be shorter than this. */
5818 char *buf = (char*)safesysmalloc(bsiz);
5819 while (*environ != NULL) {
5820 char *e = strchr(*environ, '=');
5821 int l = e ? e - *environ : (int)strlen(*environ);
5823 (void)safesysfree(buf);
5824 bsiz = l + 1; /* + 1 for the \0. */
5825 buf = (char*)safesysmalloc(bsiz);
5827 memcpy(buf, *environ, l);
5829 (void)unsetenv(buf);
5831 (void)safesysfree(buf);
5832 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5833 /* Just null environ and accept the leakage. */
5835 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5836 # endif /* ! PERL_USE_SAFE_PUTENV */
5838 # endif /* USE_ENVIRON_ARRAY */
5839 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5840 #endif /* PERL_MICRO */
5843 #ifdef PERL_IMPLICIT_CONTEXT
5845 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5846 the global PL_my_cxt_index is incremented, and that value is assigned to
5847 that module's static my_cxt_index (who's address is passed as an arg).
5848 Then, for each interpreter this function is called for, it makes sure a
5849 void* slot is available to hang the static data off, by allocating or
5850 extending the interpreter's PL_my_cxt_list array */
5852 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5854 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5858 PERL_ARGS_ASSERT_MY_CXT_INIT;
5860 /* this module hasn't been allocated an index yet */
5861 #if defined(USE_ITHREADS)
5862 MUTEX_LOCK(&PL_my_ctx_mutex);
5864 *index = PL_my_cxt_index++;
5865 #if defined(USE_ITHREADS)
5866 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5870 /* make sure the array is big enough */
5871 if (PL_my_cxt_size <= *index) {
5872 if (PL_my_cxt_size) {
5873 while (PL_my_cxt_size <= *index)
5874 PL_my_cxt_size *= 2;
5875 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5878 PL_my_cxt_size = 16;
5879 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5882 /* newSV() allocates one more than needed */
5883 p = (void*)SvPVX(newSV(size-1));
5884 PL_my_cxt_list[*index] = p;
5885 Zero(p, size, char);
5889 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5892 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5897 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5899 for (index = 0; index < PL_my_cxt_index; index++) {
5900 const char *key = PL_my_cxt_keys[index];
5901 /* try direct pointer compare first - there are chances to success,
5902 * and it's much faster.
5904 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5911 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5917 PERL_ARGS_ASSERT_MY_CXT_INIT;
5919 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5921 /* this module hasn't been allocated an index yet */
5922 #if defined(USE_ITHREADS)
5923 MUTEX_LOCK(&PL_my_ctx_mutex);
5925 index = PL_my_cxt_index++;
5926 #if defined(USE_ITHREADS)
5927 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5931 /* make sure the array is big enough */
5932 if (PL_my_cxt_size <= index) {
5933 int old_size = PL_my_cxt_size;
5935 if (PL_my_cxt_size) {
5936 while (PL_my_cxt_size <= index)
5937 PL_my_cxt_size *= 2;
5938 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5939 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5942 PL_my_cxt_size = 16;
5943 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5944 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5946 for (i = old_size; i < PL_my_cxt_size; i++) {
5947 PL_my_cxt_keys[i] = 0;
5948 PL_my_cxt_list[i] = 0;
5951 PL_my_cxt_keys[index] = my_cxt_key;
5952 /* newSV() allocates one more than needed */
5953 p = (void*)SvPVX(newSV(size-1));
5954 PL_my_cxt_list[index] = p;
5955 Zero(p, size, char);
5958 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5959 #endif /* PERL_IMPLICIT_CONTEXT */
5962 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5966 const char *vn = NULL;
5967 SV *const module = PL_stack_base[ax];
5969 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5971 if (items >= 2) /* version supplied as bootstrap arg */
5972 sv = PL_stack_base[ax + 1];
5974 /* XXX GV_ADDWARN */
5976 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5977 if (!sv || !SvOK(sv)) {
5979 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5983 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5984 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5985 ? sv : sv_2mortal(new_version(sv));
5986 xssv = upg_version(xssv, 0);
5987 if ( vcmp(pmsv,xssv) ) {
5988 SV *string = vstringify(xssv);
5989 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5990 " does not match ", module, string);
5992 SvREFCNT_dec(string);
5993 string = vstringify(pmsv);
5996 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5999 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6001 SvREFCNT_dec(string);
6003 Perl_sv_2mortal(aTHX_ xpt);
6004 Perl_croak_sv(aTHX_ xpt);
6010 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6014 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6017 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6019 /* This might croak */
6020 compver = upg_version(compver, 0);
6021 /* This should never croak */
6022 runver = new_version(PL_apiversion);
6023 if (vcmp(compver, runver)) {
6024 SV *compver_string = vstringify(compver);
6025 SV *runver_string = vstringify(runver);
6026 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6027 " of %"SVf" does not match %"SVf,
6028 compver_string, module, runver_string);
6029 Perl_sv_2mortal(aTHX_ xpt);
6031 SvREFCNT_dec(compver_string);
6032 SvREFCNT_dec(runver_string);
6034 SvREFCNT_dec(runver);
6036 Perl_croak_sv(aTHX_ xpt);
6040 =for apidoc my_strlcat
6042 The C library C<strlcat> if available, or a Perl implementation of it.
6043 This operates on C NUL-terminated strings.
6045 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
6046 most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
6047 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
6048 practice this should not happen as it means that either C<size> is incorrect or
6049 that C<dst> is not a proper NUL-terminated string).
6051 Note that C<size> is the full size of the destination buffer and
6052 the result is guaranteed to be NUL-terminated if there is room. Note that room
6053 for the NUL should be included in C<size>.
6057 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
6061 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6063 Size_t used, length, copy;
6066 length = strlen(src);
6067 if (size > 0 && used < size - 1) {
6068 copy = (length >= size - used) ? size - used - 1 : length;
6069 memcpy(dst + used, src, copy);
6070 dst[used + copy] = '\0';
6072 return used + length;
6078 =for apidoc my_strlcpy
6080 The C library C<strlcpy> if available, or a Perl implementation of it.
6081 This operates on C NUL-terminated strings.
6083 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
6084 to C<dst>, NUL-terminating the result if C<size> is not 0.
6088 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
6092 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6094 Size_t length, copy;
6096 length = strlen(src);
6098 copy = (length >= size) ? size - 1 : length;
6099 memcpy(dst, src, copy);
6106 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6107 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6108 long _ftol( double ); /* Defined by VC6 C libs. */
6109 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6112 PERL_STATIC_INLINE bool
6113 S_gv_has_usable_name(pTHX_ GV *gv)
6117 && HvENAME(GvSTASH(gv))
6118 && (gvp = (GV **)hv_fetch(
6119 GvSTASH(gv), GvNAME(gv),
6120 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6126 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6129 SV * const dbsv = GvSVn(PL_DBsub);
6130 const bool save_taint = TAINT_get;
6132 /* When we are called from pp_goto (svp is null),
6133 * we do not care about using dbsv to call CV;
6134 * it's for informational purposes only.
6137 PERL_ARGS_ASSERT_GET_DB_SUB;
6141 if (!PERLDB_SUB_NN) {
6145 gv_efullname3(dbsv, gv, NULL);
6147 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6148 || strEQ(GvNAME(gv), "END")
6149 || ( /* Could be imported, and old sub redefined. */
6150 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6152 !( (SvTYPE(*svp) == SVt_PVGV)
6153 && (GvCV((const GV *)*svp) == cv)
6154 /* Use GV from the stack as a fallback. */
6155 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6159 /* GV is potentially non-unique, or contain different CV. */
6160 SV * const tmp = newRV(MUTABLE_SV(cv));
6161 sv_setsv(dbsv, tmp);
6165 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6166 sv_catpvs(dbsv, "::");
6168 dbsv, GvNAME(gv), GvNAMELEN(gv),
6169 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6174 const int type = SvTYPE(dbsv);
6175 if (type < SVt_PVIV && type != SVt_IV)
6176 sv_upgrade(dbsv, SVt_PVIV);
6177 (void)SvIOK_on(dbsv);
6178 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6180 TAINT_IF(save_taint);
6181 #ifdef NO_TAINT_SUPPORT
6182 PERL_UNUSED_VAR(save_taint);
6187 Perl_my_dirfd(pTHX_ DIR * dir) {
6189 /* Most dirfd implementations have problems when passed NULL. */
6194 #elif defined(HAS_DIR_DD_FD)
6197 Perl_die(aTHX_ PL_no_func, "dirfd");
6198 assert(0); /* NOT REACHED */
6204 Perl_get_re_arg(pTHX_ SV *sv) {
6210 sv = MUTABLE_SV(SvRV(sv));
6211 if (SvTYPE(sv) == SVt_REGEXP)
6212 return (REGEXP*) sv;
6219 * This code is derived from drand48() implementation from FreeBSD,
6220 * found in lib/libc/gen/_rand48.c.
6222 * The U64 implementation is original, based on the POSIX
6223 * specification for drand48().
6227 * Copyright (c) 1993 Martin Birgmeier
6228 * All rights reserved.
6230 * You may redistribute unmodified or modified versions of this source
6231 * code provided that the above copyright notice and this and the
6232 * following conditions are retained.
6234 * This software is provided ``as is'', and comes with no warranties
6235 * of any kind. I shall in no event be liable for anything that happens
6236 * to anyone/anything when using this software.
6239 #define FREEBSD_DRAND48_SEED_0 (0x330e)
6241 #ifdef PERL_DRAND48_QUAD
6243 #define DRAND48_MULT 0x5deece66d
6244 #define DRAND48_ADD 0xb
6245 #define DRAND48_MASK 0xffffffffffff
6249 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
6250 #define FREEBSD_DRAND48_SEED_2 (0x1234)
6251 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
6252 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
6253 #define FREEBSD_DRAND48_MULT_2 (0x0005)
6254 #define FREEBSD_DRAND48_ADD (0x000b)
6256 const unsigned short _rand48_mult[3] = {
6257 FREEBSD_DRAND48_MULT_0,
6258 FREEBSD_DRAND48_MULT_1,
6259 FREEBSD_DRAND48_MULT_2
6261 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
6266 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
6268 PERL_ARGS_ASSERT_DRAND48_INIT_R;
6270 #ifdef PERL_DRAND48_QUAD
6271 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
6273 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
6274 random_state->seed[1] = (U16) seed;
6275 random_state->seed[2] = (U16) (seed >> 16);
6280 Perl_drand48_r(perl_drand48_t *random_state)
6282 PERL_ARGS_ASSERT_DRAND48_R;
6284 #ifdef PERL_DRAND48_QUAD
6285 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
6288 return ldexp(*random_state, -48);
6294 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
6295 + (U32) _rand48_add;
6296 temp[0] = (U16) accu; /* lower 16 bits */
6297 accu >>= sizeof(U16) * 8;
6298 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
6299 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
6300 temp[1] = (U16) accu; /* middle 16 bits */
6301 accu >>= sizeof(U16) * 8;
6302 accu += _rand48_mult[0] * random_state->seed[2]
6303 + _rand48_mult[1] * random_state->seed[1]
6304 + _rand48_mult[2] * random_state->seed[0];
6305 random_state->seed[0] = temp[0];
6306 random_state->seed[1] = temp[1];
6307 random_state->seed[2] = (U16) accu;
6309 return ldexp((double) random_state->seed[0], -48) +
6310 ldexp((double) random_state->seed[1], -32) +
6311 ldexp((double) random_state->seed[2], -16);
6319 * c-indentation-style: bsd
6321 * indent-tabs-mode: nil
6324 * ex: set ts=8 sts=4 sw=4 et: