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
79 #ifdef PERL_TRACK_MEMPOOL
83 if ((SSize_t)size < 0)
84 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
86 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
87 PERL_ALLOC_CHECK(ptr);
89 #ifdef PERL_TRACK_MEMPOOL
90 struct perl_memory_debug_header *const header
91 = (struct perl_memory_debug_header *)ptr;
95 PoisonNew(((char *)ptr), size, char);
98 #ifdef PERL_TRACK_MEMPOOL
99 header->interpreter = aTHX;
100 /* Link us into the list. */
101 header->prev = &PL_memory_debug_header;
102 header->next = PL_memory_debug_header.next;
103 PL_memory_debug_header.next = header;
104 header->next->prev = header;
108 ptr = (Malloc_t)((char*)ptr+sTHX);
110 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
114 #ifndef ALWAYS_NEED_THX
126 /* paranoid version of system's realloc() */
129 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
131 #ifdef ALWAYS_NEED_THX
135 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
136 Malloc_t PerlMem_realloc();
137 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
145 return safesysmalloc(size);
146 #ifdef PERL_TRACK_MEMPOOL
147 where = (Malloc_t)((char*)where-sTHX);
150 struct perl_memory_debug_header *const header
151 = (struct perl_memory_debug_header *)where;
153 if (header->interpreter != aTHX) {
154 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
155 header->interpreter, aTHX);
157 assert(header->next->prev == header);
158 assert(header->prev->next == header);
160 if (header->size > size) {
161 const MEM_SIZE freed_up = header->size - size;
162 char *start_of_freed = ((char *)where) + size;
163 PoisonFree(start_of_freed, freed_up, char);
170 if ((SSize_t)size < 0)
171 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
173 ptr = (Malloc_t)PerlMem_realloc(where,size);
174 PERL_ALLOC_CHECK(ptr);
176 /* MUST do this fixup first, before doing ANYTHING else, as anything else
177 might allocate memory/free/move memory, and until we do the fixup, it
178 may well be chasing (and writing to) free memory. */
179 #ifdef PERL_TRACK_MEMPOOL
181 struct perl_memory_debug_header *const header
182 = (struct perl_memory_debug_header *)ptr;
185 if (header->size < size) {
186 const MEM_SIZE fresh = size - header->size;
187 char *start_of_fresh = ((char *)ptr) + size;
188 PoisonNew(start_of_fresh, fresh, char);
192 header->next->prev = header;
193 header->prev->next = header;
195 ptr = (Malloc_t)((char*)ptr+sTHX);
199 /* In particular, must do that fixup above before logging anything via
200 *printf(), as it can reallocate memory, which can cause SEGVs. */
202 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
203 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
210 #ifndef ALWAYS_NEED_THX
222 /* safe version of system's free() */
225 Perl_safesysfree(Malloc_t where)
227 #ifdef ALWAYS_NEED_THX
232 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
234 #ifdef PERL_TRACK_MEMPOOL
235 where = (Malloc_t)((char*)where-sTHX);
237 struct perl_memory_debug_header *const header
238 = (struct perl_memory_debug_header *)where;
240 if (header->interpreter != aTHX) {
241 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
242 header->interpreter, aTHX);
245 Perl_croak_nocontext("panic: duplicate free");
248 Perl_croak_nocontext("panic: bad free, header->next==NULL");
249 if (header->next->prev != header || header->prev->next != header) {
250 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
251 "header=%p, ->prev->next=%p",
252 header->next->prev, header,
255 /* Unlink us from the chain. */
256 header->next->prev = header->prev;
257 header->prev->next = header->next;
259 PoisonNew(where, header->size, char);
261 /* Trigger the duplicate free warning. */
269 /* safe version of system's calloc() */
272 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
274 #ifdef ALWAYS_NEED_THX
278 #if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
279 MEM_SIZE total_size = 0;
282 /* Even though calloc() for zero bytes is strange, be robust. */
283 if (size && (count <= MEM_SIZE_MAX / size)) {
284 #if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
285 total_size = size * count;
290 #ifdef PERL_TRACK_MEMPOOL
291 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
297 if ((SSize_t)size < 0 || (SSize_t)count < 0)
298 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
299 (UV)size, (UV)count);
301 #ifdef PERL_TRACK_MEMPOOL
302 /* Have to use malloc() because we've added some space for our tracking
304 /* malloc(0) is non-portable. */
305 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
307 /* Use calloc() because it might save a memset() if the memory is fresh
308 and clean from the OS. */
310 ptr = (Malloc_t)PerlMem_calloc(count, size);
311 else /* calloc(0) is non-portable. */
312 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
314 PERL_ALLOC_CHECK(ptr);
315 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
317 #ifdef PERL_TRACK_MEMPOOL
319 struct perl_memory_debug_header *const header
320 = (struct perl_memory_debug_header *)ptr;
322 memset((void*)ptr, 0, total_size);
323 header->interpreter = aTHX;
324 /* Link us into the list. */
325 header->prev = &PL_memory_debug_header;
326 header->next = PL_memory_debug_header.next;
327 PL_memory_debug_header.next = header;
328 header->next->prev = header;
330 header->size = total_size;
332 ptr = (Malloc_t)((char*)ptr+sTHX);
338 #ifndef ALWAYS_NEED_THX
347 /* These must be defined when not using Perl's malloc for binary
352 Malloc_t Perl_malloc (MEM_SIZE nbytes)
355 return (Malloc_t)PerlMem_malloc(nbytes);
358 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
361 return (Malloc_t)PerlMem_calloc(elements, size);
364 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
367 return (Malloc_t)PerlMem_realloc(where, nbytes);
370 Free_t Perl_mfree (Malloc_t where)
378 /* copy a string up to some (non-backslashed) delimiter, if any */
381 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
385 PERL_ARGS_ASSERT_DELIMCPY;
387 for (tolen = 0; from < fromend; from++, tolen++) {
389 if (from[1] != delim) {
396 else if (*from == delim)
407 /* return ptr to little string in big string, NULL if not found */
408 /* This routine was donated by Corey Satten. */
411 Perl_instr(const char *big, const char *little)
414 PERL_ARGS_ASSERT_INSTR;
416 /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
419 return strstr((char*)big, (char*)little);
422 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond
423 * the final character desired to be checked */
426 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
428 PERL_ARGS_ASSERT_NINSTR;
432 const char first = *little;
434 bigend -= lend - little++;
436 while (big <= bigend) {
437 if (*big++ == first) {
438 for (x=big,s=little; s < lend; x++,s++) {
442 return (char*)(big-1);
449 /* reverse of the above--find last substring */
452 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
455 const I32 first = *little;
456 const char * const littleend = lend;
458 PERL_ARGS_ASSERT_RNINSTR;
460 if (little >= littleend)
461 return (char*)bigend;
463 big = bigend - (littleend - little++);
464 while (big >= bigbeg) {
468 for (x=big+2,s=little; s < littleend; /**/ ) {
477 return (char*)(big+1);
482 /* As a space optimization, we do not compile tables for strings of length
483 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
484 special-cased in fbm_instr().
486 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
489 =head1 Miscellaneous Functions
491 =for apidoc fbm_compile
493 Analyses the string in order to make fast searches on it using fbm_instr()
494 -- the Boyer-Moore algorithm.
500 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
508 PERL_DEB( STRLEN rarest = 0 );
510 PERL_ARGS_ASSERT_FBM_COMPILE;
512 if (isGV_with_GP(sv) || SvROK(sv))
518 if (flags & FBMcf_TAIL) {
519 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
520 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
521 if (mg && mg->mg_len >= 0)
524 if (!SvPOK(sv) || SvNIOKp(sv))
525 s = (U8*)SvPV_force_mutable(sv, len);
526 else s = (U8 *)SvPV_mutable(sv, len);
527 if (len == 0) /* TAIL might be on a zero-length string. */
529 SvUPGRADE(sv, SVt_PVMG);
534 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
535 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
536 to call SvVALID_off() if the scalar was assigned to.
538 The comment itself (and "deeper magic" below) date back to
539 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
541 where the magic (presumably) was that the scalar had a BM table hidden
544 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
545 the table instead of the previous (somewhat hacky) approach of co-opting
546 the string buffer and storing it after the string. */
548 assert(!mg_find(sv, PERL_MAGIC_bm));
549 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
553 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
555 const U8 mlen = (len>255) ? 255 : (U8)len;
556 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
559 Newx(table, 256, U8);
560 memset((void*)table, mlen, 256);
561 mg->mg_ptr = (char *)table;
564 s += len - 1; /* last char */
567 if (table[*s] == mlen)
573 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
574 for (i = 0; i < len; i++) {
575 if (PL_freq[s[i]] < frequency) {
576 PERL_DEB( rarest = i );
577 frequency = PL_freq[s[i]];
580 BmUSEFUL(sv) = 100; /* Initial value */
581 if (flags & FBMcf_TAIL)
583 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
584 s[rarest], (UV)rarest));
587 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
588 /* If SvTAIL is actually due to \Z or \z, this gives false positives
592 =for apidoc fbm_instr
594 Returns the location of the SV in the string delimited by C<big> and
595 C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
596 does not have to be fbm_compiled, but the search will not be as fast
603 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
607 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
608 STRLEN littlelen = l;
609 const I32 multiline = flags & FBMrf_MULTILINE;
611 PERL_ARGS_ASSERT_FBM_INSTR;
613 if ((STRLEN)(bigend - big) < littlelen) {
614 if ( SvTAIL(littlestr)
615 && ((STRLEN)(bigend - big) == littlelen - 1)
617 || (*big == *little &&
618 memEQ((char *)big, (char *)little, littlelen - 1))))
623 switch (littlelen) { /* Special cases for 0, 1 and 2 */
625 return (char*)big; /* Cannot be SvTAIL! */
627 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
628 /* Know that bigend != big. */
629 if (bigend[-1] == '\n')
630 return (char *)(bigend - 1);
631 return (char *) bigend;
639 if (SvTAIL(littlestr))
640 return (char *) bigend;
643 if (SvTAIL(littlestr) && !multiline) {
644 if (bigend[-1] == '\n' && bigend[-2] == *little)
645 return (char*)bigend - 2;
646 if (bigend[-1] == *little)
647 return (char*)bigend - 1;
651 /* This should be better than FBM if c1 == c2, and almost
652 as good otherwise: maybe better since we do less indirection.
653 And we save a lot of memory by caching no table. */
654 const unsigned char c1 = little[0];
655 const unsigned char c2 = little[1];
660 while (s <= bigend) {
670 goto check_1char_anchor;
681 goto check_1char_anchor;
684 while (s <= bigend) {
689 goto check_1char_anchor;
698 check_1char_anchor: /* One char and anchor! */
699 if (SvTAIL(littlestr) && (*bigend == *little))
700 return (char *)bigend; /* bigend is already decremented. */
703 break; /* Only lengths 0 1 and 2 have special-case code. */
706 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
707 s = bigend - littlelen;
708 if (s >= big && bigend[-1] == '\n' && *s == *little
709 /* Automatically of length > 2 */
710 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
712 return (char*)s; /* how sweet it is */
715 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
717 return (char*)s + 1; /* how sweet it is */
721 if (!SvVALID(littlestr)) {
722 char * const b = ninstr((char*)big,(char*)bigend,
723 (char*)little, (char*)little + littlelen);
725 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
726 /* Chop \n from littlestr: */
727 s = bigend - littlelen + 1;
729 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
739 if (littlelen > (STRLEN)(bigend - big))
743 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
744 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
745 const unsigned char *oldlittle;
747 --littlelen; /* Last char found by table lookup */
750 little += littlelen; /* last char */
756 if ((tmp = table[*s])) {
757 if ((s += tmp) < bigend)
761 else { /* less expensive than calling strncmp() */
762 unsigned char * const olds = s;
767 if (*--s == *--little)
769 s = olds + 1; /* here we pay the price for failure */
771 if (s < bigend) /* fake up continue to outer loop */
781 && memEQ((char *)(bigend - littlelen),
782 (char *)(oldlittle - littlelen), littlelen) )
783 return (char*)bigend - littlelen;
789 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
792 PERL_ARGS_ASSERT_SCREAMINSTR;
793 PERL_UNUSED_ARG(bigstr);
794 PERL_UNUSED_ARG(littlestr);
795 PERL_UNUSED_ARG(start_shift);
796 PERL_UNUSED_ARG(end_shift);
797 PERL_UNUSED_ARG(old_posp);
798 PERL_UNUSED_ARG(last);
800 /* This function must only ever be called on a scalar with study magic,
801 but those do not happen any more. */
802 Perl_croak(aTHX_ "panic: screaminstr");
809 Returns true if the leading len bytes of the strings s1 and s2 are the same
810 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
811 match themselves and their opposite case counterparts. Non-cased and non-ASCII
812 range bytes match only themselves.
819 Perl_foldEQ(const char *s1, const char *s2, I32 len)
821 const U8 *a = (const U8 *)s1;
822 const U8 *b = (const U8 *)s2;
824 PERL_ARGS_ASSERT_FOLDEQ;
829 if (*a != *b && *a != PL_fold[*b])
836 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
838 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
839 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
840 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
841 * does it check that the strings each have at least 'len' characters */
843 const U8 *a = (const U8 *)s1;
844 const U8 *b = (const U8 *)s2;
846 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
851 if (*a != *b && *a != PL_fold_latin1[*b]) {
860 =for apidoc foldEQ_locale
862 Returns true if the leading len bytes of the strings s1 and s2 are the same
863 case-insensitively in the current locale; false otherwise.
869 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
872 const U8 *a = (const U8 *)s1;
873 const U8 *b = (const U8 *)s2;
875 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
880 if (*a != *b && *a != PL_fold_locale[*b])
887 /* copy a string to a safe spot */
890 =head1 Memory Management
894 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
895 string which is a duplicate of C<pv>. The size of the string is
896 determined by C<strlen()>. The memory allocated for the new string can
897 be freed with the C<Safefree()> function.
903 Perl_savepv(pTHX_ const char *pv)
910 const STRLEN pvlen = strlen(pv)+1;
911 Newx(newaddr, pvlen, char);
912 return (char*)memcpy(newaddr, pv, pvlen);
916 /* same thing but with a known length */
921 Perl's version of what C<strndup()> would be if it existed. Returns a
922 pointer to a newly allocated string which is a duplicate of the first
923 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
924 the new string can be freed with the C<Safefree()> function.
930 Perl_savepvn(pTHX_ const char *pv, I32 len)
937 Newx(newaddr,len+1,char);
938 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
940 /* might not be null terminated */
942 return (char *) CopyD(pv,newaddr,len,char);
945 return (char *) ZeroD(newaddr,len+1,char);
950 =for apidoc savesharedpv
952 A version of C<savepv()> which allocates the duplicate string in memory
953 which is shared between threads.
958 Perl_savesharedpv(pTHX_ const char *pv)
965 pvlen = strlen(pv)+1;
966 newaddr = (char*)PerlMemShared_malloc(pvlen);
970 return (char*)memcpy(newaddr, pv, pvlen);
974 =for apidoc savesharedpvn
976 A version of C<savepvn()> which allocates the duplicate string in memory
977 which is shared between threads. (With the specific difference that a NULL
978 pointer is not acceptable)
983 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
985 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
987 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
993 return (char*)memcpy(newaddr, pv, len);
999 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1000 the passed in SV using C<SvPV()>
1006 Perl_savesvpv(pTHX_ SV *sv)
1009 const char * const pv = SvPV_const(sv, len);
1012 PERL_ARGS_ASSERT_SAVESVPV;
1015 Newx(newaddr,len,char);
1016 return (char *) CopyD(pv,newaddr,len,char);
1020 =for apidoc savesharedsvpv
1022 A version of C<savesharedpv()> which allocates the duplicate string in
1023 memory which is shared between threads.
1029 Perl_savesharedsvpv(pTHX_ SV *sv)
1032 const char * const pv = SvPV_const(sv, len);
1034 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1036 return savesharedpvn(pv, len);
1039 /* the SV for Perl_form() and mess() is not kept in an arena */
1048 if (PL_phase != PERL_PHASE_DESTRUCT)
1049 return newSVpvs_flags("", SVs_TEMP);
1054 /* Create as PVMG now, to avoid any upgrading later */
1056 Newxz(any, 1, XPVMG);
1057 SvFLAGS(sv) = SVt_PVMG;
1058 SvANY(sv) = (void*)any;
1060 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1065 #if defined(PERL_IMPLICIT_CONTEXT)
1067 Perl_form_nocontext(const char* pat, ...)
1072 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1073 va_start(args, pat);
1074 retval = vform(pat, &args);
1078 #endif /* PERL_IMPLICIT_CONTEXT */
1081 =head1 Miscellaneous Functions
1084 Takes a sprintf-style format pattern and conventional
1085 (non-SV) arguments and returns the formatted string.
1087 (char *) Perl_form(pTHX_ const char* pat, ...)
1089 can be used any place a string (char *) is required:
1091 char * s = Perl_form("%d.%d",major,minor);
1093 Uses a single private buffer so if you want to format several strings you
1094 must explicitly copy the earlier strings away (and free the copies when you
1101 Perl_form(pTHX_ const char* pat, ...)
1105 PERL_ARGS_ASSERT_FORM;
1106 va_start(args, pat);
1107 retval = vform(pat, &args);
1113 Perl_vform(pTHX_ const char *pat, va_list *args)
1115 SV * const sv = mess_alloc();
1116 PERL_ARGS_ASSERT_VFORM;
1117 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1122 =for apidoc Am|SV *|mess|const char *pat|...
1124 Take a sprintf-style format pattern and argument list. These are used to
1125 generate a string message. If the message does not end with a newline,
1126 then it will be extended with some indication of the current location
1127 in the code, as described for L</mess_sv>.
1129 Normally, the resulting message is returned in a new mortal SV.
1130 During global destruction a single SV may be shared between uses of
1136 #if defined(PERL_IMPLICIT_CONTEXT)
1138 Perl_mess_nocontext(const char *pat, ...)
1143 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1144 va_start(args, pat);
1145 retval = vmess(pat, &args);
1149 #endif /* PERL_IMPLICIT_CONTEXT */
1152 Perl_mess(pTHX_ const char *pat, ...)
1156 PERL_ARGS_ASSERT_MESS;
1157 va_start(args, pat);
1158 retval = vmess(pat, &args);
1164 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1168 /* Look for curop starting from o. cop is the last COP we've seen. */
1169 /* opnext means that curop is actually the ->op_next of the op we are
1172 PERL_ARGS_ASSERT_CLOSEST_COP;
1174 if (!o || !curop || (
1175 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1179 if (o->op_flags & OPf_KIDS) {
1181 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1184 /* If the OP_NEXTSTATE has been optimised away we can still use it
1185 * the get the file and line number. */
1187 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1188 cop = (const COP *)kid;
1190 /* Keep searching, and return when we've found something. */
1192 new_cop = closest_cop(cop, kid, curop, opnext);
1198 /* Nothing found. */
1204 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1206 Expands a message, intended for the user, to include an indication of
1207 the current location in the code, if the message does not already appear
1210 C<basemsg> is the initial message or object. If it is a reference, it
1211 will be used as-is and will be the result of this function. Otherwise it
1212 is used as a string, and if it already ends with a newline, it is taken
1213 to be complete, and the result of this function will be the same string.
1214 If the message does not end with a newline, then a segment such as C<at
1215 foo.pl line 37> will be appended, and possibly other clauses indicating
1216 the current state of execution. The resulting message will end with a
1219 Normally, the resulting message is returned in a new mortal SV.
1220 During global destruction a single SV may be shared between uses of this
1221 function. If C<consume> is true, then the function is permitted (but not
1222 required) to modify and return C<basemsg> instead of allocating a new SV.
1228 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1233 PERL_ARGS_ASSERT_MESS_SV;
1235 if (SvROK(basemsg)) {
1241 sv_setsv(sv, basemsg);
1246 if (SvPOK(basemsg) && consume) {
1251 sv_copypv(sv, basemsg);
1254 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1256 * Try and find the file and line for PL_op. This will usually be
1257 * PL_curcop, but it might be a cop that has been optimised away. We
1258 * can try to find such a cop by searching through the optree starting
1259 * from the sibling of PL_curcop.
1263 closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
1268 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1269 OutCopFILE(cop), (IV)CopLINE(cop));
1270 /* Seems that GvIO() can be untrustworthy during global destruction. */
1271 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1272 && IoLINES(GvIOp(PL_last_in_gv)))
1275 const bool line_mode = (RsSIMPLE(PL_rs) &&
1276 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1277 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1278 SVfARG(PL_last_in_gv == PL_argvgv
1280 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1281 line_mode ? "line" : "chunk",
1282 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1284 if (PL_phase == PERL_PHASE_DESTRUCT)
1285 sv_catpvs(sv, " during global destruction");
1286 sv_catpvs(sv, ".\n");
1292 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1294 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1295 argument list. These are used to generate a string message. If the
1296 message does not end with a newline, then it will be extended with
1297 some indication of the current location in the code, as described for
1300 Normally, the resulting message is returned in a new mortal SV.
1301 During global destruction a single SV may be shared between uses of
1308 Perl_vmess(pTHX_ const char *pat, va_list *args)
1311 SV * const sv = mess_alloc();
1313 PERL_ARGS_ASSERT_VMESS;
1315 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1316 return mess_sv(sv, 1);
1320 Perl_write_to_stderr(pTHX_ SV* msv)
1326 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1328 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1329 && (io = GvIO(PL_stderrgv))
1330 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1331 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1332 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1335 /* SFIO can really mess with your errno */
1338 PerlIO * const serr = Perl_error_log;
1340 do_print(msv, serr);
1341 (void)PerlIO_flush(serr);
1349 =head1 Warning and Dieing
1352 /* Common code used in dieing and warning */
1355 S_with_queued_errors(pTHX_ SV *ex)
1357 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1358 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1359 sv_catsv(PL_errors, ex);
1360 ex = sv_mortalcopy(PL_errors);
1361 SvCUR_set(PL_errors, 0);
1367 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1373 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1374 /* sv_2cv might call Perl_croak() or Perl_warner() */
1375 SV * const oldhook = *hook;
1383 cv = sv_2cv(oldhook, &stash, &gv, 0);
1385 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1395 exarg = newSVsv(ex);
1396 SvREADONLY_on(exarg);
1399 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1403 call_sv(MUTABLE_SV(cv), G_DISCARD);
1412 =for apidoc Am|OP *|die_sv|SV *baseex
1414 Behaves the same as L</croak_sv>, except for the return type.
1415 It should be used only where the C<OP *> return type is required.
1416 The function never actually returns.
1422 Perl_die_sv(pTHX_ SV *baseex)
1424 PERL_ARGS_ASSERT_DIE_SV;
1426 assert(0); /* NOTREACHED */
1431 =for apidoc Am|OP *|die|const char *pat|...
1433 Behaves the same as L</croak>, except for the return type.
1434 It should be used only where the C<OP *> return type is required.
1435 The function never actually returns.
1440 #if defined(PERL_IMPLICIT_CONTEXT)
1442 Perl_die_nocontext(const char* pat, ...)
1446 va_start(args, pat);
1448 assert(0); /* NOTREACHED */
1452 #endif /* PERL_IMPLICIT_CONTEXT */
1455 Perl_die(pTHX_ const char* pat, ...)
1458 va_start(args, pat);
1460 assert(0); /* NOTREACHED */
1466 =for apidoc Am|void|croak_sv|SV *baseex
1468 This is an XS interface to Perl's C<die> function.
1470 C<baseex> is the error message or object. If it is a reference, it
1471 will be used as-is. Otherwise it is used as a string, and if it does
1472 not end with a newline then it will be extended with some indication of
1473 the current location in the code, as described for L</mess_sv>.
1475 The error message or object will be used as an exception, by default
1476 returning control to the nearest enclosing C<eval>, but subject to
1477 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1478 function never returns normally.
1480 To die with a simple string message, the L</croak> function may be
1487 Perl_croak_sv(pTHX_ SV *baseex)
1489 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1490 PERL_ARGS_ASSERT_CROAK_SV;
1491 invoke_exception_hook(ex, FALSE);
1496 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1498 This is an XS interface to Perl's C<die> function.
1500 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1501 argument list. These are used to generate a string message. If the
1502 message does not end with a newline, then it will be extended with
1503 some indication of the current location in the code, as described for
1506 The error message will be used as an exception, by default
1507 returning control to the nearest enclosing C<eval>, but subject to
1508 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1509 function never returns normally.
1511 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1512 (C<$@>) will be used as an error message or object instead of building an
1513 error message from arguments. If you want to throw a non-string object,
1514 or build an error message in an SV yourself, it is preferable to use
1515 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1521 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1523 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1524 invoke_exception_hook(ex, FALSE);
1529 =for apidoc Am|void|croak|const char *pat|...
1531 This is an XS interface to Perl's C<die> function.
1533 Take a sprintf-style format pattern and argument list. These are used to
1534 generate a string message. If the message does not end with a newline,
1535 then it will be extended with some indication of the current location
1536 in the code, as described for L</mess_sv>.
1538 The error message will be used as an exception, by default
1539 returning control to the nearest enclosing C<eval>, but subject to
1540 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1541 function never returns normally.
1543 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1544 (C<$@>) will be used as an error message or object instead of building an
1545 error message from arguments. If you want to throw a non-string object,
1546 or build an error message in an SV yourself, it is preferable to use
1547 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1552 #if defined(PERL_IMPLICIT_CONTEXT)
1554 Perl_croak_nocontext(const char *pat, ...)
1558 va_start(args, pat);
1560 assert(0); /* NOTREACHED */
1563 #endif /* PERL_IMPLICIT_CONTEXT */
1566 Perl_croak(pTHX_ const char *pat, ...)
1569 va_start(args, pat);
1571 assert(0); /* NOTREACHED */
1576 =for apidoc Am|void|croak_no_modify
1578 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1579 terser object code than using C<Perl_croak>. Less code used on exception code
1580 paths reduces CPU cache pressure.
1586 Perl_croak_no_modify()
1588 Perl_croak_nocontext( "%s", PL_no_modify);
1591 /* does not return, used in util.c perlio.c and win32.c
1592 This is typically called when malloc returns NULL.
1600 /* Can't use PerlIO to write as it allocates memory */
1601 rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
1602 PL_no_mem, sizeof(PL_no_mem)-1);
1603 /* silently ignore failures */
1604 PERL_UNUSED_VAR(rc);
1608 /* does not return, used only in POPSTACK */
1610 Perl_croak_popstack(void)
1613 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1618 =for apidoc Am|void|warn_sv|SV *baseex
1620 This is an XS interface to Perl's C<warn> function.
1622 C<baseex> is the error message or object. If it is a reference, it
1623 will be used as-is. Otherwise it is used as a string, and if it does
1624 not end with a newline then it will be extended with some indication of
1625 the current location in the code, as described for L</mess_sv>.
1627 The error message or object will by default be written to standard error,
1628 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1630 To warn with a simple string message, the L</warn> function may be
1637 Perl_warn_sv(pTHX_ SV *baseex)
1639 SV *ex = mess_sv(baseex, 0);
1640 PERL_ARGS_ASSERT_WARN_SV;
1641 if (!invoke_exception_hook(ex, TRUE))
1642 write_to_stderr(ex);
1646 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1648 This is an XS interface to Perl's C<warn> function.
1650 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1651 argument list. These are used to generate a string message. If the
1652 message does not end with a newline, then it will be extended with
1653 some indication of the current location in the code, as described for
1656 The error message or object will by default be written to standard error,
1657 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1659 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1665 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1667 SV *ex = vmess(pat, args);
1668 PERL_ARGS_ASSERT_VWARN;
1669 if (!invoke_exception_hook(ex, TRUE))
1670 write_to_stderr(ex);
1674 =for apidoc Am|void|warn|const char *pat|...
1676 This is an XS interface to Perl's C<warn> function.
1678 Take a sprintf-style format pattern and argument list. These are used to
1679 generate a string message. If the message does not end with a newline,
1680 then it will be extended with some indication of the current location
1681 in the code, as described for L</mess_sv>.
1683 The error message or object will by default be written to standard error,
1684 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1686 Unlike with L</croak>, C<pat> is not permitted to be null.
1691 #if defined(PERL_IMPLICIT_CONTEXT)
1693 Perl_warn_nocontext(const char *pat, ...)
1697 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1698 va_start(args, pat);
1702 #endif /* PERL_IMPLICIT_CONTEXT */
1705 Perl_warn(pTHX_ const char *pat, ...)
1708 PERL_ARGS_ASSERT_WARN;
1709 va_start(args, pat);
1714 #if defined(PERL_IMPLICIT_CONTEXT)
1716 Perl_warner_nocontext(U32 err, const char *pat, ...)
1720 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1721 va_start(args, pat);
1722 vwarner(err, pat, &args);
1725 #endif /* PERL_IMPLICIT_CONTEXT */
1728 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1730 PERL_ARGS_ASSERT_CK_WARNER_D;
1732 if (Perl_ckwarn_d(aTHX_ err)) {
1734 va_start(args, pat);
1735 vwarner(err, pat, &args);
1741 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1743 PERL_ARGS_ASSERT_CK_WARNER;
1745 if (Perl_ckwarn(aTHX_ err)) {
1747 va_start(args, pat);
1748 vwarner(err, pat, &args);
1754 Perl_warner(pTHX_ U32 err, const char* pat,...)
1757 PERL_ARGS_ASSERT_WARNER;
1758 va_start(args, pat);
1759 vwarner(err, pat, &args);
1764 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1767 PERL_ARGS_ASSERT_VWARNER;
1768 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1769 SV * const msv = vmess(pat, args);
1771 invoke_exception_hook(msv, FALSE);
1775 Perl_vwarn(aTHX_ pat, args);
1779 /* implements the ckWARN? macros */
1782 Perl_ckwarn(pTHX_ U32 w)
1785 /* If lexical warnings have not been set, use $^W. */
1787 return PL_dowarn & G_WARN_ON;
1789 return ckwarn_common(w);
1792 /* implements the ckWARN?_d macro */
1795 Perl_ckwarn_d(pTHX_ U32 w)
1798 /* If lexical warnings have not been set then default classes warn. */
1802 return ckwarn_common(w);
1806 S_ckwarn_common(pTHX_ U32 w)
1808 if (PL_curcop->cop_warnings == pWARN_ALL)
1811 if (PL_curcop->cop_warnings == pWARN_NONE)
1814 /* Check the assumption that at least the first slot is non-zero. */
1815 assert(unpackWARN1(w));
1817 /* Check the assumption that it is valid to stop as soon as a zero slot is
1819 if (!unpackWARN2(w)) {
1820 assert(!unpackWARN3(w));
1821 assert(!unpackWARN4(w));
1822 } else if (!unpackWARN3(w)) {
1823 assert(!unpackWARN4(w));
1826 /* Right, dealt with all the special cases, which are implemented as non-
1827 pointers, so there is a pointer to a real warnings mask. */
1829 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1831 } while (w >>= WARNshift);
1836 /* Set buffer=NULL to get a new one. */
1838 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1840 const MEM_SIZE len_wanted =
1841 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1842 PERL_UNUSED_CONTEXT;
1843 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1846 (specialWARN(buffer) ?
1847 PerlMemShared_malloc(len_wanted) :
1848 PerlMemShared_realloc(buffer, len_wanted));
1850 Copy(bits, (buffer + 1), size, char);
1851 if (size < WARNsize)
1852 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1856 /* since we've already done strlen() for both nam and val
1857 * we can use that info to make things faster than
1858 * sprintf(s, "%s=%s", nam, val)
1860 #define my_setenv_format(s, nam, nlen, val, vlen) \
1861 Copy(nam, s, nlen, char); \
1863 Copy(val, s+(nlen+1), vlen, char); \
1864 *(s+(nlen+1+vlen)) = '\0'
1866 #ifdef USE_ENVIRON_ARRAY
1867 /* VMS' my_setenv() is in vms.c */
1868 #if !defined(WIN32) && !defined(NETWARE)
1870 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1874 /* only parent thread can modify process environment */
1875 if (PL_curinterp == aTHX)
1878 #ifndef PERL_USE_SAFE_PUTENV
1879 if (!PL_use_safe_putenv) {
1880 /* most putenv()s leak, so we manipulate environ directly */
1882 const I32 len = strlen(nam);
1885 /* where does it go? */
1886 for (i = 0; environ[i]; i++) {
1887 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1891 if (environ == PL_origenviron) { /* need we copy environment? */
1897 while (environ[max])
1899 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1900 for (j=0; j<max; j++) { /* copy environment */
1901 const int len = strlen(environ[j]);
1902 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1903 Copy(environ[j], tmpenv[j], len+1, char);
1906 environ = tmpenv; /* tell exec where it is now */
1909 safesysfree(environ[i]);
1910 while (environ[i]) {
1911 environ[i] = environ[i+1];
1916 if (!environ[i]) { /* does not exist yet */
1917 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1918 environ[i+1] = NULL; /* make sure it's null terminated */
1921 safesysfree(environ[i]);
1925 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1926 /* all that work just for this */
1927 my_setenv_format(environ[i], nam, nlen, val, vlen);
1930 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
1931 # if defined(HAS_UNSETENV)
1933 (void)unsetenv(nam);
1935 (void)setenv(nam, val, 1);
1937 # else /* ! HAS_UNSETENV */
1938 (void)setenv(nam, val, 1);
1939 # endif /* HAS_UNSETENV */
1941 # if defined(HAS_UNSETENV)
1943 if (environ) /* old glibc can crash with null environ */
1944 (void)unsetenv(nam);
1946 const int nlen = strlen(nam);
1947 const int vlen = strlen(val);
1948 char * const new_env =
1949 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1950 my_setenv_format(new_env, nam, nlen, val, vlen);
1951 (void)putenv(new_env);
1953 # else /* ! HAS_UNSETENV */
1955 const int nlen = strlen(nam);
1961 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1962 /* all that work just for this */
1963 my_setenv_format(new_env, nam, nlen, val, vlen);
1964 (void)putenv(new_env);
1965 # endif /* HAS_UNSETENV */
1966 # endif /* __CYGWIN__ */
1967 #ifndef PERL_USE_SAFE_PUTENV
1973 #else /* WIN32 || NETWARE */
1976 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1980 const int nlen = strlen(nam);
1987 Newx(envstr, nlen+vlen+2, char);
1988 my_setenv_format(envstr, nam, nlen, val, vlen);
1989 (void)PerlEnv_putenv(envstr);
1993 #endif /* WIN32 || NETWARE */
1997 #ifdef UNLINK_ALL_VERSIONS
1999 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2003 PERL_ARGS_ASSERT_UNLNK;
2005 while (PerlLIO_unlink(f) >= 0)
2007 return retries ? 0 : -1;
2011 /* this is a drop-in replacement for bcopy() */
2012 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2014 Perl_my_bcopy(const char *from, char *to, I32 len)
2016 char * const retval = to;
2018 PERL_ARGS_ASSERT_MY_BCOPY;
2022 if (from - to >= 0) {
2030 *(--to) = *(--from);
2036 /* this is a drop-in replacement for memset() */
2039 Perl_my_memset(char *loc, I32 ch, I32 len)
2041 char * const retval = loc;
2043 PERL_ARGS_ASSERT_MY_MEMSET;
2053 /* this is a drop-in replacement for bzero() */
2054 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2056 Perl_my_bzero(char *loc, I32 len)
2058 char * const retval = loc;
2060 PERL_ARGS_ASSERT_MY_BZERO;
2070 /* this is a drop-in replacement for memcmp() */
2071 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2073 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2075 const U8 *a = (const U8 *)s1;
2076 const U8 *b = (const U8 *)s2;
2079 PERL_ARGS_ASSERT_MY_MEMCMP;
2084 if ((tmp = *a++ - *b++))
2089 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2092 /* This vsprintf replacement should generally never get used, since
2093 vsprintf was available in both System V and BSD 2.11. (There may
2094 be some cross-compilation or embedded set-ups where it is needed,
2097 If you encounter a problem in this function, it's probably a symptom
2098 that Configure failed to detect your system's vprintf() function.
2099 See the section on "item vsprintf" in the INSTALL file.
2101 This version may compile on systems with BSD-ish <stdio.h>,
2102 but probably won't on others.
2105 #ifdef USE_CHAR_VSPRINTF
2110 vsprintf(char *dest, const char *pat, void *args)
2114 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2115 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2116 FILE_cnt(&fakebuf) = 32767;
2118 /* These probably won't compile -- If you really need
2119 this, you'll have to figure out some other method. */
2120 fakebuf._ptr = dest;
2121 fakebuf._cnt = 32767;
2126 fakebuf._flag = _IOWRT|_IOSTRG;
2127 _doprnt(pat, args, &fakebuf); /* what a kludge */
2128 #if defined(STDIO_PTR_LVALUE)
2129 *(FILE_ptr(&fakebuf)++) = '\0';
2131 /* PerlIO has probably #defined away fputc, but we want it here. */
2133 # undef fputc /* XXX Should really restore it later */
2135 (void)fputc('\0', &fakebuf);
2137 #ifdef USE_CHAR_VSPRINTF
2140 return 0; /* perl doesn't use return value */
2144 #endif /* HAS_VPRINTF */
2147 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2149 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2158 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2160 PERL_FLUSHALL_FOR_CHILD;
2161 This = (*mode == 'w');
2165 taint_proper("Insecure %s%s", "EXEC");
2167 if (PerlProc_pipe(p) < 0)
2169 /* Try for another pipe pair for error return */
2170 if (PerlProc_pipe(pp) >= 0)
2172 while ((pid = PerlProc_fork()) < 0) {
2173 if (errno != EAGAIN) {
2174 PerlLIO_close(p[This]);
2175 PerlLIO_close(p[that]);
2177 PerlLIO_close(pp[0]);
2178 PerlLIO_close(pp[1]);
2182 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2191 /* Close parent's end of error status pipe (if any) */
2193 PerlLIO_close(pp[0]);
2194 #if defined(HAS_FCNTL) && defined(F_SETFD)
2195 /* Close error pipe automatically if exec works */
2196 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2199 /* Now dup our end of _the_ pipe to right position */
2200 if (p[THIS] != (*mode == 'r')) {
2201 PerlLIO_dup2(p[THIS], *mode == 'r');
2202 PerlLIO_close(p[THIS]);
2203 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2204 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2207 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2208 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2209 /* No automatic close - do it by hand */
2216 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2222 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2228 do_execfree(); /* free any memory malloced by child on fork */
2230 PerlLIO_close(pp[1]);
2231 /* Keep the lower of the two fd numbers */
2232 if (p[that] < p[This]) {
2233 PerlLIO_dup2(p[This], p[that]);
2234 PerlLIO_close(p[This]);
2238 PerlLIO_close(p[that]); /* close child's end of pipe */
2240 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2241 SvUPGRADE(sv,SVt_IV);
2243 PL_forkprocess = pid;
2244 /* If we managed to get status pipe check for exec fail */
2245 if (did_pipes && pid > 0) {
2250 while (n < sizeof(int)) {
2251 n1 = PerlLIO_read(pp[0],
2252 (void*)(((char*)&errkid)+n),
2258 PerlLIO_close(pp[0]);
2260 if (n) { /* Error */
2262 PerlLIO_close(p[This]);
2263 if (n != sizeof(int))
2264 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2266 pid2 = wait4pid(pid, &status, 0);
2267 } while (pid2 == -1 && errno == EINTR);
2268 errno = errkid; /* Propagate errno from kid */
2273 PerlLIO_close(pp[0]);
2274 return PerlIO_fdopen(p[This], mode);
2276 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2277 return my_syspopen4(aTHX_ NULL, mode, n, args);
2279 Perl_croak(aTHX_ "List form of piped open not implemented");
2280 return (PerlIO *) NULL;
2285 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2286 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2288 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2295 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2299 PERL_ARGS_ASSERT_MY_POPEN;
2301 PERL_FLUSHALL_FOR_CHILD;
2304 return my_syspopen(aTHX_ cmd,mode);
2307 This = (*mode == 'w');
2309 if (doexec && TAINTING_get) {
2311 taint_proper("Insecure %s%s", "EXEC");
2313 if (PerlProc_pipe(p) < 0)
2315 if (doexec && PerlProc_pipe(pp) >= 0)
2317 while ((pid = PerlProc_fork()) < 0) {
2318 if (errno != EAGAIN) {
2319 PerlLIO_close(p[This]);
2320 PerlLIO_close(p[that]);
2322 PerlLIO_close(pp[0]);
2323 PerlLIO_close(pp[1]);
2326 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2329 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2339 PerlLIO_close(pp[0]);
2340 #if defined(HAS_FCNTL) && defined(F_SETFD)
2341 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2344 if (p[THIS] != (*mode == 'r')) {
2345 PerlLIO_dup2(p[THIS], *mode == 'r');
2346 PerlLIO_close(p[THIS]);
2347 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2348 PerlLIO_close(p[THAT]);
2351 PerlLIO_close(p[THAT]);
2354 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2361 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2366 /* may or may not use the shell */
2367 do_exec3(cmd, pp[1], did_pipes);
2370 #endif /* defined OS2 */
2372 #ifdef PERLIO_USING_CRLF
2373 /* Since we circumvent IO layers when we manipulate low-level
2374 filedescriptors directly, need to manually switch to the
2375 default, binary, low-level mode; see PerlIOBuf_open(). */
2376 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2379 #ifdef PERL_USES_PL_PIDSTATUS
2380 hv_clear(PL_pidstatus); /* we have no children */
2386 do_execfree(); /* free any memory malloced by child on vfork */
2388 PerlLIO_close(pp[1]);
2389 if (p[that] < p[This]) {
2390 PerlLIO_dup2(p[This], p[that]);
2391 PerlLIO_close(p[This]);
2395 PerlLIO_close(p[that]);
2397 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2398 SvUPGRADE(sv,SVt_IV);
2400 PL_forkprocess = pid;
2401 if (did_pipes && pid > 0) {
2406 while (n < sizeof(int)) {
2407 n1 = PerlLIO_read(pp[0],
2408 (void*)(((char*)&errkid)+n),
2414 PerlLIO_close(pp[0]);
2416 if (n) { /* Error */
2418 PerlLIO_close(p[This]);
2419 if (n != sizeof(int))
2420 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2422 pid2 = wait4pid(pid, &status, 0);
2423 } while (pid2 == -1 && errno == EINTR);
2424 errno = errkid; /* Propagate errno from kid */
2429 PerlLIO_close(pp[0]);
2430 return PerlIO_fdopen(p[This], mode);
2434 FILE *djgpp_popen();
2436 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2438 PERL_FLUSHALL_FOR_CHILD;
2439 /* Call system's popen() to get a FILE *, then import it.
2440 used 0 for 2nd parameter to PerlIO_importFILE;
2443 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2446 #if defined(__LIBCATAMOUNT__)
2448 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2455 #endif /* !DOSISH */
2457 /* this is called in parent before the fork() */
2459 Perl_atfork_lock(void)
2462 #if defined(USE_ITHREADS)
2463 /* locks must be held in locking order (if any) */
2465 MUTEX_LOCK(&PL_perlio_mutex);
2468 MUTEX_LOCK(&PL_malloc_mutex);
2474 /* this is called in both parent and child after the fork() */
2476 Perl_atfork_unlock(void)
2479 #if defined(USE_ITHREADS)
2480 /* locks must be released in same order as in atfork_lock() */
2482 MUTEX_UNLOCK(&PL_perlio_mutex);
2485 MUTEX_UNLOCK(&PL_malloc_mutex);
2494 #if defined(HAS_FORK)
2496 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2501 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2502 * handlers elsewhere in the code */
2507 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2508 Perl_croak_nocontext("fork() not available");
2510 #endif /* HAS_FORK */
2515 dup2(int oldfd, int newfd)
2517 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2520 PerlLIO_close(newfd);
2521 return fcntl(oldfd, F_DUPFD, newfd);
2523 #define DUP2_MAX_FDS 256
2524 int fdtmp[DUP2_MAX_FDS];
2530 PerlLIO_close(newfd);
2531 /* good enough for low fd's... */
2532 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2533 if (fdx >= DUP2_MAX_FDS) {
2541 PerlLIO_close(fdtmp[--fdx]);
2548 #ifdef HAS_SIGACTION
2551 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2554 struct sigaction act, oact;
2557 /* only "parent" interpreter can diddle signals */
2558 if (PL_curinterp != aTHX)
2559 return (Sighandler_t) SIG_ERR;
2562 act.sa_handler = (void(*)(int))handler;
2563 sigemptyset(&act.sa_mask);
2566 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2567 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2569 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2570 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2571 act.sa_flags |= SA_NOCLDWAIT;
2573 if (sigaction(signo, &act, &oact) == -1)
2574 return (Sighandler_t) SIG_ERR;
2576 return (Sighandler_t) oact.sa_handler;
2580 Perl_rsignal_state(pTHX_ int signo)
2582 struct sigaction oact;
2583 PERL_UNUSED_CONTEXT;
2585 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2586 return (Sighandler_t) SIG_ERR;
2588 return (Sighandler_t) oact.sa_handler;
2592 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2595 struct sigaction act;
2597 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2600 /* only "parent" interpreter can diddle signals */
2601 if (PL_curinterp != aTHX)
2605 act.sa_handler = (void(*)(int))handler;
2606 sigemptyset(&act.sa_mask);
2609 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2610 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2612 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2613 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2614 act.sa_flags |= SA_NOCLDWAIT;
2616 return sigaction(signo, &act, save);
2620 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2624 /* only "parent" interpreter can diddle signals */
2625 if (PL_curinterp != aTHX)
2629 return sigaction(signo, save, (struct sigaction *)NULL);
2632 #else /* !HAS_SIGACTION */
2635 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2637 #if defined(USE_ITHREADS) && !defined(WIN32)
2638 /* only "parent" interpreter can diddle signals */
2639 if (PL_curinterp != aTHX)
2640 return (Sighandler_t) SIG_ERR;
2643 return PerlProc_signal(signo, handler);
2654 Perl_rsignal_state(pTHX_ int signo)
2657 Sighandler_t oldsig;
2659 #if defined(USE_ITHREADS) && !defined(WIN32)
2660 /* only "parent" interpreter can diddle signals */
2661 if (PL_curinterp != aTHX)
2662 return (Sighandler_t) SIG_ERR;
2666 oldsig = PerlProc_signal(signo, sig_trap);
2667 PerlProc_signal(signo, oldsig);
2669 PerlProc_kill(PerlProc_getpid(), signo);
2674 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2676 #if defined(USE_ITHREADS) && !defined(WIN32)
2677 /* only "parent" interpreter can diddle signals */
2678 if (PL_curinterp != aTHX)
2681 *save = PerlProc_signal(signo, handler);
2682 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2686 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2688 #if defined(USE_ITHREADS) && !defined(WIN32)
2689 /* only "parent" interpreter can diddle signals */
2690 if (PL_curinterp != aTHX)
2693 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2696 #endif /* !HAS_SIGACTION */
2697 #endif /* !PERL_MICRO */
2699 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2700 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2702 Perl_my_pclose(pTHX_ PerlIO *ptr)
2711 const int fd = PerlIO_fileno(ptr);
2714 svp = av_fetch(PL_fdpid,fd,TRUE);
2715 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2720 /* Find out whether the refcount is low enough for us to wait for the
2721 child proc without blocking. */
2722 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2724 should_wait = pid > 0;
2728 if (pid == -1) { /* Opened by popen. */
2729 return my_syspclose(ptr);
2732 close_failed = (PerlIO_close(ptr) == EOF);
2734 if (should_wait) do {
2735 pid2 = wait4pid(pid, &status, 0);
2736 } while (pid2 == -1 && errno == EINTR);
2743 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2748 #if defined(__LIBCATAMOUNT__)
2750 Perl_my_pclose(pTHX_ PerlIO *ptr)
2755 #endif /* !DOSISH */
2757 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2759 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2763 PERL_ARGS_ASSERT_WAIT4PID;
2764 #ifdef PERL_USES_PL_PIDSTATUS
2766 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2767 waitpid() nor wait4() is available, or on OS/2, which
2768 doesn't appear to support waiting for a progress group
2769 member, so we can only treat a 0 pid as an unknown child.
2776 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2777 pid, rather than a string form. */
2778 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2779 if (svp && *svp != &PL_sv_undef) {
2780 *statusp = SvIVX(*svp);
2781 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2789 hv_iterinit(PL_pidstatus);
2790 if ((entry = hv_iternext(PL_pidstatus))) {
2791 SV * const sv = hv_iterval(PL_pidstatus,entry);
2793 const char * const spid = hv_iterkey(entry,&len);
2795 assert (len == sizeof(Pid_t));
2796 memcpy((char *)&pid, spid, len);
2797 *statusp = SvIVX(sv);
2798 /* The hash iterator is currently on this entry, so simply
2799 calling hv_delete would trigger the lazy delete, which on
2800 aggregate does more work, beacuse next call to hv_iterinit()
2801 would spot the flag, and have to call the delete routine,
2802 while in the meantime any new entries can't re-use that
2804 hv_iterinit(PL_pidstatus);
2805 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2812 # ifdef HAS_WAITPID_RUNTIME
2813 if (!HAS_WAITPID_RUNTIME)
2816 result = PerlProc_waitpid(pid,statusp,flags);
2819 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2820 result = wait4(pid,statusp,flags,NULL);
2823 #ifdef PERL_USES_PL_PIDSTATUS
2824 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2829 Perl_croak(aTHX_ "Can't do waitpid with flags");
2831 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2832 pidgone(result,*statusp);
2838 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2841 if (result < 0 && errno == EINTR) {
2843 errno = EINTR; /* reset in case a signal handler changed $! */
2847 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2849 #ifdef PERL_USES_PL_PIDSTATUS
2851 S_pidgone(pTHX_ Pid_t pid, int status)
2855 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2856 SvUPGRADE(sv,SVt_IV);
2857 SvIV_set(sv, status);
2865 int /* Cannot prototype with I32
2867 my_syspclose(PerlIO *ptr)
2870 Perl_my_pclose(pTHX_ PerlIO *ptr)
2873 /* Needs work for PerlIO ! */
2874 FILE * const f = PerlIO_findFILE(ptr);
2875 const I32 result = pclose(f);
2876 PerlIO_releaseFILE(ptr,f);
2884 Perl_my_pclose(pTHX_ PerlIO *ptr)
2886 /* Needs work for PerlIO ! */
2887 FILE * const f = PerlIO_findFILE(ptr);
2888 I32 result = djgpp_pclose(f);
2889 result = (result << 8) & 0xff00;
2890 PerlIO_releaseFILE(ptr,f);
2895 #define PERL_REPEATCPY_LINEAR 4
2897 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2899 PERL_ARGS_ASSERT_REPEATCPY;
2904 croak_memory_wrap();
2907 memset(to, *from, count);
2910 IV items, linear, half;
2912 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2913 for (items = 0; items < linear; ++items) {
2914 const char *q = from;
2916 for (todo = len; todo > 0; todo--)
2921 while (items <= half) {
2922 IV size = items * len;
2923 memcpy(p, to, size);
2929 memcpy(p, to, (count - items) * len);
2935 Perl_same_dirent(pTHX_ const char *a, const char *b)
2937 char *fa = strrchr(a,'/');
2938 char *fb = strrchr(b,'/');
2941 SV * const tmpsv = sv_newmortal();
2943 PERL_ARGS_ASSERT_SAME_DIRENT;
2956 sv_setpvs(tmpsv, ".");
2958 sv_setpvn(tmpsv, a, fa - a);
2959 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2962 sv_setpvs(tmpsv, ".");
2964 sv_setpvn(tmpsv, b, fb - b);
2965 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2967 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2968 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2970 #endif /* !HAS_RENAME */
2973 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2974 const char *const *const search_ext, I32 flags)
2977 const char *xfound = NULL;
2978 char *xfailed = NULL;
2979 char tmpbuf[MAXPATHLEN];
2984 #if defined(DOSISH) && !defined(OS2)
2985 # define SEARCH_EXTS ".bat", ".cmd", NULL
2986 # define MAX_EXT_LEN 4
2989 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2990 # define MAX_EXT_LEN 4
2993 # define SEARCH_EXTS ".pl", ".com", NULL
2994 # define MAX_EXT_LEN 4
2996 /* additional extensions to try in each dir if scriptname not found */
2998 static const char *const exts[] = { SEARCH_EXTS };
2999 const char *const *const ext = search_ext ? search_ext : exts;
3000 int extidx = 0, i = 0;
3001 const char *curext = NULL;
3003 PERL_UNUSED_ARG(search_ext);
3004 # define MAX_EXT_LEN 0
3007 PERL_ARGS_ASSERT_FIND_SCRIPT;
3010 * If dosearch is true and if scriptname does not contain path
3011 * delimiters, search the PATH for scriptname.
3013 * If SEARCH_EXTS is also defined, will look for each
3014 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3015 * while searching the PATH.
3017 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3018 * proceeds as follows:
3019 * If DOSISH or VMSISH:
3020 * + look for ./scriptname{,.foo,.bar}
3021 * + search the PATH for scriptname{,.foo,.bar}
3024 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3025 * this will not look in '.' if it's not in the PATH)
3030 # ifdef ALWAYS_DEFTYPES
3031 len = strlen(scriptname);
3032 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3033 int idx = 0, deftypes = 1;
3036 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3039 int idx = 0, deftypes = 1;
3042 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3044 /* The first time through, just add SEARCH_EXTS to whatever we
3045 * already have, so we can check for default file types. */
3047 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3053 if ((strlen(tmpbuf) + strlen(scriptname)
3054 + MAX_EXT_LEN) >= sizeof tmpbuf)
3055 continue; /* don't search dir with too-long name */
3056 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3060 if (strEQ(scriptname, "-"))
3062 if (dosearch) { /* Look in '.' first. */
3063 const char *cur = scriptname;
3065 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3067 if (strEQ(ext[i++],curext)) {
3068 extidx = -1; /* already has an ext */
3073 DEBUG_p(PerlIO_printf(Perl_debug_log,
3074 "Looking for %s\n",cur));
3075 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3076 && !S_ISDIR(PL_statbuf.st_mode)) {
3084 if (cur == scriptname) {
3085 len = strlen(scriptname);
3086 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3088 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3091 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3092 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3097 if (dosearch && !strchr(scriptname, '/')
3099 && !strchr(scriptname, '\\')
3101 && (s = PerlEnv_getenv("PATH")))
3105 bufend = s + strlen(s);
3106 while (s < bufend) {
3109 && *s != ';'; len++, s++) {
3110 if (len < sizeof tmpbuf)
3113 if (len < sizeof tmpbuf)
3116 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3122 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3123 continue; /* don't search dir with too-long name */
3126 && tmpbuf[len - 1] != '/'
3127 && tmpbuf[len - 1] != '\\'
3130 tmpbuf[len++] = '/';
3131 if (len == 2 && tmpbuf[0] == '.')
3133 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3137 len = strlen(tmpbuf);
3138 if (extidx > 0) /* reset after previous loop */
3142 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3143 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3144 if (S_ISDIR(PL_statbuf.st_mode)) {
3148 } while ( retval < 0 /* not there */
3149 && extidx>=0 && ext[extidx] /* try an extension? */
3150 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3155 if (S_ISREG(PL_statbuf.st_mode)
3156 && cando(S_IRUSR,TRUE,&PL_statbuf)
3157 #if !defined(DOSISH)
3158 && cando(S_IXUSR,TRUE,&PL_statbuf)
3162 xfound = tmpbuf; /* bingo! */
3166 xfailed = savepv(tmpbuf);
3169 if (!xfound && !seen_dot && !xfailed &&
3170 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3171 || S_ISDIR(PL_statbuf.st_mode)))
3173 seen_dot = 1; /* Disable message. */
3175 if (flags & 1) { /* do or die? */
3176 /* diag_listed_as: Can't execute %s */
3177 Perl_croak(aTHX_ "Can't %s %s%s%s",
3178 (xfailed ? "execute" : "find"),
3179 (xfailed ? xfailed : scriptname),
3180 (xfailed ? "" : " on PATH"),
3181 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3186 scriptname = xfound;
3188 return (scriptname ? savepv(scriptname) : NULL);
3191 #ifndef PERL_GET_CONTEXT_DEFINED
3194 Perl_get_context(void)
3197 #if defined(USE_ITHREADS)
3198 # ifdef OLD_PTHREADS_API
3200 int error = pthread_getspecific(PL_thr_key, &t)
3202 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3205 # ifdef I_MACH_CTHREADS
3206 return (void*)cthread_data(cthread_self());
3208 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3217 Perl_set_context(void *t)
3220 PERL_ARGS_ASSERT_SET_CONTEXT;
3221 #if defined(USE_ITHREADS)
3222 # ifdef I_MACH_CTHREADS
3223 cthread_set_data(cthread_self(), t);
3226 const int error = pthread_setspecific(PL_thr_key, t);
3228 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3236 #endif /* !PERL_GET_CONTEXT_DEFINED */
3238 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3247 Perl_get_op_names(pTHX)
3249 PERL_UNUSED_CONTEXT;
3250 return (char **)PL_op_name;
3254 Perl_get_op_descs(pTHX)
3256 PERL_UNUSED_CONTEXT;
3257 return (char **)PL_op_desc;
3261 Perl_get_no_modify(pTHX)
3263 PERL_UNUSED_CONTEXT;
3264 return PL_no_modify;
3268 Perl_get_opargs(pTHX)
3270 PERL_UNUSED_CONTEXT;
3271 return (U32 *)PL_opargs;
3275 Perl_get_ppaddr(pTHX)
3278 PERL_UNUSED_CONTEXT;
3279 return (PPADDR_t*)PL_ppaddr;
3282 #ifndef HAS_GETENV_LEN
3284 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3286 char * const env_trans = PerlEnv_getenv(env_elem);
3287 PERL_UNUSED_CONTEXT;
3288 PERL_ARGS_ASSERT_GETENV_LEN;
3290 *len = strlen(env_trans);
3297 Perl_get_vtbl(pTHX_ int vtbl_id)
3299 PERL_UNUSED_CONTEXT;
3301 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3302 ? NULL : PL_magic_vtables + vtbl_id;
3306 Perl_my_fflush_all(pTHX)
3308 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3309 return PerlIO_flush(NULL);
3311 # if defined(HAS__FWALK)
3312 extern int fflush(FILE *);
3313 /* undocumented, unprototyped, but very useful BSDism */
3314 extern void _fwalk(int (*)(FILE *));
3318 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3320 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3321 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3323 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3324 open_max = sysconf(_SC_OPEN_MAX);
3327 open_max = FOPEN_MAX;
3330 open_max = OPEN_MAX;
3341 for (i = 0; i < open_max; i++)
3342 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3343 STDIO_STREAM_ARRAY[i]._file < open_max &&
3344 STDIO_STREAM_ARRAY[i]._flag)
3345 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3349 SETERRNO(EBADF,RMS_IFI);
3356 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3358 if (ckWARN(WARN_IO)) {
3360 = gv && (isGV_with_GP(gv))
3363 const char * const direction = have == '>' ? "out" : "in";
3365 if (name && HEK_LEN(name))
3366 Perl_warner(aTHX_ packWARN(WARN_IO),
3367 "Filehandle %"HEKf" opened only for %sput",
3370 Perl_warner(aTHX_ packWARN(WARN_IO),
3371 "Filehandle opened only for %sput", direction);
3376 Perl_report_evil_fh(pTHX_ const GV *gv)
3378 const IO *io = gv ? GvIO(gv) : NULL;
3379 const PERL_BITFIELD16 op = PL_op->op_type;
3383 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3385 warn_type = WARN_CLOSED;
3389 warn_type = WARN_UNOPENED;
3392 if (ckWARN(warn_type)) {
3394 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3395 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3396 const char * const pars =
3397 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3398 const char * const func =
3400 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3401 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3403 const char * const type =
3405 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3406 ? "socket" : "filehandle");
3407 const bool have_name = name && SvCUR(name);
3408 Perl_warner(aTHX_ packWARN(warn_type),
3409 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3410 have_name ? " " : "",
3411 SVfARG(have_name ? name : &PL_sv_no));
3412 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3414 aTHX_ packWARN(warn_type),
3415 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3416 func, pars, have_name ? " " : "",
3417 SVfARG(have_name ? name : &PL_sv_no)
3422 /* To workaround core dumps from the uninitialised tm_zone we get the
3423 * system to give us a reasonable struct to copy. This fix means that
3424 * strftime uses the tm_zone and tm_gmtoff values returned by
3425 * localtime(time()). That should give the desired result most of the
3426 * time. But probably not always!
3428 * This does not address tzname aspects of NETaa14816.
3433 # ifndef STRUCT_TM_HASZONE
3434 # define STRUCT_TM_HASZONE
3438 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3439 # ifndef HAS_TM_TM_ZONE
3440 # define HAS_TM_TM_ZONE
3445 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3447 #ifdef HAS_TM_TM_ZONE
3449 const struct tm* my_tm;
3450 PERL_ARGS_ASSERT_INIT_TM;
3452 my_tm = localtime(&now);
3454 Copy(my_tm, ptm, 1, struct tm);
3456 PERL_ARGS_ASSERT_INIT_TM;
3457 PERL_UNUSED_ARG(ptm);
3462 * mini_mktime - normalise struct tm values without the localtime()
3463 * semantics (and overhead) of mktime().
3466 Perl_mini_mktime(pTHX_ struct tm *ptm)
3470 int month, mday, year, jday;
3471 int odd_cent, odd_year;
3472 PERL_UNUSED_CONTEXT;
3474 PERL_ARGS_ASSERT_MINI_MKTIME;
3476 #define DAYS_PER_YEAR 365
3477 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3478 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3479 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3480 #define SECS_PER_HOUR (60*60)
3481 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3482 /* parentheses deliberately absent on these two, otherwise they don't work */
3483 #define MONTH_TO_DAYS 153/5
3484 #define DAYS_TO_MONTH 5/153
3485 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3486 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3487 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3488 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3491 * Year/day algorithm notes:
3493 * With a suitable offset for numeric value of the month, one can find
3494 * an offset into the year by considering months to have 30.6 (153/5) days,
3495 * using integer arithmetic (i.e., with truncation). To avoid too much
3496 * messing about with leap days, we consider January and February to be
3497 * the 13th and 14th month of the previous year. After that transformation,
3498 * we need the month index we use to be high by 1 from 'normal human' usage,
3499 * so the month index values we use run from 4 through 15.
3501 * Given that, and the rules for the Gregorian calendar (leap years are those
3502 * divisible by 4 unless also divisible by 100, when they must be divisible
3503 * by 400 instead), we can simply calculate the number of days since some
3504 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3505 * the days we derive from our month index, and adding in the day of the
3506 * month. The value used here is not adjusted for the actual origin which
3507 * it normally would use (1 January A.D. 1), since we're not exposing it.
3508 * We're only building the value so we can turn around and get the
3509 * normalised values for the year, month, day-of-month, and day-of-year.
3511 * For going backward, we need to bias the value we're using so that we find
3512 * the right year value. (Basically, we don't want the contribution of
3513 * March 1st to the number to apply while deriving the year). Having done
3514 * that, we 'count up' the contribution to the year number by accounting for
3515 * full quadracenturies (400-year periods) with their extra leap days, plus
3516 * the contribution from full centuries (to avoid counting in the lost leap
3517 * days), plus the contribution from full quad-years (to count in the normal
3518 * leap days), plus the leftover contribution from any non-leap years.
3519 * At this point, if we were working with an actual leap day, we'll have 0
3520 * days left over. This is also true for March 1st, however. So, we have
3521 * to special-case that result, and (earlier) keep track of the 'odd'
3522 * century and year contributions. If we got 4 extra centuries in a qcent,
3523 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3524 * Otherwise, we add back in the earlier bias we removed (the 123 from
3525 * figuring in March 1st), find the month index (integer division by 30.6),
3526 * and the remainder is the day-of-month. We then have to convert back to
3527 * 'real' months (including fixing January and February from being 14/15 in
3528 * the previous year to being in the proper year). After that, to get
3529 * tm_yday, we work with the normalised year and get a new yearday value for
3530 * January 1st, which we subtract from the yearday value we had earlier,
3531 * representing the date we've re-built. This is done from January 1
3532 * because tm_yday is 0-origin.
3534 * Since POSIX time routines are only guaranteed to work for times since the
3535 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3536 * applies Gregorian calendar rules even to dates before the 16th century
3537 * doesn't bother me. Besides, you'd need cultural context for a given
3538 * date to know whether it was Julian or Gregorian calendar, and that's
3539 * outside the scope for this routine. Since we convert back based on the
3540 * same rules we used to build the yearday, you'll only get strange results
3541 * for input which needed normalising, or for the 'odd' century years which
3542 * were leap years in the Julian calendar but not in the Gregorian one.
3543 * I can live with that.
3545 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3546 * that's still outside the scope for POSIX time manipulation, so I don't
3550 year = 1900 + ptm->tm_year;
3551 month = ptm->tm_mon;
3552 mday = ptm->tm_mday;
3558 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3559 yearday += month*MONTH_TO_DAYS + mday + jday;
3561 * Note that we don't know when leap-seconds were or will be,
3562 * so we have to trust the user if we get something which looks
3563 * like a sensible leap-second. Wild values for seconds will
3564 * be rationalised, however.
3566 if ((unsigned) ptm->tm_sec <= 60) {
3573 secs += 60 * ptm->tm_min;
3574 secs += SECS_PER_HOUR * ptm->tm_hour;
3576 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3577 /* got negative remainder, but need positive time */
3578 /* back off an extra day to compensate */
3579 yearday += (secs/SECS_PER_DAY)-1;
3580 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3583 yearday += (secs/SECS_PER_DAY);
3584 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3587 else if (secs >= SECS_PER_DAY) {
3588 yearday += (secs/SECS_PER_DAY);
3589 secs %= SECS_PER_DAY;
3591 ptm->tm_hour = secs/SECS_PER_HOUR;
3592 secs %= SECS_PER_HOUR;
3593 ptm->tm_min = secs/60;
3595 ptm->tm_sec += secs;
3596 /* done with time of day effects */
3598 * The algorithm for yearday has (so far) left it high by 428.
3599 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3600 * bias it by 123 while trying to figure out what year it
3601 * really represents. Even with this tweak, the reverse
3602 * translation fails for years before A.D. 0001.
3603 * It would still fail for Feb 29, but we catch that one below.
3605 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3606 yearday -= YEAR_ADJUST;
3607 year = (yearday / DAYS_PER_QCENT) * 400;
3608 yearday %= DAYS_PER_QCENT;
3609 odd_cent = yearday / DAYS_PER_CENT;
3610 year += odd_cent * 100;
3611 yearday %= DAYS_PER_CENT;
3612 year += (yearday / DAYS_PER_QYEAR) * 4;
3613 yearday %= DAYS_PER_QYEAR;
3614 odd_year = yearday / DAYS_PER_YEAR;
3616 yearday %= DAYS_PER_YEAR;
3617 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3622 yearday += YEAR_ADJUST; /* recover March 1st crock */
3623 month = yearday*DAYS_TO_MONTH;
3624 yearday -= month*MONTH_TO_DAYS;
3625 /* recover other leap-year adjustment */
3634 ptm->tm_year = year - 1900;
3636 ptm->tm_mday = yearday;
3637 ptm->tm_mon = month;
3641 ptm->tm_mon = month - 1;
3643 /* re-build yearday based on Jan 1 to get tm_yday */
3645 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3646 yearday += 14*MONTH_TO_DAYS + 1;
3647 ptm->tm_yday = jday - yearday;
3648 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3652 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)
3660 PERL_ARGS_ASSERT_MY_STRFTIME;
3662 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3665 mytm.tm_hour = hour;
3666 mytm.tm_mday = mday;
3668 mytm.tm_year = year;
3669 mytm.tm_wday = wday;
3670 mytm.tm_yday = yday;
3671 mytm.tm_isdst = isdst;
3673 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3674 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3679 #ifdef HAS_TM_TM_GMTOFF
3680 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3682 #ifdef HAS_TM_TM_ZONE
3683 mytm.tm_zone = mytm2.tm_zone;
3688 Newx(buf, buflen, char);
3689 len = strftime(buf, buflen, fmt, &mytm);
3691 ** The following is needed to handle to the situation where
3692 ** tmpbuf overflows. Basically we want to allocate a buffer
3693 ** and try repeatedly. The reason why it is so complicated
3694 ** is that getting a return value of 0 from strftime can indicate
3695 ** one of the following:
3696 ** 1. buffer overflowed,
3697 ** 2. illegal conversion specifier, or
3698 ** 3. the format string specifies nothing to be returned(not
3699 ** an error). This could be because format is an empty string
3700 ** or it specifies %p that yields an empty string in some locale.
3701 ** If there is a better way to make it portable, go ahead by
3704 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3707 /* Possibly buf overflowed - try again with a bigger buf */
3708 const int fmtlen = strlen(fmt);
3709 int bufsize = fmtlen + buflen;
3711 Renew(buf, bufsize, char);
3713 buflen = strftime(buf, bufsize, fmt, &mytm);
3714 if (buflen > 0 && buflen < bufsize)
3716 /* heuristic to prevent out-of-memory errors */
3717 if (bufsize > 100*fmtlen) {
3723 Renew(buf, bufsize, char);
3728 Perl_croak(aTHX_ "panic: no strftime");
3734 #define SV_CWD_RETURN_UNDEF \
3735 sv_setsv(sv, &PL_sv_undef); \
3738 #define SV_CWD_ISDOT(dp) \
3739 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3740 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3743 =head1 Miscellaneous Functions
3745 =for apidoc getcwd_sv
3747 Fill the sv with current working directory
3752 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3753 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3754 * getcwd(3) if available
3755 * Comments from the orignal:
3756 * This is a faster version of getcwd. It's also more dangerous
3757 * because you might chdir out of a directory that you can't chdir
3761 Perl_getcwd_sv(pTHX_ SV *sv)
3767 PERL_ARGS_ASSERT_GETCWD_SV;
3771 char buf[MAXPATHLEN];
3773 /* Some getcwd()s automatically allocate a buffer of the given
3774 * size from the heap if they are given a NULL buffer pointer.
3775 * The problem is that this behaviour is not portable. */
3776 if (getcwd(buf, sizeof(buf) - 1)) {
3781 sv_setsv(sv, &PL_sv_undef);
3789 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3793 SvUPGRADE(sv, SVt_PV);
3795 if (PerlLIO_lstat(".", &statbuf) < 0) {
3796 SV_CWD_RETURN_UNDEF;
3799 orig_cdev = statbuf.st_dev;
3800 orig_cino = statbuf.st_ino;
3810 if (PerlDir_chdir("..") < 0) {
3811 SV_CWD_RETURN_UNDEF;
3813 if (PerlLIO_stat(".", &statbuf) < 0) {
3814 SV_CWD_RETURN_UNDEF;
3817 cdev = statbuf.st_dev;
3818 cino = statbuf.st_ino;
3820 if (odev == cdev && oino == cino) {
3823 if (!(dir = PerlDir_open("."))) {
3824 SV_CWD_RETURN_UNDEF;
3827 while ((dp = PerlDir_read(dir)) != NULL) {
3829 namelen = dp->d_namlen;
3831 namelen = strlen(dp->d_name);
3834 if (SV_CWD_ISDOT(dp)) {
3838 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3839 SV_CWD_RETURN_UNDEF;
3842 tdev = statbuf.st_dev;
3843 tino = statbuf.st_ino;
3844 if (tino == oino && tdev == odev) {
3850 SV_CWD_RETURN_UNDEF;
3853 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3854 SV_CWD_RETURN_UNDEF;
3857 SvGROW(sv, pathlen + namelen + 1);
3861 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3864 /* prepend current directory to the front */
3866 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3867 pathlen += (namelen + 1);
3869 #ifdef VOID_CLOSEDIR
3872 if (PerlDir_close(dir) < 0) {
3873 SV_CWD_RETURN_UNDEF;
3879 SvCUR_set(sv, pathlen);
3883 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3884 SV_CWD_RETURN_UNDEF;
3887 if (PerlLIO_stat(".", &statbuf) < 0) {
3888 SV_CWD_RETURN_UNDEF;
3891 cdev = statbuf.st_dev;
3892 cino = statbuf.st_ino;
3894 if (cdev != orig_cdev || cino != orig_cino) {
3895 Perl_croak(aTHX_ "Unstable directory path, "
3896 "current directory changed unexpectedly");
3907 #define VERSION_MAX 0x7FFFFFFF
3910 =for apidoc prescan_version
3912 Validate that a given string can be parsed as a version object, but doesn't
3913 actually perform the parsing. Can use either strict or lax validation rules.
3914 Can optionally set a number of hint variables to save the parsing code
3915 some time when tokenizing.
3920 Perl_prescan_version(pTHX_ const char *s, bool strict,
3921 const char **errstr,
3922 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3923 bool qv = (sqv ? *sqv : FALSE);
3925 int saw_decimal = 0;
3929 PERL_ARGS_ASSERT_PRESCAN_VERSION;
3931 if (qv && isDIGIT(*d))
3932 goto dotted_decimal_version;
3934 if (*d == 'v') { /* explicit v-string */
3939 else { /* degenerate v-string */
3940 /* requires v1.2.3 */
3941 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3944 dotted_decimal_version:
3945 if (strict && d[0] == '0' && isDIGIT(d[1])) {
3946 /* no leading zeros allowed */
3947 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3950 while (isDIGIT(*d)) /* integer part */
3956 d++; /* decimal point */
3961 /* require v1.2.3 */
3962 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3965 goto version_prescan_finish;
3972 while (isDIGIT(*d)) { /* just keep reading */
3974 while (isDIGIT(*d)) {
3976 /* maximum 3 digits between decimal */
3977 if (strict && j > 3) {
3978 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
3983 BADVERSION(s,errstr,"Invalid version format (no underscores)");
3986 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
3991 else if (*d == '.') {
3993 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
3998 else if (!isDIGIT(*d)) {
4004 if (strict && i < 2) {
4005 /* requires v1.2.3 */
4006 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4009 } /* end if dotted-decimal */
4011 { /* decimal versions */
4012 int j = 0; /* may need this later */
4013 /* special strict case for leading '.' or '0' */
4016 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4018 if (*d == '0' && isDIGIT(d[1])) {
4019 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4023 /* and we never support negative versions */
4025 BADVERSION(s,errstr,"Invalid version format (negative version number)");
4028 /* consume all of the integer part */
4032 /* look for a fractional part */
4034 /* we found it, so consume it */
4038 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4041 BADVERSION(s,errstr,"Invalid version format (version required)");
4043 /* found just an integer */
4044 goto version_prescan_finish;
4046 else if ( d == s ) {
4047 /* didn't find either integer or period */
4048 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4050 else if (*d == '_') {
4051 /* underscore can't come after integer part */
4053 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4055 else if (isDIGIT(d[1])) {
4056 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4059 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4063 /* anything else after integer part is just invalid data */
4064 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4067 /* scan the fractional part after the decimal point*/
4069 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4070 /* strict or lax-but-not-the-end */
4071 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4074 while (isDIGIT(*d)) {
4076 if (*d == '.' && isDIGIT(d[-1])) {
4078 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4081 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4083 d = (char *)s; /* start all over again */
4085 goto dotted_decimal_version;
4089 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4092 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4094 if ( ! isDIGIT(d[1]) ) {
4095 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4104 version_prescan_finish:
4108 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4109 /* trailing non-numeric data */
4110 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4118 *ssaw_decimal = saw_decimal;
4125 =for apidoc scan_version
4127 Returns a pointer to the next character after the parsed
4128 version string, as well as upgrading the passed in SV to
4131 Function must be called with an already existing SV like
4134 s = scan_version(s, SV *sv, bool qv);
4136 Performs some preprocessing to the string to ensure that
4137 it has the correct characteristics of a version. Flags the
4138 object if it contains an underscore (which denotes this
4139 is an alpha version). The boolean qv denotes that the version
4140 should be interpreted as if it had multiple decimals, even if
4147 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4149 const char *start = s;
4152 const char *errstr = NULL;
4153 int saw_decimal = 0;
4160 PERL_ARGS_ASSERT_SCAN_VERSION;
4162 while (isSPACE(*s)) /* leading whitespace is OK */
4165 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4167 /* "undef" is a special case and not an error */
4168 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4170 Perl_croak(aTHX_ "%s", errstr);
4179 /* Now that we are through the prescan, start creating the object */
4181 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4182 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4184 #ifndef NODEFAULT_SHAREKEYS
4185 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4189 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4191 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4192 if ( !qv && width < 3 )
4193 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4195 while (isDIGIT(*pos))
4197 if (!isALPHA(*pos)) {
4203 /* this is atoi() that delimits on underscores */
4204 const char *end = pos;
4208 /* the following if() will only be true after the decimal
4209 * point of a version originally created with a bare
4210 * floating point number, i.e. not quoted in any way
4212 if ( !qv && s > start && saw_decimal == 1 ) {
4216 rev += (*s - '0') * mult;
4218 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4219 || (PERL_ABS(rev) > VERSION_MAX )) {
4220 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4221 "Integer overflow in version %d",VERSION_MAX);
4232 while (--end >= s) {
4234 rev += (*end - '0') * mult;
4236 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4237 || (PERL_ABS(rev) > VERSION_MAX )) {
4238 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4239 "Integer overflow in version");
4248 /* Append revision */
4249 av_push(av, newSViv(rev));
4254 else if ( *pos == '.' )
4256 else if ( *pos == '_' && isDIGIT(pos[1]) )
4258 else if ( *pos == ',' && isDIGIT(pos[1]) )
4260 else if ( isDIGIT(*pos) )
4267 while ( isDIGIT(*pos) )
4272 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4280 if ( qv ) { /* quoted versions always get at least three terms*/
4281 SSize_t len = av_len(av);
4282 /* This for loop appears to trigger a compiler bug on OS X, as it
4283 loops infinitely. Yes, len is negative. No, it makes no sense.
4284 Compiler in question is:
4285 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4286 for ( len = 2 - len; len > 0; len-- )
4287 av_push(MUTABLE_AV(sv), newSViv(0));
4291 av_push(av, newSViv(0));
4294 /* need to save off the current version string for later */
4296 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4297 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4298 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4300 else if ( s > start ) {
4301 SV * orig = newSVpvn(start,s-start);
4302 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4303 /* need to insert a v to be consistent */
4304 sv_insert(orig, 0, 0, "v", 1);
4306 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4309 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4310 av_push(av, newSViv(0));
4313 /* And finally, store the AV in the hash */
4314 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4316 /* fix RT#19517 - special case 'undef' as string */
4317 if ( *s == 'u' && strEQ(s,"undef") ) {
4325 =for apidoc new_version
4327 Returns a new version object based on the passed in SV:
4329 SV *sv = new_version(SV *ver);
4331 Does not alter the passed in ver SV. See "upg_version" if you
4332 want to upgrade the SV.
4338 Perl_new_version(pTHX_ SV *ver)
4341 SV * const rv = newSV(0);
4342 PERL_ARGS_ASSERT_NEW_VERSION;
4343 if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4344 /* can just copy directly */
4347 AV * const av = newAV();
4349 /* This will get reblessed later if a derived class*/
4350 SV * const hv = newSVrv(rv, "version");
4351 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4352 #ifndef NODEFAULT_SHAREKEYS
4353 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4359 /* Begin copying all of the elements */
4360 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4361 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4363 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4364 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4366 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4368 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4369 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4372 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4374 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4375 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4378 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4379 /* This will get reblessed later if a derived class*/
4380 for ( key = 0; key <= av_len(sav); key++ )
4382 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4383 av_push(av, newSViv(rev));
4386 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4391 const MAGIC* const mg = SvVSTRING_mg(ver);
4392 if ( mg ) { /* already a v-string */
4393 const STRLEN len = mg->mg_len;
4394 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4395 sv_setpvn(rv,version,len);
4396 /* this is for consistency with the pure Perl class */
4397 if ( isDIGIT(*version) )
4398 sv_insert(rv, 0, 0, "v", 1);
4403 sv_setsv(rv,ver); /* make a duplicate */
4408 return upg_version(rv, FALSE);
4412 =for apidoc upg_version
4414 In-place upgrade of the supplied SV to a version object.
4416 SV *sv = upg_version(SV *sv, bool qv);
4418 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4419 to force this SV to be interpreted as an "extended" version.
4425 Perl_upg_version(pTHX_ SV *ver, bool qv)
4427 const char *version, *s;
4432 PERL_ARGS_ASSERT_UPG_VERSION;
4434 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4438 /* may get too much accuracy */
4440 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4442 #ifdef USE_LOCALE_NUMERIC
4444 if (! PL_numeric_standard) {
4445 loc = savepv(setlocale(LC_NUMERIC, NULL));
4446 setlocale(LC_NUMERIC, "C");
4450 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4451 buf = SvPV(sv, len);
4454 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4457 #ifdef USE_LOCALE_NUMERIC
4459 setlocale(LC_NUMERIC, loc);
4463 while (buf[len-1] == '0' && len > 0) len--;
4464 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4465 version = savepvn(buf, len);
4469 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4470 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4474 else /* must be a string or something like a string */
4477 version = savepv(SvPV(ver,len));
4479 # if PERL_VERSION > 5
4480 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4481 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4482 /* may be a v-string */
4483 char *testv = (char *)version;
4485 for (tlen=0; tlen < len; tlen++, testv++) {
4486 /* if one of the characters is non-text assume v-string */
4487 if (testv[0] < ' ') {
4488 SV * const nsv = sv_newmortal();
4491 int saw_decimal = 0;
4492 sv_setpvf(nsv,"v%vd",ver);
4493 pos = nver = savepv(SvPV_nolen(nsv));
4495 /* scan the resulting formatted string */
4496 pos++; /* skip the leading 'v' */
4497 while ( *pos == '.' || isDIGIT(*pos) ) {
4503 /* is definitely a v-string */
4504 if ( saw_decimal >= 2 ) {
4516 s = scan_version(version, ver, qv);
4518 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4519 "Version string '%s' contains invalid data; "
4520 "ignoring: '%s'", version, s);
4528 Validates that the SV contains valid internal structure for a version object.
4529 It may be passed either the version object (RV) or the hash itself (HV). If
4530 the structure is valid, it returns the HV. If the structure is invalid,
4533 SV *hv = vverify(sv);
4535 Note that it only confirms the bare minimum structure (so as not to get
4536 confused by derived classes which may contain additional hash entries):
4540 =item * The SV is an HV or a reference to an HV
4542 =item * The hash contains a "version" key
4544 =item * The "version" key has a reference to an AV as its value
4552 Perl_vverify(pTHX_ SV *vs)
4556 PERL_ARGS_ASSERT_VVERIFY;
4561 /* see if the appropriate elements exist */
4562 if ( SvTYPE(vs) == SVt_PVHV
4563 && hv_exists(MUTABLE_HV(vs), "version", 7)
4564 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4565 && SvTYPE(sv) == SVt_PVAV )
4574 Accepts a version object and returns the normalized floating
4575 point representation. Call like:
4579 NOTE: you can pass either the object directly or the SV
4580 contained within the RV.
4582 The SV returned has a refcount of 1.
4588 Perl_vnumify(pTHX_ SV *vs)
4597 PERL_ARGS_ASSERT_VNUMIFY;
4599 /* extract the HV from the object */
4602 Perl_croak(aTHX_ "Invalid version object");
4604 /* see if various flags exist */
4605 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4607 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4608 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4613 /* attempt to retrieve the version array */
4614 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4615 return newSVpvs("0");
4621 return newSVpvs("0");
4624 digit = SvIV(*av_fetch(av, 0, 0));
4625 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4626 for ( i = 1 ; i < len ; i++ )
4628 digit = SvIV(*av_fetch(av, i, 0));
4630 const int denom = (width == 2 ? 10 : 100);
4631 const div_t term = div((int)PERL_ABS(digit),denom);
4632 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4635 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4641 digit = SvIV(*av_fetch(av, len, 0));
4642 if ( alpha && width == 3 ) /* alpha version */
4644 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4648 sv_catpvs(sv, "000");
4656 Accepts a version object and returns the normalized string
4657 representation. Call like:
4661 NOTE: you can pass either the object directly or the SV
4662 contained within the RV.
4664 The SV returned has a refcount of 1.
4670 Perl_vnormal(pTHX_ SV *vs)
4677 PERL_ARGS_ASSERT_VNORMAL;
4679 /* extract the HV from the object */
4682 Perl_croak(aTHX_ "Invalid version object");
4684 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4686 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4691 return newSVpvs("");
4693 digit = SvIV(*av_fetch(av, 0, 0));
4694 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4695 for ( i = 1 ; i < len ; i++ ) {
4696 digit = SvIV(*av_fetch(av, i, 0));
4697 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4702 /* handle last digit specially */
4703 digit = SvIV(*av_fetch(av, len, 0));
4705 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4707 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4710 if ( len <= 2 ) { /* short version, must be at least three */
4711 for ( len = 2 - len; len != 0; len-- )
4718 =for apidoc vstringify
4720 In order to maintain maximum compatibility with earlier versions
4721 of Perl, this function will return either the floating point
4722 notation or the multiple dotted notation, depending on whether
4723 the original version contained 1 or more dots, respectively.
4725 The SV returned has a refcount of 1.
4731 Perl_vstringify(pTHX_ SV *vs)
4733 PERL_ARGS_ASSERT_VSTRINGIFY;
4735 /* extract the HV from the object */
4738 Perl_croak(aTHX_ "Invalid version object");
4740 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
4742 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4746 return &PL_sv_undef;
4749 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4759 Version object aware cmp. Both operands must already have been
4760 converted into version objects.
4766 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4770 bool lalpha = FALSE;
4771 bool ralpha = FALSE;
4776 PERL_ARGS_ASSERT_VCMP;
4778 /* extract the HVs from the objects */
4781 if ( ! ( lhv && rhv ) )
4782 Perl_croak(aTHX_ "Invalid version object");
4784 /* get the left hand term */
4785 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4786 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4789 /* and the right hand term */
4790 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4791 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4799 while ( i <= m && retval == 0 )
4801 left = SvIV(*av_fetch(lav,i,0));
4802 right = SvIV(*av_fetch(rav,i,0));
4810 /* tiebreaker for alpha with identical terms */
4811 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4813 if ( lalpha && !ralpha )
4817 else if ( ralpha && !lalpha)
4823 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4827 while ( i <= r && retval == 0 )
4829 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4830 retval = -1; /* not a match after all */
4836 while ( i <= l && retval == 0 )
4838 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4839 retval = +1; /* not a match after all */
4847 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4848 # define EMULATE_SOCKETPAIR_UDP
4851 #ifdef EMULATE_SOCKETPAIR_UDP
4853 S_socketpair_udp (int fd[2]) {
4855 /* Fake a datagram socketpair using UDP to localhost. */
4856 int sockets[2] = {-1, -1};
4857 struct sockaddr_in addresses[2];
4859 Sock_size_t size = sizeof(struct sockaddr_in);
4860 unsigned short port;
4863 memset(&addresses, 0, sizeof(addresses));
4866 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4867 if (sockets[i] == -1)
4868 goto tidy_up_and_fail;
4870 addresses[i].sin_family = AF_INET;
4871 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4872 addresses[i].sin_port = 0; /* kernel choses port. */
4873 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4874 sizeof(struct sockaddr_in)) == -1)
4875 goto tidy_up_and_fail;
4878 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4879 for each connect the other socket to it. */
4882 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4884 goto tidy_up_and_fail;
4885 if (size != sizeof(struct sockaddr_in))
4886 goto abort_tidy_up_and_fail;
4887 /* !1 is 0, !0 is 1 */
4888 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4889 sizeof(struct sockaddr_in)) == -1)
4890 goto tidy_up_and_fail;
4893 /* Now we have 2 sockets connected to each other. I don't trust some other
4894 process not to have already sent a packet to us (by random) so send
4895 a packet from each to the other. */
4898 /* I'm going to send my own port number. As a short.
4899 (Who knows if someone somewhere has sin_port as a bitfield and needs
4900 this routine. (I'm assuming crays have socketpair)) */
4901 port = addresses[i].sin_port;
4902 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4903 if (got != sizeof(port)) {
4905 goto tidy_up_and_fail;
4906 goto abort_tidy_up_and_fail;
4910 /* Packets sent. I don't trust them to have arrived though.
4911 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4912 connect to localhost will use a second kernel thread. In 2.6 the
4913 first thread running the connect() returns before the second completes,
4914 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4915 returns 0. Poor programs have tripped up. One poor program's authors'
4916 had a 50-1 reverse stock split. Not sure how connected these were.)
4917 So I don't trust someone not to have an unpredictable UDP stack.
4921 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4922 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4926 FD_SET((unsigned int)sockets[0], &rset);
4927 FD_SET((unsigned int)sockets[1], &rset);
4929 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4930 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4931 || !FD_ISSET(sockets[1], &rset)) {
4932 /* I hope this is portable and appropriate. */
4934 goto tidy_up_and_fail;
4935 goto abort_tidy_up_and_fail;
4939 /* And the paranoia department even now doesn't trust it to have arrive
4940 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4942 struct sockaddr_in readfrom;
4943 unsigned short buffer[2];
4948 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4949 sizeof(buffer), MSG_DONTWAIT,
4950 (struct sockaddr *) &readfrom, &size);
4952 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4954 (struct sockaddr *) &readfrom, &size);
4958 goto tidy_up_and_fail;
4959 if (got != sizeof(port)
4960 || size != sizeof(struct sockaddr_in)
4961 /* Check other socket sent us its port. */
4962 || buffer[0] != (unsigned short) addresses[!i].sin_port
4963 /* Check kernel says we got the datagram from that socket */
4964 || readfrom.sin_family != addresses[!i].sin_family
4965 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4966 || readfrom.sin_port != addresses[!i].sin_port)
4967 goto abort_tidy_up_and_fail;
4970 /* My caller (my_socketpair) has validated that this is non-NULL */
4973 /* I hereby declare this connection open. May God bless all who cross
4977 abort_tidy_up_and_fail:
4978 errno = ECONNABORTED;
4982 if (sockets[0] != -1)
4983 PerlLIO_close(sockets[0]);
4984 if (sockets[1] != -1)
4985 PerlLIO_close(sockets[1]);
4990 #endif /* EMULATE_SOCKETPAIR_UDP */
4992 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4994 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4995 /* Stevens says that family must be AF_LOCAL, protocol 0.
4996 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5001 struct sockaddr_in listen_addr;
5002 struct sockaddr_in connect_addr;
5007 || family != AF_UNIX
5010 errno = EAFNOSUPPORT;
5018 #ifdef EMULATE_SOCKETPAIR_UDP
5019 if (type == SOCK_DGRAM)
5020 return S_socketpair_udp(fd);
5023 aTHXa(PERL_GET_THX);
5024 listener = PerlSock_socket(AF_INET, type, 0);
5027 memset(&listen_addr, 0, sizeof(listen_addr));
5028 listen_addr.sin_family = AF_INET;
5029 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5030 listen_addr.sin_port = 0; /* kernel choses port. */
5031 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5032 sizeof(listen_addr)) == -1)
5033 goto tidy_up_and_fail;
5034 if (PerlSock_listen(listener, 1) == -1)
5035 goto tidy_up_and_fail;
5037 connector = PerlSock_socket(AF_INET, type, 0);
5038 if (connector == -1)
5039 goto tidy_up_and_fail;
5040 /* We want to find out the port number to connect to. */
5041 size = sizeof(connect_addr);
5042 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5044 goto tidy_up_and_fail;
5045 if (size != sizeof(connect_addr))
5046 goto abort_tidy_up_and_fail;
5047 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5048 sizeof(connect_addr)) == -1)
5049 goto tidy_up_and_fail;
5051 size = sizeof(listen_addr);
5052 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5055 goto tidy_up_and_fail;
5056 if (size != sizeof(listen_addr))
5057 goto abort_tidy_up_and_fail;
5058 PerlLIO_close(listener);
5059 /* Now check we are talking to ourself by matching port and host on the
5061 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5063 goto tidy_up_and_fail;
5064 if (size != sizeof(connect_addr)
5065 || listen_addr.sin_family != connect_addr.sin_family
5066 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5067 || listen_addr.sin_port != connect_addr.sin_port) {
5068 goto abort_tidy_up_and_fail;
5074 abort_tidy_up_and_fail:
5076 errno = ECONNABORTED; /* This would be the standard thing to do. */
5078 # ifdef ECONNREFUSED
5079 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5081 errno = ETIMEDOUT; /* Desperation time. */
5088 PerlLIO_close(listener);
5089 if (connector != -1)
5090 PerlLIO_close(connector);
5092 PerlLIO_close(acceptor);
5098 /* In any case have a stub so that there's code corresponding
5099 * to the my_socketpair in embed.fnc. */
5101 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5102 #ifdef HAS_SOCKETPAIR
5103 return socketpair(family, type, protocol, fd);
5112 =for apidoc sv_nosharing
5114 Dummy routine which "shares" an SV when there is no sharing module present.
5115 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5116 Exists to avoid test for a NULL function pointer and because it could
5117 potentially warn under some level of strict-ness.
5123 Perl_sv_nosharing(pTHX_ SV *sv)
5125 PERL_UNUSED_CONTEXT;
5126 PERL_UNUSED_ARG(sv);
5131 =for apidoc sv_destroyable
5133 Dummy routine which reports that object can be destroyed when there is no
5134 sharing module present. It ignores its single SV argument, and returns
5135 'true'. Exists to avoid test for a NULL function pointer and because it
5136 could potentially warn under some level of strict-ness.
5142 Perl_sv_destroyable(pTHX_ SV *sv)
5144 PERL_UNUSED_CONTEXT;
5145 PERL_UNUSED_ARG(sv);
5150 Perl_parse_unicode_opts(pTHX_ const char **popt)
5152 const char *p = *popt;
5155 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5159 opt = (U32) atoi(p);
5162 if (*p && *p != '\n' && *p != '\r') {
5163 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5165 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5171 case PERL_UNICODE_STDIN:
5172 opt |= PERL_UNICODE_STDIN_FLAG; break;
5173 case PERL_UNICODE_STDOUT:
5174 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5175 case PERL_UNICODE_STDERR:
5176 opt |= PERL_UNICODE_STDERR_FLAG; break;
5177 case PERL_UNICODE_STD:
5178 opt |= PERL_UNICODE_STD_FLAG; break;
5179 case PERL_UNICODE_IN:
5180 opt |= PERL_UNICODE_IN_FLAG; break;
5181 case PERL_UNICODE_OUT:
5182 opt |= PERL_UNICODE_OUT_FLAG; break;
5183 case PERL_UNICODE_INOUT:
5184 opt |= PERL_UNICODE_INOUT_FLAG; break;
5185 case PERL_UNICODE_LOCALE:
5186 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5187 case PERL_UNICODE_ARGV:
5188 opt |= PERL_UNICODE_ARGV_FLAG; break;
5189 case PERL_UNICODE_UTF8CACHEASSERT:
5190 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5192 if (*p != '\n' && *p != '\r') {
5193 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5196 "Unknown Unicode option letter '%c'", *p);
5203 opt = PERL_UNICODE_DEFAULT_FLAGS;
5205 the_end_of_the_opts_parser:
5207 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5208 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5209 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5217 # include <starlet.h>
5225 * This is really just a quick hack which grabs various garbage
5226 * values. It really should be a real hash algorithm which
5227 * spreads the effect of every input bit onto every output bit,
5228 * if someone who knows about such things would bother to write it.
5229 * Might be a good idea to add that function to CORE as well.
5230 * No numbers below come from careful analysis or anything here,
5231 * except they are primes and SEED_C1 > 1E6 to get a full-width
5232 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5233 * probably be bigger too.
5236 # define SEED_C1 1000003
5237 #define SEED_C4 73819
5239 # define SEED_C1 25747
5240 #define SEED_C4 20639
5244 #define SEED_C5 26107
5246 #ifndef PERL_NO_DEV_RANDOM
5251 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5252 * in 100-ns units, typically incremented ever 10 ms. */
5253 unsigned int when[2];
5255 # ifdef HAS_GETTIMEOFDAY
5256 struct timeval when;
5262 /* This test is an escape hatch, this symbol isn't set by Configure. */
5263 #ifndef PERL_NO_DEV_RANDOM
5264 #ifndef PERL_RANDOM_DEVICE
5265 /* /dev/random isn't used by default because reads from it will block
5266 * if there isn't enough entropy available. You can compile with
5267 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5268 * is enough real entropy to fill the seed. */
5269 # define PERL_RANDOM_DEVICE "/dev/urandom"
5271 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5273 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5282 _ckvmssts(sys$gettim(when));
5283 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5285 # ifdef HAS_GETTIMEOFDAY
5286 PerlProc_gettimeofday(&when,NULL);
5287 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5290 u = (U32)SEED_C1 * when;
5293 u += SEED_C3 * (U32)PerlProc_getpid();
5294 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5295 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5296 u += SEED_C5 * (U32)PTR2UV(&when);
5302 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
5308 PERL_ARGS_ASSERT_GET_HASH_SEED;
5310 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
5313 #ifndef USE_HASH_SEED_EXPLICIT
5315 /* ignore leading spaces */
5316 while (isSPACE(*env_pv))
5318 #ifdef USE_PERL_PERTURB_KEYS
5319 /* if they set it to "0" we disable key traversal randomization completely */
5320 if (strEQ(env_pv,"0")) {
5321 PL_hash_rand_bits_enabled= 0;
5323 /* otherwise switch to deterministic mode */
5324 PL_hash_rand_bits_enabled= 2;
5327 /* ignore a leading 0x... if it is there */
5328 if (env_pv[0] == '0' && env_pv[1] == 'x')
5331 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
5332 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
5333 if ( isXDIGIT(*env_pv)) {
5334 seed_buffer[i] |= READ_XDIGIT(env_pv);
5337 while (isSPACE(*env_pv))
5340 if (*env_pv && !isXDIGIT(*env_pv)) {
5341 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
5343 /* should we check for unparsed crap? */
5344 /* should we warn about unused hex? */
5345 /* should we warn about insufficient hex? */
5350 (void)seedDrand01((Rand_seed_t)seed());
5352 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
5353 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
5356 #ifdef USE_PERL_PERTURB_KEYS
5357 { /* initialize PL_hash_rand_bits from the hash seed.
5358 * This value is highly volatile, it is updated every
5359 * hash insert, and is used as part of hash bucket chain
5360 * randomization and hash iterator randomization. */
5361 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
5362 for( i = 0; i < sizeof(UV) ; i++ ) {
5363 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
5364 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
5367 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
5369 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
5370 PL_hash_rand_bits_enabled= 0;
5371 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
5372 PL_hash_rand_bits_enabled= 1;
5373 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
5374 PL_hash_rand_bits_enabled= 2;
5376 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
5382 #ifdef PERL_GLOBAL_STRUCT
5384 #define PERL_GLOBAL_STRUCT_INIT
5385 #include "opcode.h" /* the ppaddr and check */
5388 Perl_init_global_struct(pTHX)
5390 struct perl_vars *plvarsp = NULL;
5391 # ifdef PERL_GLOBAL_STRUCT
5392 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5393 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5394 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5395 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5396 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5400 plvarsp = PL_VarsPtr;
5401 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5406 # define PERLVAR(prefix,var,type) /**/
5407 # define PERLVARA(prefix,var,n,type) /**/
5408 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5409 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5410 # include "perlvars.h"
5415 # ifdef PERL_GLOBAL_STRUCT
5418 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5419 if (!plvarsp->Gppaddr)
5423 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5424 if (!plvarsp->Gcheck)
5426 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5427 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5429 # ifdef PERL_SET_VARS
5430 PERL_SET_VARS(plvarsp);
5432 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5433 plvarsp->Gsv_placeholder.sv_flags = 0;
5434 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
5436 # undef PERL_GLOBAL_STRUCT_INIT
5441 #endif /* PERL_GLOBAL_STRUCT */
5443 #ifdef PERL_GLOBAL_STRUCT
5446 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5448 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5449 # ifdef PERL_GLOBAL_STRUCT
5450 # ifdef PERL_UNSET_VARS
5451 PERL_UNSET_VARS(plvarsp);
5453 free(plvarsp->Gppaddr);
5454 free(plvarsp->Gcheck);
5455 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5461 #endif /* PERL_GLOBAL_STRUCT */
5465 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5466 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5467 * given, and you supply your own implementation.
5469 * The default implementation reads a single env var, PERL_MEM_LOG,
5470 * expecting one or more of the following:
5472 * \d+ - fd fd to write to : must be 1st (atoi)
5473 * 'm' - memlog was PERL_MEM_LOG=1
5474 * 's' - svlog was PERL_SV_LOG=1
5475 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5477 * This makes the logger controllable enough that it can reasonably be
5478 * added to the system perl.
5481 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5482 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5484 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5486 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5487 * writes to. In the default logger, this is settable at runtime.
5489 #ifndef PERL_MEM_LOG_FD
5490 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5493 #ifndef PERL_MEM_LOG_NOIMPL
5495 # ifdef DEBUG_LEAKING_SCALARS
5496 # define SV_LOG_SERIAL_FMT " [%lu]"
5497 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5499 # define SV_LOG_SERIAL_FMT
5500 # define _SV_LOG_SERIAL_ARG(sv)
5504 S_mem_log_common(enum mem_log_type mlt, const UV n,
5505 const UV typesize, const char *type_name, const SV *sv,
5506 Malloc_t oldalloc, Malloc_t newalloc,
5507 const char *filename, const int linenumber,
5508 const char *funcname)
5512 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5514 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5517 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5519 /* We can't use SVs or PerlIO for obvious reasons,
5520 * so we'll use stdio and low-level IO instead. */
5521 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5523 # ifdef HAS_GETTIMEOFDAY
5524 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5525 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5527 gettimeofday(&tv, 0);
5529 # define MEM_LOG_TIME_FMT "%10d: "
5530 # define MEM_LOG_TIME_ARG (int)when
5534 /* If there are other OS specific ways of hires time than
5535 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5536 * probably that they would be used to fill in the struct
5540 int fd = atoi(pmlenv);
5542 fd = PERL_MEM_LOG_FD;
5544 if (strchr(pmlenv, 't')) {
5545 len = my_snprintf(buf, sizeof(buf),
5546 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5547 PerlLIO_write(fd, buf, len);
5551 len = my_snprintf(buf, sizeof(buf),
5552 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5553 " %s = %"IVdf": %"UVxf"\n",
5554 filename, linenumber, funcname, n, typesize,
5555 type_name, n * typesize, PTR2UV(newalloc));
5558 len = my_snprintf(buf, sizeof(buf),
5559 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5560 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5561 filename, linenumber, funcname, n, typesize,
5562 type_name, n * typesize, PTR2UV(oldalloc),
5566 len = my_snprintf(buf, sizeof(buf),
5567 "free: %s:%d:%s: %"UVxf"\n",
5568 filename, linenumber, funcname,
5573 len = my_snprintf(buf, sizeof(buf),
5574 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5575 mlt == MLT_NEW_SV ? "new" : "del",
5576 filename, linenumber, funcname,
5577 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5582 PerlLIO_write(fd, buf, len);
5586 #endif /* !PERL_MEM_LOG_NOIMPL */
5588 #ifndef PERL_MEM_LOG_NOIMPL
5590 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5591 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5593 /* this is suboptimal, but bug compatible. User is providing their
5594 own implementation, but is getting these functions anyway, and they
5595 do nothing. But _NOIMPL users should be able to cope or fix */
5597 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5598 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5602 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5604 const char *filename, const int linenumber,
5605 const char *funcname)
5607 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5608 NULL, NULL, newalloc,
5609 filename, linenumber, funcname);
5614 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5615 Malloc_t oldalloc, Malloc_t newalloc,
5616 const char *filename, const int linenumber,
5617 const char *funcname)
5619 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5620 NULL, oldalloc, newalloc,
5621 filename, linenumber, funcname);
5626 Perl_mem_log_free(Malloc_t oldalloc,
5627 const char *filename, const int linenumber,
5628 const char *funcname)
5630 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5631 filename, linenumber, funcname);
5636 Perl_mem_log_new_sv(const SV *sv,
5637 const char *filename, const int linenumber,
5638 const char *funcname)
5640 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5641 filename, linenumber, funcname);
5645 Perl_mem_log_del_sv(const SV *sv,
5646 const char *filename, const int linenumber,
5647 const char *funcname)
5649 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5650 filename, linenumber, funcname);
5653 #endif /* PERL_MEM_LOG */
5656 =for apidoc my_sprintf
5658 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5659 the length of the string written to the buffer. Only rare pre-ANSI systems
5660 need the wrapper function - usually this is a direct call to C<sprintf>.
5664 #ifndef SPRINTF_RETURNS_STRLEN
5666 Perl_my_sprintf(char *buffer, const char* pat, ...)
5669 PERL_ARGS_ASSERT_MY_SPRINTF;
5670 va_start(args, pat);
5671 vsprintf(buffer, pat, args);
5673 return strlen(buffer);
5678 =for apidoc my_snprintf
5680 The C library C<snprintf> functionality, if available and
5681 standards-compliant (uses C<vsnprintf>, actually). However, if the
5682 C<vsnprintf> is not available, will unfortunately use the unsafe
5683 C<vsprintf> which can overrun the buffer (there is an overrun check,
5684 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5685 getting C<vsnprintf>.
5690 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5694 PERL_ARGS_ASSERT_MY_SNPRINTF;
5695 va_start(ap, format);
5696 #ifdef HAS_VSNPRINTF
5697 retval = vsnprintf(buffer, len, format, ap);
5699 retval = vsprintf(buffer, format, ap);
5702 /* vsprintf() shows failure with < 0 */
5704 #ifdef HAS_VSNPRINTF
5705 /* vsnprintf() shows failure with >= len */
5707 (len > 0 && (Size_t)retval >= len)
5710 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5715 =for apidoc my_vsnprintf
5717 The C library C<vsnprintf> if available and standards-compliant.
5718 However, if if the C<vsnprintf> is not available, will unfortunately
5719 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5720 overrun check, but that may be too late). Consider using
5721 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5726 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5732 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5734 Perl_va_copy(ap, apc);
5735 # ifdef HAS_VSNPRINTF
5736 retval = vsnprintf(buffer, len, format, apc);
5738 retval = vsprintf(buffer, format, apc);
5741 # ifdef HAS_VSNPRINTF
5742 retval = vsnprintf(buffer, len, format, ap);
5744 retval = vsprintf(buffer, format, ap);
5746 #endif /* #ifdef NEED_VA_COPY */
5747 /* vsprintf() shows failure with < 0 */
5749 #ifdef HAS_VSNPRINTF
5750 /* vsnprintf() shows failure with >= len */
5752 (len > 0 && (Size_t)retval >= len)
5755 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5760 Perl_my_clearenv(pTHX)
5763 #if ! defined(PERL_MICRO)
5764 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5766 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5767 # if defined(USE_ENVIRON_ARRAY)
5768 # if defined(USE_ITHREADS)
5769 /* only the parent thread can clobber the process environment */
5770 if (PL_curinterp == aTHX)
5771 # endif /* USE_ITHREADS */
5773 # if ! defined(PERL_USE_SAFE_PUTENV)
5774 if ( !PL_use_safe_putenv) {
5776 if (environ == PL_origenviron)
5777 environ = (char**)safesysmalloc(sizeof(char*));
5779 for (i = 0; environ[i]; i++)
5780 (void)safesysfree(environ[i]);
5783 # else /* PERL_USE_SAFE_PUTENV */
5784 # if defined(HAS_CLEARENV)
5786 # elif defined(HAS_UNSETENV)
5787 int bsiz = 80; /* Most envvar names will be shorter than this. */
5788 char *buf = (char*)safesysmalloc(bsiz);
5789 while (*environ != NULL) {
5790 char *e = strchr(*environ, '=');
5791 int l = e ? e - *environ : (int)strlen(*environ);
5793 (void)safesysfree(buf);
5794 bsiz = l + 1; /* + 1 for the \0. */
5795 buf = (char*)safesysmalloc(bsiz);
5797 memcpy(buf, *environ, l);
5799 (void)unsetenv(buf);
5801 (void)safesysfree(buf);
5802 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5803 /* Just null environ and accept the leakage. */
5805 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5806 # endif /* ! PERL_USE_SAFE_PUTENV */
5808 # endif /* USE_ENVIRON_ARRAY */
5809 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5810 #endif /* PERL_MICRO */
5813 #ifdef PERL_IMPLICIT_CONTEXT
5815 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5816 the global PL_my_cxt_index is incremented, and that value is assigned to
5817 that module's static my_cxt_index (who's address is passed as an arg).
5818 Then, for each interpreter this function is called for, it makes sure a
5819 void* slot is available to hang the static data off, by allocating or
5820 extending the interpreter's PL_my_cxt_list array */
5822 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5824 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5828 PERL_ARGS_ASSERT_MY_CXT_INIT;
5830 /* this module hasn't been allocated an index yet */
5831 #if defined(USE_ITHREADS)
5832 MUTEX_LOCK(&PL_my_ctx_mutex);
5834 *index = PL_my_cxt_index++;
5835 #if defined(USE_ITHREADS)
5836 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5840 /* make sure the array is big enough */
5841 if (PL_my_cxt_size <= *index) {
5842 if (PL_my_cxt_size) {
5843 while (PL_my_cxt_size <= *index)
5844 PL_my_cxt_size *= 2;
5845 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5848 PL_my_cxt_size = 16;
5849 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5852 /* newSV() allocates one more than needed */
5853 p = (void*)SvPVX(newSV(size-1));
5854 PL_my_cxt_list[*index] = p;
5855 Zero(p, size, char);
5859 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5862 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5867 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5869 for (index = 0; index < PL_my_cxt_index; index++) {
5870 const char *key = PL_my_cxt_keys[index];
5871 /* try direct pointer compare first - there are chances to success,
5872 * and it's much faster.
5874 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5881 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5887 PERL_ARGS_ASSERT_MY_CXT_INIT;
5889 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5891 /* this module hasn't been allocated an index yet */
5892 #if defined(USE_ITHREADS)
5893 MUTEX_LOCK(&PL_my_ctx_mutex);
5895 index = PL_my_cxt_index++;
5896 #if defined(USE_ITHREADS)
5897 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5901 /* make sure the array is big enough */
5902 if (PL_my_cxt_size <= index) {
5903 int old_size = PL_my_cxt_size;
5905 if (PL_my_cxt_size) {
5906 while (PL_my_cxt_size <= index)
5907 PL_my_cxt_size *= 2;
5908 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5909 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5912 PL_my_cxt_size = 16;
5913 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5914 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5916 for (i = old_size; i < PL_my_cxt_size; i++) {
5917 PL_my_cxt_keys[i] = 0;
5918 PL_my_cxt_list[i] = 0;
5921 PL_my_cxt_keys[index] = my_cxt_key;
5922 /* newSV() allocates one more than needed */
5923 p = (void*)SvPVX(newSV(size-1));
5924 PL_my_cxt_list[index] = p;
5925 Zero(p, size, char);
5928 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5929 #endif /* PERL_IMPLICIT_CONTEXT */
5932 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5936 const char *vn = NULL;
5937 SV *const module = PL_stack_base[ax];
5939 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5941 if (items >= 2) /* version supplied as bootstrap arg */
5942 sv = PL_stack_base[ax + 1];
5944 /* XXX GV_ADDWARN */
5946 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5947 if (!sv || !SvOK(sv)) {
5949 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5953 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5954 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5955 ? sv : sv_2mortal(new_version(sv));
5956 xssv = upg_version(xssv, 0);
5957 if ( vcmp(pmsv,xssv) ) {
5958 SV *string = vstringify(xssv);
5959 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5960 " does not match ", module, string);
5962 SvREFCNT_dec(string);
5963 string = vstringify(pmsv);
5966 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5969 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
5971 SvREFCNT_dec(string);
5973 Perl_sv_2mortal(aTHX_ xpt);
5974 Perl_croak_sv(aTHX_ xpt);
5980 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
5984 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
5987 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
5989 /* This might croak */
5990 compver = upg_version(compver, 0);
5991 /* This should never croak */
5992 runver = new_version(PL_apiversion);
5993 if (vcmp(compver, runver)) {
5994 SV *compver_string = vstringify(compver);
5995 SV *runver_string = vstringify(runver);
5996 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
5997 " of %"SVf" does not match %"SVf,
5998 compver_string, module, runver_string);
5999 Perl_sv_2mortal(aTHX_ xpt);
6001 SvREFCNT_dec(compver_string);
6002 SvREFCNT_dec(runver_string);
6004 SvREFCNT_dec(runver);
6006 Perl_croak_sv(aTHX_ xpt);
6010 =for apidoc my_strlcat
6012 The C library C<strlcat> if available, or a Perl implementation of it.
6013 This operates on C NUL-terminated strings.
6015 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
6016 most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
6017 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
6018 practice this should not happen as it means that either C<size> is incorrect or
6019 that C<dst> is not a proper NUL-terminated string).
6021 Note that C<size> is the full size of the destination buffer and
6022 the result is guaranteed to be NUL-terminated if there is room. Note that room
6023 for the NUL should be included in C<size>.
6027 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
6031 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6033 Size_t used, length, copy;
6036 length = strlen(src);
6037 if (size > 0 && used < size - 1) {
6038 copy = (length >= size - used) ? size - used - 1 : length;
6039 memcpy(dst + used, src, copy);
6040 dst[used + copy] = '\0';
6042 return used + length;
6048 =for apidoc my_strlcpy
6050 The C library C<strlcpy> if available, or a Perl implementation of it.
6051 This operates on C NUL-terminated strings.
6053 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
6054 to C<dst>, NUL-terminating the result if C<size> is not 0.
6058 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
6062 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6064 Size_t length, copy;
6066 length = strlen(src);
6068 copy = (length >= size) ? size - 1 : length;
6069 memcpy(dst, src, copy);
6076 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6077 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6078 long _ftol( double ); /* Defined by VC6 C libs. */
6079 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6082 PERL_STATIC_INLINE bool
6083 S_gv_has_usable_name(pTHX_ GV *gv)
6087 && HvENAME(GvSTASH(gv))
6088 && (gvp = (GV **)hv_fetch(
6089 GvSTASH(gv), GvNAME(gv),
6090 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6096 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6099 SV * const dbsv = GvSVn(PL_DBsub);
6100 const bool save_taint = TAINT_get;
6102 /* When we are called from pp_goto (svp is null),
6103 * we do not care about using dbsv to call CV;
6104 * it's for informational purposes only.
6107 PERL_ARGS_ASSERT_GET_DB_SUB;
6111 if (!PERLDB_SUB_NN) {
6115 gv_efullname3(dbsv, gv, NULL);
6117 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6118 || strEQ(GvNAME(gv), "END")
6119 || ( /* Could be imported, and old sub redefined. */
6120 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6122 !( (SvTYPE(*svp) == SVt_PVGV)
6123 && (GvCV((const GV *)*svp) == cv)
6124 /* Use GV from the stack as a fallback. */
6125 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6129 /* GV is potentially non-unique, or contain different CV. */
6130 SV * const tmp = newRV(MUTABLE_SV(cv));
6131 sv_setsv(dbsv, tmp);
6135 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6136 sv_catpvs(dbsv, "::");
6138 dbsv, GvNAME(gv), GvNAMELEN(gv),
6139 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6144 const int type = SvTYPE(dbsv);
6145 if (type < SVt_PVIV && type != SVt_IV)
6146 sv_upgrade(dbsv, SVt_PVIV);
6147 (void)SvIOK_on(dbsv);
6148 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6150 TAINT_IF(save_taint);
6151 #ifdef NO_TAINT_SUPPORT
6152 PERL_UNUSED_VAR(save_taint);
6157 Perl_my_dirfd(pTHX_ DIR * dir) {
6159 /* Most dirfd implementations have problems when passed NULL. */
6164 #elif defined(HAS_DIR_DD_FD)
6167 Perl_die(aTHX_ PL_no_func, "dirfd");
6168 assert(0); /* NOT REACHED */
6174 Perl_get_re_arg(pTHX_ SV *sv) {
6180 sv = MUTABLE_SV(SvRV(sv));
6181 if (SvTYPE(sv) == SVt_REGEXP)
6182 return (REGEXP*) sv;
6189 * This code is derived from drand48() implementation from FreeBSD,
6190 * found in lib/libc/gen/_rand48.c.
6192 * The U64 implementation is original, based on the POSIX
6193 * specification for drand48().
6197 * Copyright (c) 1993 Martin Birgmeier
6198 * All rights reserved.
6200 * You may redistribute unmodified or modified versions of this source
6201 * code provided that the above copyright notice and this and the
6202 * following conditions are retained.
6204 * This software is provided ``as is'', and comes with no warranties
6205 * of any kind. I shall in no event be liable for anything that happens
6206 * to anyone/anything when using this software.
6209 #define FREEBSD_DRAND48_SEED_0 (0x330e)
6211 #ifdef PERL_DRAND48_QUAD
6213 #define DRAND48_MULT U64_CONST(0x5deece66d)
6214 #define DRAND48_ADD 0xb
6215 #define DRAND48_MASK U64_CONST(0xffffffffffff)
6219 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
6220 #define FREEBSD_DRAND48_SEED_2 (0x1234)
6221 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
6222 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
6223 #define FREEBSD_DRAND48_MULT_2 (0x0005)
6224 #define FREEBSD_DRAND48_ADD (0x000b)
6226 const unsigned short _rand48_mult[3] = {
6227 FREEBSD_DRAND48_MULT_0,
6228 FREEBSD_DRAND48_MULT_1,
6229 FREEBSD_DRAND48_MULT_2
6231 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
6236 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
6238 PERL_ARGS_ASSERT_DRAND48_INIT_R;
6240 #ifdef PERL_DRAND48_QUAD
6241 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
6243 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
6244 random_state->seed[1] = (U16) seed;
6245 random_state->seed[2] = (U16) (seed >> 16);
6250 Perl_drand48_r(perl_drand48_t *random_state)
6252 PERL_ARGS_ASSERT_DRAND48_R;
6254 #ifdef PERL_DRAND48_QUAD
6255 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
6258 return ldexp((double)*random_state, -48);
6264 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
6265 + (U32) _rand48_add;
6266 temp[0] = (U16) accu; /* lower 16 bits */
6267 accu >>= sizeof(U16) * 8;
6268 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
6269 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
6270 temp[1] = (U16) accu; /* middle 16 bits */
6271 accu >>= sizeof(U16) * 8;
6272 accu += _rand48_mult[0] * random_state->seed[2]
6273 + _rand48_mult[1] * random_state->seed[1]
6274 + _rand48_mult[2] * random_state->seed[0];
6275 random_state->seed[0] = temp[0];
6276 random_state->seed[1] = temp[1];
6277 random_state->seed[2] = (U16) accu;
6279 return ldexp((double) random_state->seed[0], -48) +
6280 ldexp((double) random_state->seed[1], -32) +
6281 ldexp((double) random_state->seed[2], -16);
6289 * c-indentation-style: bsd
6291 * indent-tabs-mode: nil
6294 * ex: set ts=8 sts=4 sw=4 et: