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.
1599 /* Can't use PerlIO to write as it allocates memory */
1600 (void)PerlLIO_write(PerlIO_fileno(Perl_error_log),
1601 PL_no_mem, sizeof(PL_no_mem)-1);
1605 /* does not return, used only in POPSTACK */
1607 Perl_croak_popstack(void)
1610 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1615 =for apidoc Am|void|warn_sv|SV *baseex
1617 This is an XS interface to Perl's C<warn> function.
1619 C<baseex> is the error message or object. If it is a reference, it
1620 will be used as-is. Otherwise it is used as a string, and if it does
1621 not end with a newline then it will be extended with some indication of
1622 the current location in the code, as described for L</mess_sv>.
1624 The error message or object will by default be written to standard error,
1625 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1627 To warn with a simple string message, the L</warn> function may be
1634 Perl_warn_sv(pTHX_ SV *baseex)
1636 SV *ex = mess_sv(baseex, 0);
1637 PERL_ARGS_ASSERT_WARN_SV;
1638 if (!invoke_exception_hook(ex, TRUE))
1639 write_to_stderr(ex);
1643 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1645 This is an XS interface to Perl's C<warn> function.
1647 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1648 argument list. These are used to generate a string message. If the
1649 message does not end with a newline, then it will be extended with
1650 some indication of the current location in the code, as described for
1653 The error message or object will by default be written to standard error,
1654 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1656 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1662 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1664 SV *ex = vmess(pat, args);
1665 PERL_ARGS_ASSERT_VWARN;
1666 if (!invoke_exception_hook(ex, TRUE))
1667 write_to_stderr(ex);
1671 =for apidoc Am|void|warn|const char *pat|...
1673 This is an XS interface to Perl's C<warn> function.
1675 Take a sprintf-style format pattern and argument list. These are used to
1676 generate a string message. If the message does not end with a newline,
1677 then it will be extended with some indication of the current location
1678 in the code, as described for L</mess_sv>.
1680 The error message or object will by default be written to standard error,
1681 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1683 Unlike with L</croak>, C<pat> is not permitted to be null.
1688 #if defined(PERL_IMPLICIT_CONTEXT)
1690 Perl_warn_nocontext(const char *pat, ...)
1694 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1695 va_start(args, pat);
1699 #endif /* PERL_IMPLICIT_CONTEXT */
1702 Perl_warn(pTHX_ const char *pat, ...)
1705 PERL_ARGS_ASSERT_WARN;
1706 va_start(args, pat);
1711 #if defined(PERL_IMPLICIT_CONTEXT)
1713 Perl_warner_nocontext(U32 err, const char *pat, ...)
1717 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1718 va_start(args, pat);
1719 vwarner(err, pat, &args);
1722 #endif /* PERL_IMPLICIT_CONTEXT */
1725 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1727 PERL_ARGS_ASSERT_CK_WARNER_D;
1729 if (Perl_ckwarn_d(aTHX_ err)) {
1731 va_start(args, pat);
1732 vwarner(err, pat, &args);
1738 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1740 PERL_ARGS_ASSERT_CK_WARNER;
1742 if (Perl_ckwarn(aTHX_ err)) {
1744 va_start(args, pat);
1745 vwarner(err, pat, &args);
1751 Perl_warner(pTHX_ U32 err, const char* pat,...)
1754 PERL_ARGS_ASSERT_WARNER;
1755 va_start(args, pat);
1756 vwarner(err, pat, &args);
1761 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1764 PERL_ARGS_ASSERT_VWARNER;
1765 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1766 SV * const msv = vmess(pat, args);
1768 invoke_exception_hook(msv, FALSE);
1772 Perl_vwarn(aTHX_ pat, args);
1776 /* implements the ckWARN? macros */
1779 Perl_ckwarn(pTHX_ U32 w)
1782 /* If lexical warnings have not been set, use $^W. */
1784 return PL_dowarn & G_WARN_ON;
1786 return ckwarn_common(w);
1789 /* implements the ckWARN?_d macro */
1792 Perl_ckwarn_d(pTHX_ U32 w)
1795 /* If lexical warnings have not been set then default classes warn. */
1799 return ckwarn_common(w);
1803 S_ckwarn_common(pTHX_ U32 w)
1805 if (PL_curcop->cop_warnings == pWARN_ALL)
1808 if (PL_curcop->cop_warnings == pWARN_NONE)
1811 /* Check the assumption that at least the first slot is non-zero. */
1812 assert(unpackWARN1(w));
1814 /* Check the assumption that it is valid to stop as soon as a zero slot is
1816 if (!unpackWARN2(w)) {
1817 assert(!unpackWARN3(w));
1818 assert(!unpackWARN4(w));
1819 } else if (!unpackWARN3(w)) {
1820 assert(!unpackWARN4(w));
1823 /* Right, dealt with all the special cases, which are implemented as non-
1824 pointers, so there is a pointer to a real warnings mask. */
1826 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1828 } while (w >>= WARNshift);
1833 /* Set buffer=NULL to get a new one. */
1835 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1837 const MEM_SIZE len_wanted =
1838 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1839 PERL_UNUSED_CONTEXT;
1840 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1843 (specialWARN(buffer) ?
1844 PerlMemShared_malloc(len_wanted) :
1845 PerlMemShared_realloc(buffer, len_wanted));
1847 Copy(bits, (buffer + 1), size, char);
1848 if (size < WARNsize)
1849 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1853 /* since we've already done strlen() for both nam and val
1854 * we can use that info to make things faster than
1855 * sprintf(s, "%s=%s", nam, val)
1857 #define my_setenv_format(s, nam, nlen, val, vlen) \
1858 Copy(nam, s, nlen, char); \
1860 Copy(val, s+(nlen+1), vlen, char); \
1861 *(s+(nlen+1+vlen)) = '\0'
1863 #ifdef USE_ENVIRON_ARRAY
1864 /* VMS' my_setenv() is in vms.c */
1865 #if !defined(WIN32) && !defined(NETWARE)
1867 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1871 /* only parent thread can modify process environment */
1872 if (PL_curinterp == aTHX)
1875 #ifndef PERL_USE_SAFE_PUTENV
1876 if (!PL_use_safe_putenv) {
1877 /* most putenv()s leak, so we manipulate environ directly */
1879 const I32 len = strlen(nam);
1882 /* where does it go? */
1883 for (i = 0; environ[i]; i++) {
1884 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1888 if (environ == PL_origenviron) { /* need we copy environment? */
1894 while (environ[max])
1896 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1897 for (j=0; j<max; j++) { /* copy environment */
1898 const int len = strlen(environ[j]);
1899 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1900 Copy(environ[j], tmpenv[j], len+1, char);
1903 environ = tmpenv; /* tell exec where it is now */
1906 safesysfree(environ[i]);
1907 while (environ[i]) {
1908 environ[i] = environ[i+1];
1913 if (!environ[i]) { /* does not exist yet */
1914 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1915 environ[i+1] = NULL; /* make sure it's null terminated */
1918 safesysfree(environ[i]);
1922 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1923 /* all that work just for this */
1924 my_setenv_format(environ[i], nam, nlen, val, vlen);
1927 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
1928 # if defined(HAS_UNSETENV)
1930 (void)unsetenv(nam);
1932 (void)setenv(nam, val, 1);
1934 # else /* ! HAS_UNSETENV */
1935 (void)setenv(nam, val, 1);
1936 # endif /* HAS_UNSETENV */
1938 # if defined(HAS_UNSETENV)
1940 if (environ) /* old glibc can crash with null environ */
1941 (void)unsetenv(nam);
1943 const int nlen = strlen(nam);
1944 const int vlen = strlen(val);
1945 char * const new_env =
1946 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1947 my_setenv_format(new_env, nam, nlen, val, vlen);
1948 (void)putenv(new_env);
1950 # else /* ! HAS_UNSETENV */
1952 const int nlen = strlen(nam);
1958 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1959 /* all that work just for this */
1960 my_setenv_format(new_env, nam, nlen, val, vlen);
1961 (void)putenv(new_env);
1962 # endif /* HAS_UNSETENV */
1963 # endif /* __CYGWIN__ */
1964 #ifndef PERL_USE_SAFE_PUTENV
1970 #else /* WIN32 || NETWARE */
1973 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1977 const int nlen = strlen(nam);
1984 Newx(envstr, nlen+vlen+2, char);
1985 my_setenv_format(envstr, nam, nlen, val, vlen);
1986 (void)PerlEnv_putenv(envstr);
1990 #endif /* WIN32 || NETWARE */
1994 #ifdef UNLINK_ALL_VERSIONS
1996 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2000 PERL_ARGS_ASSERT_UNLNK;
2002 while (PerlLIO_unlink(f) >= 0)
2004 return retries ? 0 : -1;
2008 /* this is a drop-in replacement for bcopy() */
2009 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2011 Perl_my_bcopy(const char *from, char *to, I32 len)
2013 char * const retval = to;
2015 PERL_ARGS_ASSERT_MY_BCOPY;
2019 if (from - to >= 0) {
2027 *(--to) = *(--from);
2033 /* this is a drop-in replacement for memset() */
2036 Perl_my_memset(char *loc, I32 ch, I32 len)
2038 char * const retval = loc;
2040 PERL_ARGS_ASSERT_MY_MEMSET;
2050 /* this is a drop-in replacement for bzero() */
2051 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2053 Perl_my_bzero(char *loc, I32 len)
2055 char * const retval = loc;
2057 PERL_ARGS_ASSERT_MY_BZERO;
2067 /* this is a drop-in replacement for memcmp() */
2068 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2070 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2072 const U8 *a = (const U8 *)s1;
2073 const U8 *b = (const U8 *)s2;
2076 PERL_ARGS_ASSERT_MY_MEMCMP;
2081 if ((tmp = *a++ - *b++))
2086 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2089 /* This vsprintf replacement should generally never get used, since
2090 vsprintf was available in both System V and BSD 2.11. (There may
2091 be some cross-compilation or embedded set-ups where it is needed,
2094 If you encounter a problem in this function, it's probably a symptom
2095 that Configure failed to detect your system's vprintf() function.
2096 See the section on "item vsprintf" in the INSTALL file.
2098 This version may compile on systems with BSD-ish <stdio.h>,
2099 but probably won't on others.
2102 #ifdef USE_CHAR_VSPRINTF
2107 vsprintf(char *dest, const char *pat, void *args)
2111 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2112 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2113 FILE_cnt(&fakebuf) = 32767;
2115 /* These probably won't compile -- If you really need
2116 this, you'll have to figure out some other method. */
2117 fakebuf._ptr = dest;
2118 fakebuf._cnt = 32767;
2123 fakebuf._flag = _IOWRT|_IOSTRG;
2124 _doprnt(pat, args, &fakebuf); /* what a kludge */
2125 #if defined(STDIO_PTR_LVALUE)
2126 *(FILE_ptr(&fakebuf)++) = '\0';
2128 /* PerlIO has probably #defined away fputc, but we want it here. */
2130 # undef fputc /* XXX Should really restore it later */
2132 (void)fputc('\0', &fakebuf);
2134 #ifdef USE_CHAR_VSPRINTF
2137 return 0; /* perl doesn't use return value */
2141 #endif /* HAS_VPRINTF */
2144 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2146 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2155 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2157 PERL_FLUSHALL_FOR_CHILD;
2158 This = (*mode == 'w');
2162 taint_proper("Insecure %s%s", "EXEC");
2164 if (PerlProc_pipe(p) < 0)
2166 /* Try for another pipe pair for error return */
2167 if (PerlProc_pipe(pp) >= 0)
2169 while ((pid = PerlProc_fork()) < 0) {
2170 if (errno != EAGAIN) {
2171 PerlLIO_close(p[This]);
2172 PerlLIO_close(p[that]);
2174 PerlLIO_close(pp[0]);
2175 PerlLIO_close(pp[1]);
2179 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2188 /* Close parent's end of error status pipe (if any) */
2190 PerlLIO_close(pp[0]);
2191 #if defined(HAS_FCNTL) && defined(F_SETFD)
2192 /* Close error pipe automatically if exec works */
2193 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2196 /* Now dup our end of _the_ pipe to right position */
2197 if (p[THIS] != (*mode == 'r')) {
2198 PerlLIO_dup2(p[THIS], *mode == 'r');
2199 PerlLIO_close(p[THIS]);
2200 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2201 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2204 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2205 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2206 /* No automatic close - do it by hand */
2213 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2219 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2225 do_execfree(); /* free any memory malloced by child on fork */
2227 PerlLIO_close(pp[1]);
2228 /* Keep the lower of the two fd numbers */
2229 if (p[that] < p[This]) {
2230 PerlLIO_dup2(p[This], p[that]);
2231 PerlLIO_close(p[This]);
2235 PerlLIO_close(p[that]); /* close child's end of pipe */
2237 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2238 SvUPGRADE(sv,SVt_IV);
2240 PL_forkprocess = pid;
2241 /* If we managed to get status pipe check for exec fail */
2242 if (did_pipes && pid > 0) {
2247 while (n < sizeof(int)) {
2248 n1 = PerlLIO_read(pp[0],
2249 (void*)(((char*)&errkid)+n),
2255 PerlLIO_close(pp[0]);
2257 if (n) { /* Error */
2259 PerlLIO_close(p[This]);
2260 if (n != sizeof(int))
2261 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2263 pid2 = wait4pid(pid, &status, 0);
2264 } while (pid2 == -1 && errno == EINTR);
2265 errno = errkid; /* Propagate errno from kid */
2270 PerlLIO_close(pp[0]);
2271 return PerlIO_fdopen(p[This], mode);
2273 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2274 return my_syspopen4(aTHX_ NULL, mode, n, args);
2276 Perl_croak(aTHX_ "List form of piped open not implemented");
2277 return (PerlIO *) NULL;
2282 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2283 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2285 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2292 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2296 PERL_ARGS_ASSERT_MY_POPEN;
2298 PERL_FLUSHALL_FOR_CHILD;
2301 return my_syspopen(aTHX_ cmd,mode);
2304 This = (*mode == 'w');
2306 if (doexec && TAINTING_get) {
2308 taint_proper("Insecure %s%s", "EXEC");
2310 if (PerlProc_pipe(p) < 0)
2312 if (doexec && PerlProc_pipe(pp) >= 0)
2314 while ((pid = PerlProc_fork()) < 0) {
2315 if (errno != EAGAIN) {
2316 PerlLIO_close(p[This]);
2317 PerlLIO_close(p[that]);
2319 PerlLIO_close(pp[0]);
2320 PerlLIO_close(pp[1]);
2323 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2326 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2336 PerlLIO_close(pp[0]);
2337 #if defined(HAS_FCNTL) && defined(F_SETFD)
2338 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2341 if (p[THIS] != (*mode == 'r')) {
2342 PerlLIO_dup2(p[THIS], *mode == 'r');
2343 PerlLIO_close(p[THIS]);
2344 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2345 PerlLIO_close(p[THAT]);
2348 PerlLIO_close(p[THAT]);
2351 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2358 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2363 /* may or may not use the shell */
2364 do_exec3(cmd, pp[1], did_pipes);
2367 #endif /* defined OS2 */
2369 #ifdef PERLIO_USING_CRLF
2370 /* Since we circumvent IO layers when we manipulate low-level
2371 filedescriptors directly, need to manually switch to the
2372 default, binary, low-level mode; see PerlIOBuf_open(). */
2373 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2376 #ifdef PERL_USES_PL_PIDSTATUS
2377 hv_clear(PL_pidstatus); /* we have no children */
2383 do_execfree(); /* free any memory malloced by child on vfork */
2385 PerlLIO_close(pp[1]);
2386 if (p[that] < p[This]) {
2387 PerlLIO_dup2(p[This], p[that]);
2388 PerlLIO_close(p[This]);
2392 PerlLIO_close(p[that]);
2394 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2395 SvUPGRADE(sv,SVt_IV);
2397 PL_forkprocess = pid;
2398 if (did_pipes && pid > 0) {
2403 while (n < sizeof(int)) {
2404 n1 = PerlLIO_read(pp[0],
2405 (void*)(((char*)&errkid)+n),
2411 PerlLIO_close(pp[0]);
2413 if (n) { /* Error */
2415 PerlLIO_close(p[This]);
2416 if (n != sizeof(int))
2417 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2419 pid2 = wait4pid(pid, &status, 0);
2420 } while (pid2 == -1 && errno == EINTR);
2421 errno = errkid; /* Propagate errno from kid */
2426 PerlLIO_close(pp[0]);
2427 return PerlIO_fdopen(p[This], mode);
2431 FILE *djgpp_popen();
2433 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2435 PERL_FLUSHALL_FOR_CHILD;
2436 /* Call system's popen() to get a FILE *, then import it.
2437 used 0 for 2nd parameter to PerlIO_importFILE;
2440 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2443 #if defined(__LIBCATAMOUNT__)
2445 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2452 #endif /* !DOSISH */
2454 /* this is called in parent before the fork() */
2456 Perl_atfork_lock(void)
2459 #if defined(USE_ITHREADS)
2460 /* locks must be held in locking order (if any) */
2462 MUTEX_LOCK(&PL_perlio_mutex);
2465 MUTEX_LOCK(&PL_malloc_mutex);
2471 /* this is called in both parent and child after the fork() */
2473 Perl_atfork_unlock(void)
2476 #if defined(USE_ITHREADS)
2477 /* locks must be released in same order as in atfork_lock() */
2479 MUTEX_UNLOCK(&PL_perlio_mutex);
2482 MUTEX_UNLOCK(&PL_malloc_mutex);
2491 #if defined(HAS_FORK)
2493 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2498 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2499 * handlers elsewhere in the code */
2504 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2505 Perl_croak_nocontext("fork() not available");
2507 #endif /* HAS_FORK */
2512 dup2(int oldfd, int newfd)
2514 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2517 PerlLIO_close(newfd);
2518 return fcntl(oldfd, F_DUPFD, newfd);
2520 #define DUP2_MAX_FDS 256
2521 int fdtmp[DUP2_MAX_FDS];
2527 PerlLIO_close(newfd);
2528 /* good enough for low fd's... */
2529 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2530 if (fdx >= DUP2_MAX_FDS) {
2538 PerlLIO_close(fdtmp[--fdx]);
2545 #ifdef HAS_SIGACTION
2548 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2551 struct sigaction act, oact;
2554 /* only "parent" interpreter can diddle signals */
2555 if (PL_curinterp != aTHX)
2556 return (Sighandler_t) SIG_ERR;
2559 act.sa_handler = (void(*)(int))handler;
2560 sigemptyset(&act.sa_mask);
2563 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2564 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2566 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2567 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2568 act.sa_flags |= SA_NOCLDWAIT;
2570 if (sigaction(signo, &act, &oact) == -1)
2571 return (Sighandler_t) SIG_ERR;
2573 return (Sighandler_t) oact.sa_handler;
2577 Perl_rsignal_state(pTHX_ int signo)
2579 struct sigaction oact;
2580 PERL_UNUSED_CONTEXT;
2582 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2583 return (Sighandler_t) SIG_ERR;
2585 return (Sighandler_t) oact.sa_handler;
2589 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2592 struct sigaction act;
2594 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2597 /* only "parent" interpreter can diddle signals */
2598 if (PL_curinterp != aTHX)
2602 act.sa_handler = (void(*)(int))handler;
2603 sigemptyset(&act.sa_mask);
2606 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2607 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2609 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2610 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2611 act.sa_flags |= SA_NOCLDWAIT;
2613 return sigaction(signo, &act, save);
2617 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2621 /* only "parent" interpreter can diddle signals */
2622 if (PL_curinterp != aTHX)
2626 return sigaction(signo, save, (struct sigaction *)NULL);
2629 #else /* !HAS_SIGACTION */
2632 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2634 #if defined(USE_ITHREADS) && !defined(WIN32)
2635 /* only "parent" interpreter can diddle signals */
2636 if (PL_curinterp != aTHX)
2637 return (Sighandler_t) SIG_ERR;
2640 return PerlProc_signal(signo, handler);
2651 Perl_rsignal_state(pTHX_ int signo)
2654 Sighandler_t oldsig;
2656 #if defined(USE_ITHREADS) && !defined(WIN32)
2657 /* only "parent" interpreter can diddle signals */
2658 if (PL_curinterp != aTHX)
2659 return (Sighandler_t) SIG_ERR;
2663 oldsig = PerlProc_signal(signo, sig_trap);
2664 PerlProc_signal(signo, oldsig);
2666 PerlProc_kill(PerlProc_getpid(), signo);
2671 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2673 #if defined(USE_ITHREADS) && !defined(WIN32)
2674 /* only "parent" interpreter can diddle signals */
2675 if (PL_curinterp != aTHX)
2678 *save = PerlProc_signal(signo, handler);
2679 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2683 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2685 #if defined(USE_ITHREADS) && !defined(WIN32)
2686 /* only "parent" interpreter can diddle signals */
2687 if (PL_curinterp != aTHX)
2690 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2693 #endif /* !HAS_SIGACTION */
2694 #endif /* !PERL_MICRO */
2696 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2697 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2699 Perl_my_pclose(pTHX_ PerlIO *ptr)
2708 const int fd = PerlIO_fileno(ptr);
2711 svp = av_fetch(PL_fdpid,fd,TRUE);
2712 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2717 /* Find out whether the refcount is low enough for us to wait for the
2718 child proc without blocking. */
2719 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2721 should_wait = pid > 0;
2725 if (pid == -1) { /* Opened by popen. */
2726 return my_syspclose(ptr);
2729 close_failed = (PerlIO_close(ptr) == EOF);
2731 if (should_wait) do {
2732 pid2 = wait4pid(pid, &status, 0);
2733 } while (pid2 == -1 && errno == EINTR);
2740 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2745 #if defined(__LIBCATAMOUNT__)
2747 Perl_my_pclose(pTHX_ PerlIO *ptr)
2752 #endif /* !DOSISH */
2754 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2756 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2760 PERL_ARGS_ASSERT_WAIT4PID;
2761 #ifdef PERL_USES_PL_PIDSTATUS
2763 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2764 waitpid() nor wait4() is available, or on OS/2, which
2765 doesn't appear to support waiting for a progress group
2766 member, so we can only treat a 0 pid as an unknown child.
2773 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2774 pid, rather than a string form. */
2775 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2776 if (svp && *svp != &PL_sv_undef) {
2777 *statusp = SvIVX(*svp);
2778 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2786 hv_iterinit(PL_pidstatus);
2787 if ((entry = hv_iternext(PL_pidstatus))) {
2788 SV * const sv = hv_iterval(PL_pidstatus,entry);
2790 const char * const spid = hv_iterkey(entry,&len);
2792 assert (len == sizeof(Pid_t));
2793 memcpy((char *)&pid, spid, len);
2794 *statusp = SvIVX(sv);
2795 /* The hash iterator is currently on this entry, so simply
2796 calling hv_delete would trigger the lazy delete, which on
2797 aggregate does more work, beacuse next call to hv_iterinit()
2798 would spot the flag, and have to call the delete routine,
2799 while in the meantime any new entries can't re-use that
2801 hv_iterinit(PL_pidstatus);
2802 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2809 # ifdef HAS_WAITPID_RUNTIME
2810 if (!HAS_WAITPID_RUNTIME)
2813 result = PerlProc_waitpid(pid,statusp,flags);
2816 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2817 result = wait4(pid,statusp,flags,NULL);
2820 #ifdef PERL_USES_PL_PIDSTATUS
2821 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2826 Perl_croak(aTHX_ "Can't do waitpid with flags");
2828 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2829 pidgone(result,*statusp);
2835 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2838 if (result < 0 && errno == EINTR) {
2840 errno = EINTR; /* reset in case a signal handler changed $! */
2844 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2846 #ifdef PERL_USES_PL_PIDSTATUS
2848 S_pidgone(pTHX_ Pid_t pid, int status)
2852 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2853 SvUPGRADE(sv,SVt_IV);
2854 SvIV_set(sv, status);
2862 int /* Cannot prototype with I32
2864 my_syspclose(PerlIO *ptr)
2867 Perl_my_pclose(pTHX_ PerlIO *ptr)
2870 /* Needs work for PerlIO ! */
2871 FILE * const f = PerlIO_findFILE(ptr);
2872 const I32 result = pclose(f);
2873 PerlIO_releaseFILE(ptr,f);
2881 Perl_my_pclose(pTHX_ PerlIO *ptr)
2883 /* Needs work for PerlIO ! */
2884 FILE * const f = PerlIO_findFILE(ptr);
2885 I32 result = djgpp_pclose(f);
2886 result = (result << 8) & 0xff00;
2887 PerlIO_releaseFILE(ptr,f);
2892 #define PERL_REPEATCPY_LINEAR 4
2894 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2896 PERL_ARGS_ASSERT_REPEATCPY;
2901 croak_memory_wrap();
2904 memset(to, *from, count);
2907 IV items, linear, half;
2909 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2910 for (items = 0; items < linear; ++items) {
2911 const char *q = from;
2913 for (todo = len; todo > 0; todo--)
2918 while (items <= half) {
2919 IV size = items * len;
2920 memcpy(p, to, size);
2926 memcpy(p, to, (count - items) * len);
2932 Perl_same_dirent(pTHX_ const char *a, const char *b)
2934 char *fa = strrchr(a,'/');
2935 char *fb = strrchr(b,'/');
2938 SV * const tmpsv = sv_newmortal();
2940 PERL_ARGS_ASSERT_SAME_DIRENT;
2953 sv_setpvs(tmpsv, ".");
2955 sv_setpvn(tmpsv, a, fa - a);
2956 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2959 sv_setpvs(tmpsv, ".");
2961 sv_setpvn(tmpsv, b, fb - b);
2962 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2964 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2965 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2967 #endif /* !HAS_RENAME */
2970 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2971 const char *const *const search_ext, I32 flags)
2974 const char *xfound = NULL;
2975 char *xfailed = NULL;
2976 char tmpbuf[MAXPATHLEN];
2981 #if defined(DOSISH) && !defined(OS2)
2982 # define SEARCH_EXTS ".bat", ".cmd", NULL
2983 # define MAX_EXT_LEN 4
2986 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2987 # define MAX_EXT_LEN 4
2990 # define SEARCH_EXTS ".pl", ".com", NULL
2991 # define MAX_EXT_LEN 4
2993 /* additional extensions to try in each dir if scriptname not found */
2995 static const char *const exts[] = { SEARCH_EXTS };
2996 const char *const *const ext = search_ext ? search_ext : exts;
2997 int extidx = 0, i = 0;
2998 const char *curext = NULL;
3000 PERL_UNUSED_ARG(search_ext);
3001 # define MAX_EXT_LEN 0
3004 PERL_ARGS_ASSERT_FIND_SCRIPT;
3007 * If dosearch is true and if scriptname does not contain path
3008 * delimiters, search the PATH for scriptname.
3010 * If SEARCH_EXTS is also defined, will look for each
3011 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3012 * while searching the PATH.
3014 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3015 * proceeds as follows:
3016 * If DOSISH or VMSISH:
3017 * + look for ./scriptname{,.foo,.bar}
3018 * + search the PATH for scriptname{,.foo,.bar}
3021 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3022 * this will not look in '.' if it's not in the PATH)
3027 # ifdef ALWAYS_DEFTYPES
3028 len = strlen(scriptname);
3029 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3030 int idx = 0, deftypes = 1;
3033 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3036 int idx = 0, deftypes = 1;
3039 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3041 /* The first time through, just add SEARCH_EXTS to whatever we
3042 * already have, so we can check for default file types. */
3044 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3050 if ((strlen(tmpbuf) + strlen(scriptname)
3051 + MAX_EXT_LEN) >= sizeof tmpbuf)
3052 continue; /* don't search dir with too-long name */
3053 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3057 if (strEQ(scriptname, "-"))
3059 if (dosearch) { /* Look in '.' first. */
3060 const char *cur = scriptname;
3062 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3064 if (strEQ(ext[i++],curext)) {
3065 extidx = -1; /* already has an ext */
3070 DEBUG_p(PerlIO_printf(Perl_debug_log,
3071 "Looking for %s\n",cur));
3072 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3073 && !S_ISDIR(PL_statbuf.st_mode)) {
3081 if (cur == scriptname) {
3082 len = strlen(scriptname);
3083 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3085 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3088 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3089 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3094 if (dosearch && !strchr(scriptname, '/')
3096 && !strchr(scriptname, '\\')
3098 && (s = PerlEnv_getenv("PATH")))
3102 bufend = s + strlen(s);
3103 while (s < bufend) {
3106 && *s != ';'; len++, s++) {
3107 if (len < sizeof tmpbuf)
3110 if (len < sizeof tmpbuf)
3113 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3119 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3120 continue; /* don't search dir with too-long name */
3123 && tmpbuf[len - 1] != '/'
3124 && tmpbuf[len - 1] != '\\'
3127 tmpbuf[len++] = '/';
3128 if (len == 2 && tmpbuf[0] == '.')
3130 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3134 len = strlen(tmpbuf);
3135 if (extidx > 0) /* reset after previous loop */
3139 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3140 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3141 if (S_ISDIR(PL_statbuf.st_mode)) {
3145 } while ( retval < 0 /* not there */
3146 && extidx>=0 && ext[extidx] /* try an extension? */
3147 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3152 if (S_ISREG(PL_statbuf.st_mode)
3153 && cando(S_IRUSR,TRUE,&PL_statbuf)
3154 #if !defined(DOSISH)
3155 && cando(S_IXUSR,TRUE,&PL_statbuf)
3159 xfound = tmpbuf; /* bingo! */
3163 xfailed = savepv(tmpbuf);
3166 if (!xfound && !seen_dot && !xfailed &&
3167 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3168 || S_ISDIR(PL_statbuf.st_mode)))
3170 seen_dot = 1; /* Disable message. */
3172 if (flags & 1) { /* do or die? */
3173 /* diag_listed_as: Can't execute %s */
3174 Perl_croak(aTHX_ "Can't %s %s%s%s",
3175 (xfailed ? "execute" : "find"),
3176 (xfailed ? xfailed : scriptname),
3177 (xfailed ? "" : " on PATH"),
3178 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3183 scriptname = xfound;
3185 return (scriptname ? savepv(scriptname) : NULL);
3188 #ifndef PERL_GET_CONTEXT_DEFINED
3191 Perl_get_context(void)
3194 #if defined(USE_ITHREADS)
3195 # ifdef OLD_PTHREADS_API
3197 int error = pthread_getspecific(PL_thr_key, &t)
3199 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3202 # ifdef I_MACH_CTHREADS
3203 return (void*)cthread_data(cthread_self());
3205 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3214 Perl_set_context(void *t)
3217 PERL_ARGS_ASSERT_SET_CONTEXT;
3218 #if defined(USE_ITHREADS)
3219 # ifdef I_MACH_CTHREADS
3220 cthread_set_data(cthread_self(), t);
3223 const int error = pthread_setspecific(PL_thr_key, t);
3225 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3233 #endif /* !PERL_GET_CONTEXT_DEFINED */
3235 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3244 Perl_get_op_names(pTHX)
3246 PERL_UNUSED_CONTEXT;
3247 return (char **)PL_op_name;
3251 Perl_get_op_descs(pTHX)
3253 PERL_UNUSED_CONTEXT;
3254 return (char **)PL_op_desc;
3258 Perl_get_no_modify(pTHX)
3260 PERL_UNUSED_CONTEXT;
3261 return PL_no_modify;
3265 Perl_get_opargs(pTHX)
3267 PERL_UNUSED_CONTEXT;
3268 return (U32 *)PL_opargs;
3272 Perl_get_ppaddr(pTHX)
3275 PERL_UNUSED_CONTEXT;
3276 return (PPADDR_t*)PL_ppaddr;
3279 #ifndef HAS_GETENV_LEN
3281 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3283 char * const env_trans = PerlEnv_getenv(env_elem);
3284 PERL_UNUSED_CONTEXT;
3285 PERL_ARGS_ASSERT_GETENV_LEN;
3287 *len = strlen(env_trans);
3294 Perl_get_vtbl(pTHX_ int vtbl_id)
3296 PERL_UNUSED_CONTEXT;
3298 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3299 ? NULL : PL_magic_vtables + vtbl_id;
3303 Perl_my_fflush_all(pTHX)
3305 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3306 return PerlIO_flush(NULL);
3308 # if defined(HAS__FWALK)
3309 extern int fflush(FILE *);
3310 /* undocumented, unprototyped, but very useful BSDism */
3311 extern void _fwalk(int (*)(FILE *));
3315 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3317 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3318 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3320 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3321 open_max = sysconf(_SC_OPEN_MAX);
3324 open_max = FOPEN_MAX;
3327 open_max = OPEN_MAX;
3338 for (i = 0; i < open_max; i++)
3339 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3340 STDIO_STREAM_ARRAY[i]._file < open_max &&
3341 STDIO_STREAM_ARRAY[i]._flag)
3342 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3346 SETERRNO(EBADF,RMS_IFI);
3353 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3355 if (ckWARN(WARN_IO)) {
3357 = gv && (isGV_with_GP(gv))
3360 const char * const direction = have == '>' ? "out" : "in";
3362 if (name && HEK_LEN(name))
3363 Perl_warner(aTHX_ packWARN(WARN_IO),
3364 "Filehandle %"HEKf" opened only for %sput",
3367 Perl_warner(aTHX_ packWARN(WARN_IO),
3368 "Filehandle opened only for %sput", direction);
3373 Perl_report_evil_fh(pTHX_ const GV *gv)
3375 const IO *io = gv ? GvIO(gv) : NULL;
3376 const PERL_BITFIELD16 op = PL_op->op_type;
3380 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3382 warn_type = WARN_CLOSED;
3386 warn_type = WARN_UNOPENED;
3389 if (ckWARN(warn_type)) {
3391 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3392 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3393 const char * const pars =
3394 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3395 const char * const func =
3397 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3398 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3400 const char * const type =
3402 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3403 ? "socket" : "filehandle");
3404 const bool have_name = name && SvCUR(name);
3405 Perl_warner(aTHX_ packWARN(warn_type),
3406 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3407 have_name ? " " : "",
3408 SVfARG(have_name ? name : &PL_sv_no));
3409 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3411 aTHX_ packWARN(warn_type),
3412 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3413 func, pars, have_name ? " " : "",
3414 SVfARG(have_name ? name : &PL_sv_no)
3419 /* To workaround core dumps from the uninitialised tm_zone we get the
3420 * system to give us a reasonable struct to copy. This fix means that
3421 * strftime uses the tm_zone and tm_gmtoff values returned by
3422 * localtime(time()). That should give the desired result most of the
3423 * time. But probably not always!
3425 * This does not address tzname aspects of NETaa14816.
3430 # ifndef STRUCT_TM_HASZONE
3431 # define STRUCT_TM_HASZONE
3435 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3436 # ifndef HAS_TM_TM_ZONE
3437 # define HAS_TM_TM_ZONE
3442 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3444 #ifdef HAS_TM_TM_ZONE
3446 const struct tm* my_tm;
3447 PERL_ARGS_ASSERT_INIT_TM;
3449 my_tm = localtime(&now);
3451 Copy(my_tm, ptm, 1, struct tm);
3453 PERL_ARGS_ASSERT_INIT_TM;
3454 PERL_UNUSED_ARG(ptm);
3459 * mini_mktime - normalise struct tm values without the localtime()
3460 * semantics (and overhead) of mktime().
3463 Perl_mini_mktime(pTHX_ struct tm *ptm)
3467 int month, mday, year, jday;
3468 int odd_cent, odd_year;
3469 PERL_UNUSED_CONTEXT;
3471 PERL_ARGS_ASSERT_MINI_MKTIME;
3473 #define DAYS_PER_YEAR 365
3474 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3475 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3476 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3477 #define SECS_PER_HOUR (60*60)
3478 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3479 /* parentheses deliberately absent on these two, otherwise they don't work */
3480 #define MONTH_TO_DAYS 153/5
3481 #define DAYS_TO_MONTH 5/153
3482 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3483 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3484 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3485 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3488 * Year/day algorithm notes:
3490 * With a suitable offset for numeric value of the month, one can find
3491 * an offset into the year by considering months to have 30.6 (153/5) days,
3492 * using integer arithmetic (i.e., with truncation). To avoid too much
3493 * messing about with leap days, we consider January and February to be
3494 * the 13th and 14th month of the previous year. After that transformation,
3495 * we need the month index we use to be high by 1 from 'normal human' usage,
3496 * so the month index values we use run from 4 through 15.
3498 * Given that, and the rules for the Gregorian calendar (leap years are those
3499 * divisible by 4 unless also divisible by 100, when they must be divisible
3500 * by 400 instead), we can simply calculate the number of days since some
3501 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3502 * the days we derive from our month index, and adding in the day of the
3503 * month. The value used here is not adjusted for the actual origin which
3504 * it normally would use (1 January A.D. 1), since we're not exposing it.
3505 * We're only building the value so we can turn around and get the
3506 * normalised values for the year, month, day-of-month, and day-of-year.
3508 * For going backward, we need to bias the value we're using so that we find
3509 * the right year value. (Basically, we don't want the contribution of
3510 * March 1st to the number to apply while deriving the year). Having done
3511 * that, we 'count up' the contribution to the year number by accounting for
3512 * full quadracenturies (400-year periods) with their extra leap days, plus
3513 * the contribution from full centuries (to avoid counting in the lost leap
3514 * days), plus the contribution from full quad-years (to count in the normal
3515 * leap days), plus the leftover contribution from any non-leap years.
3516 * At this point, if we were working with an actual leap day, we'll have 0
3517 * days left over. This is also true for March 1st, however. So, we have
3518 * to special-case that result, and (earlier) keep track of the 'odd'
3519 * century and year contributions. If we got 4 extra centuries in a qcent,
3520 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3521 * Otherwise, we add back in the earlier bias we removed (the 123 from
3522 * figuring in March 1st), find the month index (integer division by 30.6),
3523 * and the remainder is the day-of-month. We then have to convert back to
3524 * 'real' months (including fixing January and February from being 14/15 in
3525 * the previous year to being in the proper year). After that, to get
3526 * tm_yday, we work with the normalised year and get a new yearday value for
3527 * January 1st, which we subtract from the yearday value we had earlier,
3528 * representing the date we've re-built. This is done from January 1
3529 * because tm_yday is 0-origin.
3531 * Since POSIX time routines are only guaranteed to work for times since the
3532 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3533 * applies Gregorian calendar rules even to dates before the 16th century
3534 * doesn't bother me. Besides, you'd need cultural context for a given
3535 * date to know whether it was Julian or Gregorian calendar, and that's
3536 * outside the scope for this routine. Since we convert back based on the
3537 * same rules we used to build the yearday, you'll only get strange results
3538 * for input which needed normalising, or for the 'odd' century years which
3539 * were leap years in the Julian calendar but not in the Gregorian one.
3540 * I can live with that.
3542 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3543 * that's still outside the scope for POSIX time manipulation, so I don't
3547 year = 1900 + ptm->tm_year;
3548 month = ptm->tm_mon;
3549 mday = ptm->tm_mday;
3555 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3556 yearday += month*MONTH_TO_DAYS + mday + jday;
3558 * Note that we don't know when leap-seconds were or will be,
3559 * so we have to trust the user if we get something which looks
3560 * like a sensible leap-second. Wild values for seconds will
3561 * be rationalised, however.
3563 if ((unsigned) ptm->tm_sec <= 60) {
3570 secs += 60 * ptm->tm_min;
3571 secs += SECS_PER_HOUR * ptm->tm_hour;
3573 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3574 /* got negative remainder, but need positive time */
3575 /* back off an extra day to compensate */
3576 yearday += (secs/SECS_PER_DAY)-1;
3577 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3580 yearday += (secs/SECS_PER_DAY);
3581 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3584 else if (secs >= SECS_PER_DAY) {
3585 yearday += (secs/SECS_PER_DAY);
3586 secs %= SECS_PER_DAY;
3588 ptm->tm_hour = secs/SECS_PER_HOUR;
3589 secs %= SECS_PER_HOUR;
3590 ptm->tm_min = secs/60;
3592 ptm->tm_sec += secs;
3593 /* done with time of day effects */
3595 * The algorithm for yearday has (so far) left it high by 428.
3596 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3597 * bias it by 123 while trying to figure out what year it
3598 * really represents. Even with this tweak, the reverse
3599 * translation fails for years before A.D. 0001.
3600 * It would still fail for Feb 29, but we catch that one below.
3602 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3603 yearday -= YEAR_ADJUST;
3604 year = (yearday / DAYS_PER_QCENT) * 400;
3605 yearday %= DAYS_PER_QCENT;
3606 odd_cent = yearday / DAYS_PER_CENT;
3607 year += odd_cent * 100;
3608 yearday %= DAYS_PER_CENT;
3609 year += (yearday / DAYS_PER_QYEAR) * 4;
3610 yearday %= DAYS_PER_QYEAR;
3611 odd_year = yearday / DAYS_PER_YEAR;
3613 yearday %= DAYS_PER_YEAR;
3614 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3619 yearday += YEAR_ADJUST; /* recover March 1st crock */
3620 month = yearday*DAYS_TO_MONTH;
3621 yearday -= month*MONTH_TO_DAYS;
3622 /* recover other leap-year adjustment */
3631 ptm->tm_year = year - 1900;
3633 ptm->tm_mday = yearday;
3634 ptm->tm_mon = month;
3638 ptm->tm_mon = month - 1;
3640 /* re-build yearday based on Jan 1 to get tm_yday */
3642 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3643 yearday += 14*MONTH_TO_DAYS + 1;
3644 ptm->tm_yday = jday - yearday;
3645 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3649 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)
3657 PERL_ARGS_ASSERT_MY_STRFTIME;
3659 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3662 mytm.tm_hour = hour;
3663 mytm.tm_mday = mday;
3665 mytm.tm_year = year;
3666 mytm.tm_wday = wday;
3667 mytm.tm_yday = yday;
3668 mytm.tm_isdst = isdst;
3670 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3671 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3676 #ifdef HAS_TM_TM_GMTOFF
3677 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3679 #ifdef HAS_TM_TM_ZONE
3680 mytm.tm_zone = mytm2.tm_zone;
3685 Newx(buf, buflen, char);
3686 len = strftime(buf, buflen, fmt, &mytm);
3688 ** The following is needed to handle to the situation where
3689 ** tmpbuf overflows. Basically we want to allocate a buffer
3690 ** and try repeatedly. The reason why it is so complicated
3691 ** is that getting a return value of 0 from strftime can indicate
3692 ** one of the following:
3693 ** 1. buffer overflowed,
3694 ** 2. illegal conversion specifier, or
3695 ** 3. the format string specifies nothing to be returned(not
3696 ** an error). This could be because format is an empty string
3697 ** or it specifies %p that yields an empty string in some locale.
3698 ** If there is a better way to make it portable, go ahead by
3701 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3704 /* Possibly buf overflowed - try again with a bigger buf */
3705 const int fmtlen = strlen(fmt);
3706 int bufsize = fmtlen + buflen;
3708 Renew(buf, bufsize, char);
3710 buflen = strftime(buf, bufsize, fmt, &mytm);
3711 if (buflen > 0 && buflen < bufsize)
3713 /* heuristic to prevent out-of-memory errors */
3714 if (bufsize > 100*fmtlen) {
3720 Renew(buf, bufsize, char);
3725 Perl_croak(aTHX_ "panic: no strftime");
3731 #define SV_CWD_RETURN_UNDEF \
3732 sv_setsv(sv, &PL_sv_undef); \
3735 #define SV_CWD_ISDOT(dp) \
3736 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3737 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3740 =head1 Miscellaneous Functions
3742 =for apidoc getcwd_sv
3744 Fill the sv with current working directory
3749 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3750 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3751 * getcwd(3) if available
3752 * Comments from the orignal:
3753 * This is a faster version of getcwd. It's also more dangerous
3754 * because you might chdir out of a directory that you can't chdir
3758 Perl_getcwd_sv(pTHX_ SV *sv)
3764 PERL_ARGS_ASSERT_GETCWD_SV;
3768 char buf[MAXPATHLEN];
3770 /* Some getcwd()s automatically allocate a buffer of the given
3771 * size from the heap if they are given a NULL buffer pointer.
3772 * The problem is that this behaviour is not portable. */
3773 if (getcwd(buf, sizeof(buf) - 1)) {
3778 sv_setsv(sv, &PL_sv_undef);
3786 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3790 SvUPGRADE(sv, SVt_PV);
3792 if (PerlLIO_lstat(".", &statbuf) < 0) {
3793 SV_CWD_RETURN_UNDEF;
3796 orig_cdev = statbuf.st_dev;
3797 orig_cino = statbuf.st_ino;
3807 if (PerlDir_chdir("..") < 0) {
3808 SV_CWD_RETURN_UNDEF;
3810 if (PerlLIO_stat(".", &statbuf) < 0) {
3811 SV_CWD_RETURN_UNDEF;
3814 cdev = statbuf.st_dev;
3815 cino = statbuf.st_ino;
3817 if (odev == cdev && oino == cino) {
3820 if (!(dir = PerlDir_open("."))) {
3821 SV_CWD_RETURN_UNDEF;
3824 while ((dp = PerlDir_read(dir)) != NULL) {
3826 namelen = dp->d_namlen;
3828 namelen = strlen(dp->d_name);
3831 if (SV_CWD_ISDOT(dp)) {
3835 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3836 SV_CWD_RETURN_UNDEF;
3839 tdev = statbuf.st_dev;
3840 tino = statbuf.st_ino;
3841 if (tino == oino && tdev == odev) {
3847 SV_CWD_RETURN_UNDEF;
3850 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3851 SV_CWD_RETURN_UNDEF;
3854 SvGROW(sv, pathlen + namelen + 1);
3858 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3861 /* prepend current directory to the front */
3863 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3864 pathlen += (namelen + 1);
3866 #ifdef VOID_CLOSEDIR
3869 if (PerlDir_close(dir) < 0) {
3870 SV_CWD_RETURN_UNDEF;
3876 SvCUR_set(sv, pathlen);
3880 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3881 SV_CWD_RETURN_UNDEF;
3884 if (PerlLIO_stat(".", &statbuf) < 0) {
3885 SV_CWD_RETURN_UNDEF;
3888 cdev = statbuf.st_dev;
3889 cino = statbuf.st_ino;
3891 if (cdev != orig_cdev || cino != orig_cino) {
3892 Perl_croak(aTHX_ "Unstable directory path, "
3893 "current directory changed unexpectedly");
3904 #define VERSION_MAX 0x7FFFFFFF
3907 =for apidoc prescan_version
3909 Validate that a given string can be parsed as a version object, but doesn't
3910 actually perform the parsing. Can use either strict or lax validation rules.
3911 Can optionally set a number of hint variables to save the parsing code
3912 some time when tokenizing.
3917 Perl_prescan_version(pTHX_ const char *s, bool strict,
3918 const char **errstr,
3919 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3920 bool qv = (sqv ? *sqv : FALSE);
3922 int saw_decimal = 0;
3926 PERL_ARGS_ASSERT_PRESCAN_VERSION;
3928 if (qv && isDIGIT(*d))
3929 goto dotted_decimal_version;
3931 if (*d == 'v') { /* explicit v-string */
3936 else { /* degenerate v-string */
3937 /* requires v1.2.3 */
3938 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3941 dotted_decimal_version:
3942 if (strict && d[0] == '0' && isDIGIT(d[1])) {
3943 /* no leading zeros allowed */
3944 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3947 while (isDIGIT(*d)) /* integer part */
3953 d++; /* decimal point */
3958 /* require v1.2.3 */
3959 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3962 goto version_prescan_finish;
3969 while (isDIGIT(*d)) { /* just keep reading */
3971 while (isDIGIT(*d)) {
3973 /* maximum 3 digits between decimal */
3974 if (strict && j > 3) {
3975 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
3980 BADVERSION(s,errstr,"Invalid version format (no underscores)");
3983 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
3988 else if (*d == '.') {
3990 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
3995 else if (!isDIGIT(*d)) {
4001 if (strict && i < 2) {
4002 /* requires v1.2.3 */
4003 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4006 } /* end if dotted-decimal */
4008 { /* decimal versions */
4009 int j = 0; /* may need this later */
4010 /* special strict case for leading '.' or '0' */
4013 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4015 if (*d == '0' && isDIGIT(d[1])) {
4016 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4020 /* and we never support negative versions */
4022 BADVERSION(s,errstr,"Invalid version format (negative version number)");
4025 /* consume all of the integer part */
4029 /* look for a fractional part */
4031 /* we found it, so consume it */
4035 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4038 BADVERSION(s,errstr,"Invalid version format (version required)");
4040 /* found just an integer */
4041 goto version_prescan_finish;
4043 else if ( d == s ) {
4044 /* didn't find either integer or period */
4045 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4047 else if (*d == '_') {
4048 /* underscore can't come after integer part */
4050 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4052 else if (isDIGIT(d[1])) {
4053 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4056 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4060 /* anything else after integer part is just invalid data */
4061 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4064 /* scan the fractional part after the decimal point*/
4066 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4067 /* strict or lax-but-not-the-end */
4068 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4071 while (isDIGIT(*d)) {
4073 if (*d == '.' && isDIGIT(d[-1])) {
4075 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4078 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4080 d = (char *)s; /* start all over again */
4082 goto dotted_decimal_version;
4086 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4089 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4091 if ( ! isDIGIT(d[1]) ) {
4092 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4101 version_prescan_finish:
4105 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4106 /* trailing non-numeric data */
4107 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4115 *ssaw_decimal = saw_decimal;
4122 =for apidoc scan_version
4124 Returns a pointer to the next character after the parsed
4125 version string, as well as upgrading the passed in SV to
4128 Function must be called with an already existing SV like
4131 s = scan_version(s, SV *sv, bool qv);
4133 Performs some preprocessing to the string to ensure that
4134 it has the correct characteristics of a version. Flags the
4135 object if it contains an underscore (which denotes this
4136 is an alpha version). The boolean qv denotes that the version
4137 should be interpreted as if it had multiple decimals, even if
4144 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4146 const char *start = s;
4149 const char *errstr = NULL;
4150 int saw_decimal = 0;
4157 PERL_ARGS_ASSERT_SCAN_VERSION;
4159 while (isSPACE(*s)) /* leading whitespace is OK */
4162 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4164 /* "undef" is a special case and not an error */
4165 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4167 Perl_croak(aTHX_ "%s", errstr);
4176 /* Now that we are through the prescan, start creating the object */
4178 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4179 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4181 #ifndef NODEFAULT_SHAREKEYS
4182 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4186 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4188 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4189 if ( !qv && width < 3 )
4190 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4192 while (isDIGIT(*pos))
4194 if (!isALPHA(*pos)) {
4200 /* this is atoi() that delimits on underscores */
4201 const char *end = pos;
4205 /* the following if() will only be true after the decimal
4206 * point of a version originally created with a bare
4207 * floating point number, i.e. not quoted in any way
4209 if ( !qv && s > start && saw_decimal == 1 ) {
4213 rev += (*s - '0') * mult;
4215 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4216 || (PERL_ABS(rev) > VERSION_MAX )) {
4217 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4218 "Integer overflow in version %d",VERSION_MAX);
4229 while (--end >= s) {
4231 rev += (*end - '0') * mult;
4233 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4234 || (PERL_ABS(rev) > VERSION_MAX )) {
4235 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4236 "Integer overflow in version");
4245 /* Append revision */
4246 av_push(av, newSViv(rev));
4251 else if ( *pos == '.' )
4253 else if ( *pos == '_' && isDIGIT(pos[1]) )
4255 else if ( *pos == ',' && isDIGIT(pos[1]) )
4257 else if ( isDIGIT(*pos) )
4264 while ( isDIGIT(*pos) )
4269 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4277 if ( qv ) { /* quoted versions always get at least three terms*/
4278 SSize_t len = av_len(av);
4279 /* This for loop appears to trigger a compiler bug on OS X, as it
4280 loops infinitely. Yes, len is negative. No, it makes no sense.
4281 Compiler in question is:
4282 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4283 for ( len = 2 - len; len > 0; len-- )
4284 av_push(MUTABLE_AV(sv), newSViv(0));
4288 av_push(av, newSViv(0));
4291 /* need to save off the current version string for later */
4293 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4294 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4295 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4297 else if ( s > start ) {
4298 SV * orig = newSVpvn(start,s-start);
4299 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4300 /* need to insert a v to be consistent */
4301 sv_insert(orig, 0, 0, "v", 1);
4303 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4306 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4307 av_push(av, newSViv(0));
4310 /* And finally, store the AV in the hash */
4311 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4313 /* fix RT#19517 - special case 'undef' as string */
4314 if ( *s == 'u' && strEQ(s,"undef") ) {
4322 =for apidoc new_version
4324 Returns a new version object based on the passed in SV:
4326 SV *sv = new_version(SV *ver);
4328 Does not alter the passed in ver SV. See "upg_version" if you
4329 want to upgrade the SV.
4335 Perl_new_version(pTHX_ SV *ver)
4338 SV * const rv = newSV(0);
4339 PERL_ARGS_ASSERT_NEW_VERSION;
4340 if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4341 /* can just copy directly */
4344 AV * const av = newAV();
4346 /* This will get reblessed later if a derived class*/
4347 SV * const hv = newSVrv(rv, "version");
4348 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4349 #ifndef NODEFAULT_SHAREKEYS
4350 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4356 /* Begin copying all of the elements */
4357 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4358 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4360 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4361 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4363 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4365 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4366 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4369 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4371 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4372 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4375 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4376 /* This will get reblessed later if a derived class*/
4377 for ( key = 0; key <= av_len(sav); key++ )
4379 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4380 av_push(av, newSViv(rev));
4383 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4388 const MAGIC* const mg = SvVSTRING_mg(ver);
4389 if ( mg ) { /* already a v-string */
4390 const STRLEN len = mg->mg_len;
4391 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4392 sv_setpvn(rv,version,len);
4393 /* this is for consistency with the pure Perl class */
4394 if ( isDIGIT(*version) )
4395 sv_insert(rv, 0, 0, "v", 1);
4400 sv_setsv(rv,ver); /* make a duplicate */
4405 return upg_version(rv, FALSE);
4409 =for apidoc upg_version
4411 In-place upgrade of the supplied SV to a version object.
4413 SV *sv = upg_version(SV *sv, bool qv);
4415 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4416 to force this SV to be interpreted as an "extended" version.
4422 Perl_upg_version(pTHX_ SV *ver, bool qv)
4424 const char *version, *s;
4429 PERL_ARGS_ASSERT_UPG_VERSION;
4431 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4435 /* may get too much accuracy */
4437 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4439 #ifdef USE_LOCALE_NUMERIC
4441 if (! PL_numeric_standard) {
4442 loc = savepv(setlocale(LC_NUMERIC, NULL));
4443 setlocale(LC_NUMERIC, "C");
4447 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4448 buf = SvPV(sv, len);
4451 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4454 #ifdef USE_LOCALE_NUMERIC
4456 setlocale(LC_NUMERIC, loc);
4460 while (buf[len-1] == '0' && len > 0) len--;
4461 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4462 version = savepvn(buf, len);
4466 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4467 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4471 else /* must be a string or something like a string */
4474 version = savepv(SvPV(ver,len));
4476 # if PERL_VERSION > 5
4477 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4478 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4479 /* may be a v-string */
4480 char *testv = (char *)version;
4482 for (tlen=0; tlen < len; tlen++, testv++) {
4483 /* if one of the characters is non-text assume v-string */
4484 if (testv[0] < ' ') {
4485 SV * const nsv = sv_newmortal();
4488 int saw_decimal = 0;
4489 sv_setpvf(nsv,"v%vd",ver);
4490 pos = nver = savepv(SvPV_nolen(nsv));
4492 /* scan the resulting formatted string */
4493 pos++; /* skip the leading 'v' */
4494 while ( *pos == '.' || isDIGIT(*pos) ) {
4500 /* is definitely a v-string */
4501 if ( saw_decimal >= 2 ) {
4513 s = scan_version(version, ver, qv);
4515 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4516 "Version string '%s' contains invalid data; "
4517 "ignoring: '%s'", version, s);
4525 Validates that the SV contains valid internal structure for a version object.
4526 It may be passed either the version object (RV) or the hash itself (HV). If
4527 the structure is valid, it returns the HV. If the structure is invalid,
4530 SV *hv = vverify(sv);
4532 Note that it only confirms the bare minimum structure (so as not to get
4533 confused by derived classes which may contain additional hash entries):
4537 =item * The SV is an HV or a reference to an HV
4539 =item * The hash contains a "version" key
4541 =item * The "version" key has a reference to an AV as its value
4549 Perl_vverify(pTHX_ SV *vs)
4553 PERL_ARGS_ASSERT_VVERIFY;
4558 /* see if the appropriate elements exist */
4559 if ( SvTYPE(vs) == SVt_PVHV
4560 && hv_exists(MUTABLE_HV(vs), "version", 7)
4561 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4562 && SvTYPE(sv) == SVt_PVAV )
4571 Accepts a version object and returns the normalized floating
4572 point representation. Call like:
4576 NOTE: you can pass either the object directly or the SV
4577 contained within the RV.
4579 The SV returned has a refcount of 1.
4585 Perl_vnumify(pTHX_ SV *vs)
4594 PERL_ARGS_ASSERT_VNUMIFY;
4596 /* extract the HV from the object */
4599 Perl_croak(aTHX_ "Invalid version object");
4601 /* see if various flags exist */
4602 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4604 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4605 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4610 /* attempt to retrieve the version array */
4611 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4612 return newSVpvs("0");
4618 return newSVpvs("0");
4621 digit = SvIV(*av_fetch(av, 0, 0));
4622 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4623 for ( i = 1 ; i < len ; i++ )
4625 digit = SvIV(*av_fetch(av, i, 0));
4627 const int denom = (width == 2 ? 10 : 100);
4628 const div_t term = div((int)PERL_ABS(digit),denom);
4629 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4632 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4638 digit = SvIV(*av_fetch(av, len, 0));
4639 if ( alpha && width == 3 ) /* alpha version */
4641 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4645 sv_catpvs(sv, "000");
4653 Accepts a version object and returns the normalized string
4654 representation. Call like:
4658 NOTE: you can pass either the object directly or the SV
4659 contained within the RV.
4661 The SV returned has a refcount of 1.
4667 Perl_vnormal(pTHX_ SV *vs)
4674 PERL_ARGS_ASSERT_VNORMAL;
4676 /* extract the HV from the object */
4679 Perl_croak(aTHX_ "Invalid version object");
4681 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4683 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4688 return newSVpvs("");
4690 digit = SvIV(*av_fetch(av, 0, 0));
4691 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4692 for ( i = 1 ; i < len ; i++ ) {
4693 digit = SvIV(*av_fetch(av, i, 0));
4694 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4699 /* handle last digit specially */
4700 digit = SvIV(*av_fetch(av, len, 0));
4702 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4704 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4707 if ( len <= 2 ) { /* short version, must be at least three */
4708 for ( len = 2 - len; len != 0; len-- )
4715 =for apidoc vstringify
4717 In order to maintain maximum compatibility with earlier versions
4718 of Perl, this function will return either the floating point
4719 notation or the multiple dotted notation, depending on whether
4720 the original version contained 1 or more dots, respectively.
4722 The SV returned has a refcount of 1.
4728 Perl_vstringify(pTHX_ SV *vs)
4730 PERL_ARGS_ASSERT_VSTRINGIFY;
4732 /* extract the HV from the object */
4735 Perl_croak(aTHX_ "Invalid version object");
4737 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
4739 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4743 return &PL_sv_undef;
4746 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4756 Version object aware cmp. Both operands must already have been
4757 converted into version objects.
4763 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4767 bool lalpha = FALSE;
4768 bool ralpha = FALSE;
4773 PERL_ARGS_ASSERT_VCMP;
4775 /* extract the HVs from the objects */
4778 if ( ! ( lhv && rhv ) )
4779 Perl_croak(aTHX_ "Invalid version object");
4781 /* get the left hand term */
4782 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4783 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4786 /* and the right hand term */
4787 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4788 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4796 while ( i <= m && retval == 0 )
4798 left = SvIV(*av_fetch(lav,i,0));
4799 right = SvIV(*av_fetch(rav,i,0));
4807 /* tiebreaker for alpha with identical terms */
4808 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4810 if ( lalpha && !ralpha )
4814 else if ( ralpha && !lalpha)
4820 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4824 while ( i <= r && retval == 0 )
4826 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4827 retval = -1; /* not a match after all */
4833 while ( i <= l && retval == 0 )
4835 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4836 retval = +1; /* not a match after all */
4844 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4845 # define EMULATE_SOCKETPAIR_UDP
4848 #ifdef EMULATE_SOCKETPAIR_UDP
4850 S_socketpair_udp (int fd[2]) {
4852 /* Fake a datagram socketpair using UDP to localhost. */
4853 int sockets[2] = {-1, -1};
4854 struct sockaddr_in addresses[2];
4856 Sock_size_t size = sizeof(struct sockaddr_in);
4857 unsigned short port;
4860 memset(&addresses, 0, sizeof(addresses));
4863 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4864 if (sockets[i] == -1)
4865 goto tidy_up_and_fail;
4867 addresses[i].sin_family = AF_INET;
4868 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4869 addresses[i].sin_port = 0; /* kernel choses port. */
4870 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4871 sizeof(struct sockaddr_in)) == -1)
4872 goto tidy_up_and_fail;
4875 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4876 for each connect the other socket to it. */
4879 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4881 goto tidy_up_and_fail;
4882 if (size != sizeof(struct sockaddr_in))
4883 goto abort_tidy_up_and_fail;
4884 /* !1 is 0, !0 is 1 */
4885 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4886 sizeof(struct sockaddr_in)) == -1)
4887 goto tidy_up_and_fail;
4890 /* Now we have 2 sockets connected to each other. I don't trust some other
4891 process not to have already sent a packet to us (by random) so send
4892 a packet from each to the other. */
4895 /* I'm going to send my own port number. As a short.
4896 (Who knows if someone somewhere has sin_port as a bitfield and needs
4897 this routine. (I'm assuming crays have socketpair)) */
4898 port = addresses[i].sin_port;
4899 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4900 if (got != sizeof(port)) {
4902 goto tidy_up_and_fail;
4903 goto abort_tidy_up_and_fail;
4907 /* Packets sent. I don't trust them to have arrived though.
4908 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4909 connect to localhost will use a second kernel thread. In 2.6 the
4910 first thread running the connect() returns before the second completes,
4911 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4912 returns 0. Poor programs have tripped up. One poor program's authors'
4913 had a 50-1 reverse stock split. Not sure how connected these were.)
4914 So I don't trust someone not to have an unpredictable UDP stack.
4918 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4919 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4923 FD_SET((unsigned int)sockets[0], &rset);
4924 FD_SET((unsigned int)sockets[1], &rset);
4926 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4927 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4928 || !FD_ISSET(sockets[1], &rset)) {
4929 /* I hope this is portable and appropriate. */
4931 goto tidy_up_and_fail;
4932 goto abort_tidy_up_and_fail;
4936 /* And the paranoia department even now doesn't trust it to have arrive
4937 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4939 struct sockaddr_in readfrom;
4940 unsigned short buffer[2];
4945 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4946 sizeof(buffer), MSG_DONTWAIT,
4947 (struct sockaddr *) &readfrom, &size);
4949 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4951 (struct sockaddr *) &readfrom, &size);
4955 goto tidy_up_and_fail;
4956 if (got != sizeof(port)
4957 || size != sizeof(struct sockaddr_in)
4958 /* Check other socket sent us its port. */
4959 || buffer[0] != (unsigned short) addresses[!i].sin_port
4960 /* Check kernel says we got the datagram from that socket */
4961 || readfrom.sin_family != addresses[!i].sin_family
4962 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4963 || readfrom.sin_port != addresses[!i].sin_port)
4964 goto abort_tidy_up_and_fail;
4967 /* My caller (my_socketpair) has validated that this is non-NULL */
4970 /* I hereby declare this connection open. May God bless all who cross
4974 abort_tidy_up_and_fail:
4975 errno = ECONNABORTED;
4979 if (sockets[0] != -1)
4980 PerlLIO_close(sockets[0]);
4981 if (sockets[1] != -1)
4982 PerlLIO_close(sockets[1]);
4987 #endif /* EMULATE_SOCKETPAIR_UDP */
4989 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4991 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4992 /* Stevens says that family must be AF_LOCAL, protocol 0.
4993 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4998 struct sockaddr_in listen_addr;
4999 struct sockaddr_in connect_addr;
5004 || family != AF_UNIX
5007 errno = EAFNOSUPPORT;
5015 #ifdef EMULATE_SOCKETPAIR_UDP
5016 if (type == SOCK_DGRAM)
5017 return S_socketpair_udp(fd);
5020 aTHXa(PERL_GET_THX);
5021 listener = PerlSock_socket(AF_INET, type, 0);
5024 memset(&listen_addr, 0, sizeof(listen_addr));
5025 listen_addr.sin_family = AF_INET;
5026 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5027 listen_addr.sin_port = 0; /* kernel choses port. */
5028 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5029 sizeof(listen_addr)) == -1)
5030 goto tidy_up_and_fail;
5031 if (PerlSock_listen(listener, 1) == -1)
5032 goto tidy_up_and_fail;
5034 connector = PerlSock_socket(AF_INET, type, 0);
5035 if (connector == -1)
5036 goto tidy_up_and_fail;
5037 /* We want to find out the port number to connect to. */
5038 size = sizeof(connect_addr);
5039 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5041 goto tidy_up_and_fail;
5042 if (size != sizeof(connect_addr))
5043 goto abort_tidy_up_and_fail;
5044 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5045 sizeof(connect_addr)) == -1)
5046 goto tidy_up_and_fail;
5048 size = sizeof(listen_addr);
5049 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5052 goto tidy_up_and_fail;
5053 if (size != sizeof(listen_addr))
5054 goto abort_tidy_up_and_fail;
5055 PerlLIO_close(listener);
5056 /* Now check we are talking to ourself by matching port and host on the
5058 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5060 goto tidy_up_and_fail;
5061 if (size != sizeof(connect_addr)
5062 || listen_addr.sin_family != connect_addr.sin_family
5063 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5064 || listen_addr.sin_port != connect_addr.sin_port) {
5065 goto abort_tidy_up_and_fail;
5071 abort_tidy_up_and_fail:
5073 errno = ECONNABORTED; /* This would be the standard thing to do. */
5075 # ifdef ECONNREFUSED
5076 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5078 errno = ETIMEDOUT; /* Desperation time. */
5085 PerlLIO_close(listener);
5086 if (connector != -1)
5087 PerlLIO_close(connector);
5089 PerlLIO_close(acceptor);
5095 /* In any case have a stub so that there's code corresponding
5096 * to the my_socketpair in embed.fnc. */
5098 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5099 #ifdef HAS_SOCKETPAIR
5100 return socketpair(family, type, protocol, fd);
5109 =for apidoc sv_nosharing
5111 Dummy routine which "shares" an SV when there is no sharing module present.
5112 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5113 Exists to avoid test for a NULL function pointer and because it could
5114 potentially warn under some level of strict-ness.
5120 Perl_sv_nosharing(pTHX_ SV *sv)
5122 PERL_UNUSED_CONTEXT;
5123 PERL_UNUSED_ARG(sv);
5128 =for apidoc sv_destroyable
5130 Dummy routine which reports that object can be destroyed when there is no
5131 sharing module present. It ignores its single SV argument, and returns
5132 'true'. Exists to avoid test for a NULL function pointer and because it
5133 could potentially warn under some level of strict-ness.
5139 Perl_sv_destroyable(pTHX_ SV *sv)
5141 PERL_UNUSED_CONTEXT;
5142 PERL_UNUSED_ARG(sv);
5147 Perl_parse_unicode_opts(pTHX_ const char **popt)
5149 const char *p = *popt;
5152 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5156 opt = (U32) atoi(p);
5159 if (*p && *p != '\n' && *p != '\r') {
5160 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5162 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5168 case PERL_UNICODE_STDIN:
5169 opt |= PERL_UNICODE_STDIN_FLAG; break;
5170 case PERL_UNICODE_STDOUT:
5171 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5172 case PERL_UNICODE_STDERR:
5173 opt |= PERL_UNICODE_STDERR_FLAG; break;
5174 case PERL_UNICODE_STD:
5175 opt |= PERL_UNICODE_STD_FLAG; break;
5176 case PERL_UNICODE_IN:
5177 opt |= PERL_UNICODE_IN_FLAG; break;
5178 case PERL_UNICODE_OUT:
5179 opt |= PERL_UNICODE_OUT_FLAG; break;
5180 case PERL_UNICODE_INOUT:
5181 opt |= PERL_UNICODE_INOUT_FLAG; break;
5182 case PERL_UNICODE_LOCALE:
5183 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5184 case PERL_UNICODE_ARGV:
5185 opt |= PERL_UNICODE_ARGV_FLAG; break;
5186 case PERL_UNICODE_UTF8CACHEASSERT:
5187 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5189 if (*p != '\n' && *p != '\r') {
5190 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5193 "Unknown Unicode option letter '%c'", *p);
5200 opt = PERL_UNICODE_DEFAULT_FLAGS;
5202 the_end_of_the_opts_parser:
5204 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5205 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5206 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5214 # include <starlet.h>
5222 * This is really just a quick hack which grabs various garbage
5223 * values. It really should be a real hash algorithm which
5224 * spreads the effect of every input bit onto every output bit,
5225 * if someone who knows about such things would bother to write it.
5226 * Might be a good idea to add that function to CORE as well.
5227 * No numbers below come from careful analysis or anything here,
5228 * except they are primes and SEED_C1 > 1E6 to get a full-width
5229 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5230 * probably be bigger too.
5233 # define SEED_C1 1000003
5234 #define SEED_C4 73819
5236 # define SEED_C1 25747
5237 #define SEED_C4 20639
5241 #define SEED_C5 26107
5243 #ifndef PERL_NO_DEV_RANDOM
5248 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5249 * in 100-ns units, typically incremented ever 10 ms. */
5250 unsigned int when[2];
5252 # ifdef HAS_GETTIMEOFDAY
5253 struct timeval when;
5259 /* This test is an escape hatch, this symbol isn't set by Configure. */
5260 #ifndef PERL_NO_DEV_RANDOM
5261 #ifndef PERL_RANDOM_DEVICE
5262 /* /dev/random isn't used by default because reads from it will block
5263 * if there isn't enough entropy available. You can compile with
5264 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5265 * is enough real entropy to fill the seed. */
5266 # define PERL_RANDOM_DEVICE "/dev/urandom"
5268 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5270 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5279 _ckvmssts(sys$gettim(when));
5280 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5282 # ifdef HAS_GETTIMEOFDAY
5283 PerlProc_gettimeofday(&when,NULL);
5284 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5287 u = (U32)SEED_C1 * when;
5290 u += SEED_C3 * (U32)PerlProc_getpid();
5291 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5292 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5293 u += SEED_C5 * (U32)PTR2UV(&when);
5299 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
5305 PERL_ARGS_ASSERT_GET_HASH_SEED;
5307 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
5310 #ifndef USE_HASH_SEED_EXPLICIT
5312 /* ignore leading spaces */
5313 while (isSPACE(*env_pv))
5315 #ifdef USE_PERL_PERTURB_KEYS
5316 /* if they set it to "0" we disable key traversal randomization completely */
5317 if (strEQ(env_pv,"0")) {
5318 PL_hash_rand_bits_enabled= 0;
5320 /* otherwise switch to deterministic mode */
5321 PL_hash_rand_bits_enabled= 2;
5324 /* ignore a leading 0x... if it is there */
5325 if (env_pv[0] == '0' && env_pv[1] == 'x')
5328 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
5329 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
5330 if ( isXDIGIT(*env_pv)) {
5331 seed_buffer[i] |= READ_XDIGIT(env_pv);
5334 while (isSPACE(*env_pv))
5337 if (*env_pv && !isXDIGIT(*env_pv)) {
5338 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
5340 /* should we check for unparsed crap? */
5341 /* should we warn about unused hex? */
5342 /* should we warn about insufficient hex? */
5347 (void)seedDrand01((Rand_seed_t)seed());
5349 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
5350 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
5353 #ifdef USE_PERL_PERTURB_KEYS
5354 { /* initialize PL_hash_rand_bits from the hash seed.
5355 * This value is highly volatile, it is updated every
5356 * hash insert, and is used as part of hash bucket chain
5357 * randomization and hash iterator randomization. */
5358 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
5359 for( i = 0; i < sizeof(UV) ; i++ ) {
5360 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
5361 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
5364 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
5366 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
5367 PL_hash_rand_bits_enabled= 0;
5368 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
5369 PL_hash_rand_bits_enabled= 1;
5370 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
5371 PL_hash_rand_bits_enabled= 2;
5373 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
5379 #ifdef PERL_GLOBAL_STRUCT
5381 #define PERL_GLOBAL_STRUCT_INIT
5382 #include "opcode.h" /* the ppaddr and check */
5385 Perl_init_global_struct(pTHX)
5387 struct perl_vars *plvarsp = NULL;
5388 # ifdef PERL_GLOBAL_STRUCT
5389 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5390 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5391 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5392 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5393 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5397 plvarsp = PL_VarsPtr;
5398 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5403 # define PERLVAR(prefix,var,type) /**/
5404 # define PERLVARA(prefix,var,n,type) /**/
5405 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5406 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5407 # include "perlvars.h"
5412 # ifdef PERL_GLOBAL_STRUCT
5415 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5416 if (!plvarsp->Gppaddr)
5420 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5421 if (!plvarsp->Gcheck)
5423 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5424 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5426 # ifdef PERL_SET_VARS
5427 PERL_SET_VARS(plvarsp);
5429 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5430 plvarsp->Gsv_placeholder.sv_flags = 0;
5431 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
5433 # undef PERL_GLOBAL_STRUCT_INIT
5438 #endif /* PERL_GLOBAL_STRUCT */
5440 #ifdef PERL_GLOBAL_STRUCT
5443 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5445 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5446 # ifdef PERL_GLOBAL_STRUCT
5447 # ifdef PERL_UNSET_VARS
5448 PERL_UNSET_VARS(plvarsp);
5450 free(plvarsp->Gppaddr);
5451 free(plvarsp->Gcheck);
5452 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5458 #endif /* PERL_GLOBAL_STRUCT */
5462 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5463 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5464 * given, and you supply your own implementation.
5466 * The default implementation reads a single env var, PERL_MEM_LOG,
5467 * expecting one or more of the following:
5469 * \d+ - fd fd to write to : must be 1st (atoi)
5470 * 'm' - memlog was PERL_MEM_LOG=1
5471 * 's' - svlog was PERL_SV_LOG=1
5472 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5474 * This makes the logger controllable enough that it can reasonably be
5475 * added to the system perl.
5478 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5479 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5481 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5483 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5484 * writes to. In the default logger, this is settable at runtime.
5486 #ifndef PERL_MEM_LOG_FD
5487 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5490 #ifndef PERL_MEM_LOG_NOIMPL
5492 # ifdef DEBUG_LEAKING_SCALARS
5493 # define SV_LOG_SERIAL_FMT " [%lu]"
5494 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5496 # define SV_LOG_SERIAL_FMT
5497 # define _SV_LOG_SERIAL_ARG(sv)
5501 S_mem_log_common(enum mem_log_type mlt, const UV n,
5502 const UV typesize, const char *type_name, const SV *sv,
5503 Malloc_t oldalloc, Malloc_t newalloc,
5504 const char *filename, const int linenumber,
5505 const char *funcname)
5509 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5511 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5514 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5516 /* We can't use SVs or PerlIO for obvious reasons,
5517 * so we'll use stdio and low-level IO instead. */
5518 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5520 # ifdef HAS_GETTIMEOFDAY
5521 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5522 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5524 gettimeofday(&tv, 0);
5526 # define MEM_LOG_TIME_FMT "%10d: "
5527 # define MEM_LOG_TIME_ARG (int)when
5531 /* If there are other OS specific ways of hires time than
5532 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5533 * probably that they would be used to fill in the struct
5537 int fd = atoi(pmlenv);
5539 fd = PERL_MEM_LOG_FD;
5541 if (strchr(pmlenv, 't')) {
5542 len = my_snprintf(buf, sizeof(buf),
5543 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5544 PerlLIO_write(fd, buf, len);
5548 len = my_snprintf(buf, sizeof(buf),
5549 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5550 " %s = %"IVdf": %"UVxf"\n",
5551 filename, linenumber, funcname, n, typesize,
5552 type_name, n * typesize, PTR2UV(newalloc));
5555 len = my_snprintf(buf, sizeof(buf),
5556 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5557 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5558 filename, linenumber, funcname, n, typesize,
5559 type_name, n * typesize, PTR2UV(oldalloc),
5563 len = my_snprintf(buf, sizeof(buf),
5564 "free: %s:%d:%s: %"UVxf"\n",
5565 filename, linenumber, funcname,
5570 len = my_snprintf(buf, sizeof(buf),
5571 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5572 mlt == MLT_NEW_SV ? "new" : "del",
5573 filename, linenumber, funcname,
5574 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5579 PerlLIO_write(fd, buf, len);
5583 #endif /* !PERL_MEM_LOG_NOIMPL */
5585 #ifndef PERL_MEM_LOG_NOIMPL
5587 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5588 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5590 /* this is suboptimal, but bug compatible. User is providing their
5591 own implementation, but is getting these functions anyway, and they
5592 do nothing. But _NOIMPL users should be able to cope or fix */
5594 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5595 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5599 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5601 const char *filename, const int linenumber,
5602 const char *funcname)
5604 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5605 NULL, NULL, newalloc,
5606 filename, linenumber, funcname);
5611 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5612 Malloc_t oldalloc, Malloc_t newalloc,
5613 const char *filename, const int linenumber,
5614 const char *funcname)
5616 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5617 NULL, oldalloc, newalloc,
5618 filename, linenumber, funcname);
5623 Perl_mem_log_free(Malloc_t oldalloc,
5624 const char *filename, const int linenumber,
5625 const char *funcname)
5627 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5628 filename, linenumber, funcname);
5633 Perl_mem_log_new_sv(const SV *sv,
5634 const char *filename, const int linenumber,
5635 const char *funcname)
5637 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5638 filename, linenumber, funcname);
5642 Perl_mem_log_del_sv(const SV *sv,
5643 const char *filename, const int linenumber,
5644 const char *funcname)
5646 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5647 filename, linenumber, funcname);
5650 #endif /* PERL_MEM_LOG */
5653 =for apidoc my_sprintf
5655 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5656 the length of the string written to the buffer. Only rare pre-ANSI systems
5657 need the wrapper function - usually this is a direct call to C<sprintf>.
5661 #ifndef SPRINTF_RETURNS_STRLEN
5663 Perl_my_sprintf(char *buffer, const char* pat, ...)
5666 PERL_ARGS_ASSERT_MY_SPRINTF;
5667 va_start(args, pat);
5668 vsprintf(buffer, pat, args);
5670 return strlen(buffer);
5675 =for apidoc my_snprintf
5677 The C library C<snprintf> functionality, if available and
5678 standards-compliant (uses C<vsnprintf>, actually). However, if the
5679 C<vsnprintf> is not available, will unfortunately use the unsafe
5680 C<vsprintf> which can overrun the buffer (there is an overrun check,
5681 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5682 getting C<vsnprintf>.
5687 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5691 PERL_ARGS_ASSERT_MY_SNPRINTF;
5692 va_start(ap, format);
5693 #ifdef HAS_VSNPRINTF
5694 retval = vsnprintf(buffer, len, format, ap);
5696 retval = vsprintf(buffer, format, ap);
5699 /* vsprintf() shows failure with < 0 */
5701 #ifdef HAS_VSNPRINTF
5702 /* vsnprintf() shows failure with >= len */
5704 (len > 0 && (Size_t)retval >= len)
5707 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5712 =for apidoc my_vsnprintf
5714 The C library C<vsnprintf> if available and standards-compliant.
5715 However, if if the C<vsnprintf> is not available, will unfortunately
5716 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5717 overrun check, but that may be too late). Consider using
5718 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5723 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5729 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5731 Perl_va_copy(ap, apc);
5732 # ifdef HAS_VSNPRINTF
5733 retval = vsnprintf(buffer, len, format, apc);
5735 retval = vsprintf(buffer, format, apc);
5738 # ifdef HAS_VSNPRINTF
5739 retval = vsnprintf(buffer, len, format, ap);
5741 retval = vsprintf(buffer, format, ap);
5743 #endif /* #ifdef NEED_VA_COPY */
5744 /* vsprintf() shows failure with < 0 */
5746 #ifdef HAS_VSNPRINTF
5747 /* vsnprintf() shows failure with >= len */
5749 (len > 0 && (Size_t)retval >= len)
5752 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5757 Perl_my_clearenv(pTHX)
5760 #if ! defined(PERL_MICRO)
5761 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5763 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5764 # if defined(USE_ENVIRON_ARRAY)
5765 # if defined(USE_ITHREADS)
5766 /* only the parent thread can clobber the process environment */
5767 if (PL_curinterp == aTHX)
5768 # endif /* USE_ITHREADS */
5770 # if ! defined(PERL_USE_SAFE_PUTENV)
5771 if ( !PL_use_safe_putenv) {
5773 if (environ == PL_origenviron)
5774 environ = (char**)safesysmalloc(sizeof(char*));
5776 for (i = 0; environ[i]; i++)
5777 (void)safesysfree(environ[i]);
5780 # else /* PERL_USE_SAFE_PUTENV */
5781 # if defined(HAS_CLEARENV)
5783 # elif defined(HAS_UNSETENV)
5784 int bsiz = 80; /* Most envvar names will be shorter than this. */
5785 char *buf = (char*)safesysmalloc(bsiz);
5786 while (*environ != NULL) {
5787 char *e = strchr(*environ, '=');
5788 int l = e ? e - *environ : (int)strlen(*environ);
5790 (void)safesysfree(buf);
5791 bsiz = l + 1; /* + 1 for the \0. */
5792 buf = (char*)safesysmalloc(bsiz);
5794 memcpy(buf, *environ, l);
5796 (void)unsetenv(buf);
5798 (void)safesysfree(buf);
5799 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5800 /* Just null environ and accept the leakage. */
5802 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5803 # endif /* ! PERL_USE_SAFE_PUTENV */
5805 # endif /* USE_ENVIRON_ARRAY */
5806 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5807 #endif /* PERL_MICRO */
5810 #ifdef PERL_IMPLICIT_CONTEXT
5812 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5813 the global PL_my_cxt_index is incremented, and that value is assigned to
5814 that module's static my_cxt_index (who's address is passed as an arg).
5815 Then, for each interpreter this function is called for, it makes sure a
5816 void* slot is available to hang the static data off, by allocating or
5817 extending the interpreter's PL_my_cxt_list array */
5819 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5821 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5825 PERL_ARGS_ASSERT_MY_CXT_INIT;
5827 /* this module hasn't been allocated an index yet */
5828 #if defined(USE_ITHREADS)
5829 MUTEX_LOCK(&PL_my_ctx_mutex);
5831 *index = PL_my_cxt_index++;
5832 #if defined(USE_ITHREADS)
5833 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5837 /* make sure the array is big enough */
5838 if (PL_my_cxt_size <= *index) {
5839 if (PL_my_cxt_size) {
5840 while (PL_my_cxt_size <= *index)
5841 PL_my_cxt_size *= 2;
5842 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5845 PL_my_cxt_size = 16;
5846 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5849 /* newSV() allocates one more than needed */
5850 p = (void*)SvPVX(newSV(size-1));
5851 PL_my_cxt_list[*index] = p;
5852 Zero(p, size, char);
5856 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5859 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5864 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5866 for (index = 0; index < PL_my_cxt_index; index++) {
5867 const char *key = PL_my_cxt_keys[index];
5868 /* try direct pointer compare first - there are chances to success,
5869 * and it's much faster.
5871 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5878 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5884 PERL_ARGS_ASSERT_MY_CXT_INIT;
5886 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5888 /* this module hasn't been allocated an index yet */
5889 #if defined(USE_ITHREADS)
5890 MUTEX_LOCK(&PL_my_ctx_mutex);
5892 index = PL_my_cxt_index++;
5893 #if defined(USE_ITHREADS)
5894 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5898 /* make sure the array is big enough */
5899 if (PL_my_cxt_size <= index) {
5900 int old_size = PL_my_cxt_size;
5902 if (PL_my_cxt_size) {
5903 while (PL_my_cxt_size <= index)
5904 PL_my_cxt_size *= 2;
5905 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5906 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5909 PL_my_cxt_size = 16;
5910 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5911 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5913 for (i = old_size; i < PL_my_cxt_size; i++) {
5914 PL_my_cxt_keys[i] = 0;
5915 PL_my_cxt_list[i] = 0;
5918 PL_my_cxt_keys[index] = my_cxt_key;
5919 /* newSV() allocates one more than needed */
5920 p = (void*)SvPVX(newSV(size-1));
5921 PL_my_cxt_list[index] = p;
5922 Zero(p, size, char);
5925 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5926 #endif /* PERL_IMPLICIT_CONTEXT */
5929 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5933 const char *vn = NULL;
5934 SV *const module = PL_stack_base[ax];
5936 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5938 if (items >= 2) /* version supplied as bootstrap arg */
5939 sv = PL_stack_base[ax + 1];
5941 /* XXX GV_ADDWARN */
5943 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5944 if (!sv || !SvOK(sv)) {
5946 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5950 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5951 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5952 ? sv : sv_2mortal(new_version(sv));
5953 xssv = upg_version(xssv, 0);
5954 if ( vcmp(pmsv,xssv) ) {
5955 SV *string = vstringify(xssv);
5956 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5957 " does not match ", module, string);
5959 SvREFCNT_dec(string);
5960 string = vstringify(pmsv);
5963 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5966 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
5968 SvREFCNT_dec(string);
5970 Perl_sv_2mortal(aTHX_ xpt);
5971 Perl_croak_sv(aTHX_ xpt);
5977 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
5981 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
5984 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
5986 /* This might croak */
5987 compver = upg_version(compver, 0);
5988 /* This should never croak */
5989 runver = new_version(PL_apiversion);
5990 if (vcmp(compver, runver)) {
5991 SV *compver_string = vstringify(compver);
5992 SV *runver_string = vstringify(runver);
5993 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
5994 " of %"SVf" does not match %"SVf,
5995 compver_string, module, runver_string);
5996 Perl_sv_2mortal(aTHX_ xpt);
5998 SvREFCNT_dec(compver_string);
5999 SvREFCNT_dec(runver_string);
6001 SvREFCNT_dec(runver);
6003 Perl_croak_sv(aTHX_ xpt);
6007 =for apidoc my_strlcat
6009 The C library C<strlcat> if available, or a Perl implementation of it.
6010 This operates on C NUL-terminated strings.
6012 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
6013 most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
6014 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
6015 practice this should not happen as it means that either C<size> is incorrect or
6016 that C<dst> is not a proper NUL-terminated string).
6018 Note that C<size> is the full size of the destination buffer and
6019 the result is guaranteed to be NUL-terminated if there is room. Note that room
6020 for the NUL should be included in C<size>.
6024 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
6028 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6030 Size_t used, length, copy;
6033 length = strlen(src);
6034 if (size > 0 && used < size - 1) {
6035 copy = (length >= size - used) ? size - used - 1 : length;
6036 memcpy(dst + used, src, copy);
6037 dst[used + copy] = '\0';
6039 return used + length;
6045 =for apidoc my_strlcpy
6047 The C library C<strlcpy> if available, or a Perl implementation of it.
6048 This operates on C NUL-terminated strings.
6050 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
6051 to C<dst>, NUL-terminating the result if C<size> is not 0.
6055 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
6059 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6061 Size_t length, copy;
6063 length = strlen(src);
6065 copy = (length >= size) ? size - 1 : length;
6066 memcpy(dst, src, copy);
6073 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6074 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6075 long _ftol( double ); /* Defined by VC6 C libs. */
6076 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6079 PERL_STATIC_INLINE bool
6080 S_gv_has_usable_name(pTHX_ GV *gv)
6084 && HvENAME(GvSTASH(gv))
6085 && (gvp = (GV **)hv_fetch(
6086 GvSTASH(gv), GvNAME(gv),
6087 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6093 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6096 SV * const dbsv = GvSVn(PL_DBsub);
6097 const bool save_taint = TAINT_get;
6099 /* When we are called from pp_goto (svp is null),
6100 * we do not care about using dbsv to call CV;
6101 * it's for informational purposes only.
6104 PERL_ARGS_ASSERT_GET_DB_SUB;
6108 if (!PERLDB_SUB_NN) {
6112 gv_efullname3(dbsv, gv, NULL);
6114 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6115 || strEQ(GvNAME(gv), "END")
6116 || ( /* Could be imported, and old sub redefined. */
6117 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6119 !( (SvTYPE(*svp) == SVt_PVGV)
6120 && (GvCV((const GV *)*svp) == cv)
6121 /* Use GV from the stack as a fallback. */
6122 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6126 /* GV is potentially non-unique, or contain different CV. */
6127 SV * const tmp = newRV(MUTABLE_SV(cv));
6128 sv_setsv(dbsv, tmp);
6132 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6133 sv_catpvs(dbsv, "::");
6135 dbsv, GvNAME(gv), GvNAMELEN(gv),
6136 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6141 const int type = SvTYPE(dbsv);
6142 if (type < SVt_PVIV && type != SVt_IV)
6143 sv_upgrade(dbsv, SVt_PVIV);
6144 (void)SvIOK_on(dbsv);
6145 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6147 TAINT_IF(save_taint);
6148 #ifdef NO_TAINT_SUPPORT
6149 PERL_UNUSED_VAR(save_taint);
6154 Perl_my_dirfd(pTHX_ DIR * dir) {
6156 /* Most dirfd implementations have problems when passed NULL. */
6161 #elif defined(HAS_DIR_DD_FD)
6164 Perl_die(aTHX_ PL_no_func, "dirfd");
6165 assert(0); /* NOT REACHED */
6171 Perl_get_re_arg(pTHX_ SV *sv) {
6177 sv = MUTABLE_SV(SvRV(sv));
6178 if (SvTYPE(sv) == SVt_REGEXP)
6179 return (REGEXP*) sv;
6186 * This code is derived from drand48() implementation from FreeBSD,
6187 * found in lib/libc/gen/_rand48.c.
6189 * The U64 implementation is original, based on the POSIX
6190 * specification for drand48().
6194 * Copyright (c) 1993 Martin Birgmeier
6195 * All rights reserved.
6197 * You may redistribute unmodified or modified versions of this source
6198 * code provided that the above copyright notice and this and the
6199 * following conditions are retained.
6201 * This software is provided ``as is'', and comes with no warranties
6202 * of any kind. I shall in no event be liable for anything that happens
6203 * to anyone/anything when using this software.
6206 #define FREEBSD_DRAND48_SEED_0 (0x330e)
6208 #ifdef PERL_DRAND48_QUAD
6210 #define DRAND48_MULT U64_CONST(0x5deece66d)
6211 #define DRAND48_ADD 0xb
6212 #define DRAND48_MASK U64_CONST(0xffffffffffff)
6216 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
6217 #define FREEBSD_DRAND48_SEED_2 (0x1234)
6218 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
6219 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
6220 #define FREEBSD_DRAND48_MULT_2 (0x0005)
6221 #define FREEBSD_DRAND48_ADD (0x000b)
6223 const unsigned short _rand48_mult[3] = {
6224 FREEBSD_DRAND48_MULT_0,
6225 FREEBSD_DRAND48_MULT_1,
6226 FREEBSD_DRAND48_MULT_2
6228 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
6233 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
6235 PERL_ARGS_ASSERT_DRAND48_INIT_R;
6237 #ifdef PERL_DRAND48_QUAD
6238 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
6240 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
6241 random_state->seed[1] = (U16) seed;
6242 random_state->seed[2] = (U16) (seed >> 16);
6247 Perl_drand48_r(perl_drand48_t *random_state)
6249 PERL_ARGS_ASSERT_DRAND48_R;
6251 #ifdef PERL_DRAND48_QUAD
6252 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
6255 return ldexp(*random_state, -48);
6261 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
6262 + (U32) _rand48_add;
6263 temp[0] = (U16) accu; /* lower 16 bits */
6264 accu >>= sizeof(U16) * 8;
6265 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
6266 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
6267 temp[1] = (U16) accu; /* middle 16 bits */
6268 accu >>= sizeof(U16) * 8;
6269 accu += _rand48_mult[0] * random_state->seed[2]
6270 + _rand48_mult[1] * random_state->seed[1]
6271 + _rand48_mult[2] * random_state->seed[0];
6272 random_state->seed[0] = temp[0];
6273 random_state->seed[1] = temp[1];
6274 random_state->seed[2] = (U16) accu;
6276 return ldexp((double) random_state->seed[0], -48) +
6277 ldexp((double) random_state->seed[1], -32) +
6278 ldexp((double) random_state->seed[2], -16);
6286 * c-indentation-style: bsd
6288 * indent-tabs-mode: nil
6291 * ex: set ts=8 sts=4 sw=4 et: