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 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 /* Find out whether the refcount is low enough for us to wait for the
2712 child proc without blocking. */
2713 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
2715 const bool should_wait = 1;
2718 svp = av_fetch(PL_fdpid,fd,TRUE);
2719 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2723 if (pid == -1) { /* Opened by popen. */
2724 return my_syspclose(ptr);
2727 close_failed = (PerlIO_close(ptr) == EOF);
2729 if (should_wait) do {
2730 pid2 = wait4pid(pid, &status, 0);
2731 } while (pid2 == -1 && errno == EINTR);
2738 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2743 #if defined(__LIBCATAMOUNT__)
2745 Perl_my_pclose(pTHX_ PerlIO *ptr)
2750 #endif /* !DOSISH */
2752 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2754 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2758 PERL_ARGS_ASSERT_WAIT4PID;
2759 #ifdef PERL_USES_PL_PIDSTATUS
2761 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2762 waitpid() nor wait4() is available, or on OS/2, which
2763 doesn't appear to support waiting for a progress group
2764 member, so we can only treat a 0 pid as an unknown child.
2771 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2772 pid, rather than a string form. */
2773 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2774 if (svp && *svp != &PL_sv_undef) {
2775 *statusp = SvIVX(*svp);
2776 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2784 hv_iterinit(PL_pidstatus);
2785 if ((entry = hv_iternext(PL_pidstatus))) {
2786 SV * const sv = hv_iterval(PL_pidstatus,entry);
2788 const char * const spid = hv_iterkey(entry,&len);
2790 assert (len == sizeof(Pid_t));
2791 memcpy((char *)&pid, spid, len);
2792 *statusp = SvIVX(sv);
2793 /* The hash iterator is currently on this entry, so simply
2794 calling hv_delete would trigger the lazy delete, which on
2795 aggregate does more work, beacuse next call to hv_iterinit()
2796 would spot the flag, and have to call the delete routine,
2797 while in the meantime any new entries can't re-use that
2799 hv_iterinit(PL_pidstatus);
2800 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2807 # ifdef HAS_WAITPID_RUNTIME
2808 if (!HAS_WAITPID_RUNTIME)
2811 result = PerlProc_waitpid(pid,statusp,flags);
2814 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2815 result = wait4(pid,statusp,flags,NULL);
2818 #ifdef PERL_USES_PL_PIDSTATUS
2819 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2824 Perl_croak(aTHX_ "Can't do waitpid with flags");
2826 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2827 pidgone(result,*statusp);
2833 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2836 if (result < 0 && errno == EINTR) {
2838 errno = EINTR; /* reset in case a signal handler changed $! */
2842 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2844 #ifdef PERL_USES_PL_PIDSTATUS
2846 S_pidgone(pTHX_ Pid_t pid, int status)
2850 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2851 SvUPGRADE(sv,SVt_IV);
2852 SvIV_set(sv, status);
2860 int /* Cannot prototype with I32
2862 my_syspclose(PerlIO *ptr)
2865 Perl_my_pclose(pTHX_ PerlIO *ptr)
2868 /* Needs work for PerlIO ! */
2869 FILE * const f = PerlIO_findFILE(ptr);
2870 const I32 result = pclose(f);
2871 PerlIO_releaseFILE(ptr,f);
2879 Perl_my_pclose(pTHX_ PerlIO *ptr)
2881 /* Needs work for PerlIO ! */
2882 FILE * const f = PerlIO_findFILE(ptr);
2883 I32 result = djgpp_pclose(f);
2884 result = (result << 8) & 0xff00;
2885 PerlIO_releaseFILE(ptr,f);
2890 #define PERL_REPEATCPY_LINEAR 4
2892 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2894 PERL_ARGS_ASSERT_REPEATCPY;
2899 croak_memory_wrap();
2902 memset(to, *from, count);
2905 IV items, linear, half;
2907 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2908 for (items = 0; items < linear; ++items) {
2909 const char *q = from;
2911 for (todo = len; todo > 0; todo--)
2916 while (items <= half) {
2917 IV size = items * len;
2918 memcpy(p, to, size);
2924 memcpy(p, to, (count - items) * len);
2930 Perl_same_dirent(pTHX_ const char *a, const char *b)
2932 char *fa = strrchr(a,'/');
2933 char *fb = strrchr(b,'/');
2936 SV * const tmpsv = sv_newmortal();
2938 PERL_ARGS_ASSERT_SAME_DIRENT;
2951 sv_setpvs(tmpsv, ".");
2953 sv_setpvn(tmpsv, a, fa - a);
2954 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2957 sv_setpvs(tmpsv, ".");
2959 sv_setpvn(tmpsv, b, fb - b);
2960 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2962 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2963 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2965 #endif /* !HAS_RENAME */
2968 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2969 const char *const *const search_ext, I32 flags)
2972 const char *xfound = NULL;
2973 char *xfailed = NULL;
2974 char tmpbuf[MAXPATHLEN];
2979 #if defined(DOSISH) && !defined(OS2)
2980 # define SEARCH_EXTS ".bat", ".cmd", NULL
2981 # define MAX_EXT_LEN 4
2984 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2985 # define MAX_EXT_LEN 4
2988 # define SEARCH_EXTS ".pl", ".com", NULL
2989 # define MAX_EXT_LEN 4
2991 /* additional extensions to try in each dir if scriptname not found */
2993 static const char *const exts[] = { SEARCH_EXTS };
2994 const char *const *const ext = search_ext ? search_ext : exts;
2995 int extidx = 0, i = 0;
2996 const char *curext = NULL;
2998 PERL_UNUSED_ARG(search_ext);
2999 # define MAX_EXT_LEN 0
3002 PERL_ARGS_ASSERT_FIND_SCRIPT;
3005 * If dosearch is true and if scriptname does not contain path
3006 * delimiters, search the PATH for scriptname.
3008 * If SEARCH_EXTS is also defined, will look for each
3009 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3010 * while searching the PATH.
3012 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3013 * proceeds as follows:
3014 * If DOSISH or VMSISH:
3015 * + look for ./scriptname{,.foo,.bar}
3016 * + search the PATH for scriptname{,.foo,.bar}
3019 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3020 * this will not look in '.' if it's not in the PATH)
3025 # ifdef ALWAYS_DEFTYPES
3026 len = strlen(scriptname);
3027 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3028 int idx = 0, deftypes = 1;
3031 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3034 int idx = 0, deftypes = 1;
3037 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3039 /* The first time through, just add SEARCH_EXTS to whatever we
3040 * already have, so we can check for default file types. */
3042 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3048 if ((strlen(tmpbuf) + strlen(scriptname)
3049 + MAX_EXT_LEN) >= sizeof tmpbuf)
3050 continue; /* don't search dir with too-long name */
3051 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3055 if (strEQ(scriptname, "-"))
3057 if (dosearch) { /* Look in '.' first. */
3058 const char *cur = scriptname;
3060 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3062 if (strEQ(ext[i++],curext)) {
3063 extidx = -1; /* already has an ext */
3068 DEBUG_p(PerlIO_printf(Perl_debug_log,
3069 "Looking for %s\n",cur));
3070 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3071 && !S_ISDIR(PL_statbuf.st_mode)) {
3079 if (cur == scriptname) {
3080 len = strlen(scriptname);
3081 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3083 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3086 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3087 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3092 if (dosearch && !strchr(scriptname, '/')
3094 && !strchr(scriptname, '\\')
3096 && (s = PerlEnv_getenv("PATH")))
3100 bufend = s + strlen(s);
3101 while (s < bufend) {
3104 && *s != ';'; len++, s++) {
3105 if (len < sizeof tmpbuf)
3108 if (len < sizeof tmpbuf)
3111 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3117 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3118 continue; /* don't search dir with too-long name */
3121 && tmpbuf[len - 1] != '/'
3122 && tmpbuf[len - 1] != '\\'
3125 tmpbuf[len++] = '/';
3126 if (len == 2 && tmpbuf[0] == '.')
3128 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3132 len = strlen(tmpbuf);
3133 if (extidx > 0) /* reset after previous loop */
3137 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3138 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3139 if (S_ISDIR(PL_statbuf.st_mode)) {
3143 } while ( retval < 0 /* not there */
3144 && extidx>=0 && ext[extidx] /* try an extension? */
3145 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3150 if (S_ISREG(PL_statbuf.st_mode)
3151 && cando(S_IRUSR,TRUE,&PL_statbuf)
3152 #if !defined(DOSISH)
3153 && cando(S_IXUSR,TRUE,&PL_statbuf)
3157 xfound = tmpbuf; /* bingo! */
3161 xfailed = savepv(tmpbuf);
3164 if (!xfound && !seen_dot && !xfailed &&
3165 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3166 || S_ISDIR(PL_statbuf.st_mode)))
3168 seen_dot = 1; /* Disable message. */
3170 if (flags & 1) { /* do or die? */
3171 /* diag_listed_as: Can't execute %s */
3172 Perl_croak(aTHX_ "Can't %s %s%s%s",
3173 (xfailed ? "execute" : "find"),
3174 (xfailed ? xfailed : scriptname),
3175 (xfailed ? "" : " on PATH"),
3176 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3181 scriptname = xfound;
3183 return (scriptname ? savepv(scriptname) : NULL);
3186 #ifndef PERL_GET_CONTEXT_DEFINED
3189 Perl_get_context(void)
3192 #if defined(USE_ITHREADS)
3193 # ifdef OLD_PTHREADS_API
3195 int error = pthread_getspecific(PL_thr_key, &t)
3197 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3200 # ifdef I_MACH_CTHREADS
3201 return (void*)cthread_data(cthread_self());
3203 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3212 Perl_set_context(void *t)
3215 PERL_ARGS_ASSERT_SET_CONTEXT;
3216 #if defined(USE_ITHREADS)
3217 # ifdef I_MACH_CTHREADS
3218 cthread_set_data(cthread_self(), t);
3221 const int error = pthread_setspecific(PL_thr_key, t);
3223 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3231 #endif /* !PERL_GET_CONTEXT_DEFINED */
3233 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3242 Perl_get_op_names(pTHX)
3244 PERL_UNUSED_CONTEXT;
3245 return (char **)PL_op_name;
3249 Perl_get_op_descs(pTHX)
3251 PERL_UNUSED_CONTEXT;
3252 return (char **)PL_op_desc;
3256 Perl_get_no_modify(pTHX)
3258 PERL_UNUSED_CONTEXT;
3259 return PL_no_modify;
3263 Perl_get_opargs(pTHX)
3265 PERL_UNUSED_CONTEXT;
3266 return (U32 *)PL_opargs;
3270 Perl_get_ppaddr(pTHX)
3273 PERL_UNUSED_CONTEXT;
3274 return (PPADDR_t*)PL_ppaddr;
3277 #ifndef HAS_GETENV_LEN
3279 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3281 char * const env_trans = PerlEnv_getenv(env_elem);
3282 PERL_UNUSED_CONTEXT;
3283 PERL_ARGS_ASSERT_GETENV_LEN;
3285 *len = strlen(env_trans);
3292 Perl_get_vtbl(pTHX_ int vtbl_id)
3294 PERL_UNUSED_CONTEXT;
3296 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3297 ? NULL : PL_magic_vtables + vtbl_id;
3301 Perl_my_fflush_all(pTHX)
3303 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3304 return PerlIO_flush(NULL);
3306 # if defined(HAS__FWALK)
3307 extern int fflush(FILE *);
3308 /* undocumented, unprototyped, but very useful BSDism */
3309 extern void _fwalk(int (*)(FILE *));
3313 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3315 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3316 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3318 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3319 open_max = sysconf(_SC_OPEN_MAX);
3322 open_max = FOPEN_MAX;
3325 open_max = OPEN_MAX;
3336 for (i = 0; i < open_max; i++)
3337 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3338 STDIO_STREAM_ARRAY[i]._file < open_max &&
3339 STDIO_STREAM_ARRAY[i]._flag)
3340 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3344 SETERRNO(EBADF,RMS_IFI);
3351 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3353 if (ckWARN(WARN_IO)) {
3355 = gv && (isGV_with_GP(gv))
3358 const char * const direction = have == '>' ? "out" : "in";
3360 if (name && HEK_LEN(name))
3361 Perl_warner(aTHX_ packWARN(WARN_IO),
3362 "Filehandle %"HEKf" opened only for %sput",
3365 Perl_warner(aTHX_ packWARN(WARN_IO),
3366 "Filehandle opened only for %sput", direction);
3371 Perl_report_evil_fh(pTHX_ const GV *gv)
3373 const IO *io = gv ? GvIO(gv) : NULL;
3374 const PERL_BITFIELD16 op = PL_op->op_type;
3378 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3380 warn_type = WARN_CLOSED;
3384 warn_type = WARN_UNOPENED;
3387 if (ckWARN(warn_type)) {
3389 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3390 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3391 const char * const pars =
3392 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3393 const char * const func =
3395 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3396 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3398 const char * const type =
3400 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3401 ? "socket" : "filehandle");
3402 const bool have_name = name && SvCUR(name);
3403 Perl_warner(aTHX_ packWARN(warn_type),
3404 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3405 have_name ? " " : "",
3406 SVfARG(have_name ? name : &PL_sv_no));
3407 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3409 aTHX_ packWARN(warn_type),
3410 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3411 func, pars, have_name ? " " : "",
3412 SVfARG(have_name ? name : &PL_sv_no)
3417 /* To workaround core dumps from the uninitialised tm_zone we get the
3418 * system to give us a reasonable struct to copy. This fix means that
3419 * strftime uses the tm_zone and tm_gmtoff values returned by
3420 * localtime(time()). That should give the desired result most of the
3421 * time. But probably not always!
3423 * This does not address tzname aspects of NETaa14816.
3428 # ifndef STRUCT_TM_HASZONE
3429 # define STRUCT_TM_HASZONE
3433 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3434 # ifndef HAS_TM_TM_ZONE
3435 # define HAS_TM_TM_ZONE
3440 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3442 #ifdef HAS_TM_TM_ZONE
3444 const struct tm* my_tm;
3445 PERL_ARGS_ASSERT_INIT_TM;
3447 my_tm = localtime(&now);
3449 Copy(my_tm, ptm, 1, struct tm);
3451 PERL_ARGS_ASSERT_INIT_TM;
3452 PERL_UNUSED_ARG(ptm);
3457 * mini_mktime - normalise struct tm values without the localtime()
3458 * semantics (and overhead) of mktime().
3461 Perl_mini_mktime(pTHX_ struct tm *ptm)
3465 int month, mday, year, jday;
3466 int odd_cent, odd_year;
3467 PERL_UNUSED_CONTEXT;
3469 PERL_ARGS_ASSERT_MINI_MKTIME;
3471 #define DAYS_PER_YEAR 365
3472 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3473 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3474 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3475 #define SECS_PER_HOUR (60*60)
3476 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3477 /* parentheses deliberately absent on these two, otherwise they don't work */
3478 #define MONTH_TO_DAYS 153/5
3479 #define DAYS_TO_MONTH 5/153
3480 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3481 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3482 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3483 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3486 * Year/day algorithm notes:
3488 * With a suitable offset for numeric value of the month, one can find
3489 * an offset into the year by considering months to have 30.6 (153/5) days,
3490 * using integer arithmetic (i.e., with truncation). To avoid too much
3491 * messing about with leap days, we consider January and February to be
3492 * the 13th and 14th month of the previous year. After that transformation,
3493 * we need the month index we use to be high by 1 from 'normal human' usage,
3494 * so the month index values we use run from 4 through 15.
3496 * Given that, and the rules for the Gregorian calendar (leap years are those
3497 * divisible by 4 unless also divisible by 100, when they must be divisible
3498 * by 400 instead), we can simply calculate the number of days since some
3499 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3500 * the days we derive from our month index, and adding in the day of the
3501 * month. The value used here is not adjusted for the actual origin which
3502 * it normally would use (1 January A.D. 1), since we're not exposing it.
3503 * We're only building the value so we can turn around and get the
3504 * normalised values for the year, month, day-of-month, and day-of-year.
3506 * For going backward, we need to bias the value we're using so that we find
3507 * the right year value. (Basically, we don't want the contribution of
3508 * March 1st to the number to apply while deriving the year). Having done
3509 * that, we 'count up' the contribution to the year number by accounting for
3510 * full quadracenturies (400-year periods) with their extra leap days, plus
3511 * the contribution from full centuries (to avoid counting in the lost leap
3512 * days), plus the contribution from full quad-years (to count in the normal
3513 * leap days), plus the leftover contribution from any non-leap years.
3514 * At this point, if we were working with an actual leap day, we'll have 0
3515 * days left over. This is also true for March 1st, however. So, we have
3516 * to special-case that result, and (earlier) keep track of the 'odd'
3517 * century and year contributions. If we got 4 extra centuries in a qcent,
3518 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3519 * Otherwise, we add back in the earlier bias we removed (the 123 from
3520 * figuring in March 1st), find the month index (integer division by 30.6),
3521 * and the remainder is the day-of-month. We then have to convert back to
3522 * 'real' months (including fixing January and February from being 14/15 in
3523 * the previous year to being in the proper year). After that, to get
3524 * tm_yday, we work with the normalised year and get a new yearday value for
3525 * January 1st, which we subtract from the yearday value we had earlier,
3526 * representing the date we've re-built. This is done from January 1
3527 * because tm_yday is 0-origin.
3529 * Since POSIX time routines are only guaranteed to work for times since the
3530 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3531 * applies Gregorian calendar rules even to dates before the 16th century
3532 * doesn't bother me. Besides, you'd need cultural context for a given
3533 * date to know whether it was Julian or Gregorian calendar, and that's
3534 * outside the scope for this routine. Since we convert back based on the
3535 * same rules we used to build the yearday, you'll only get strange results
3536 * for input which needed normalising, or for the 'odd' century years which
3537 * were leap years in the Julian calendar but not in the Gregorian one.
3538 * I can live with that.
3540 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3541 * that's still outside the scope for POSIX time manipulation, so I don't
3545 year = 1900 + ptm->tm_year;
3546 month = ptm->tm_mon;
3547 mday = ptm->tm_mday;
3553 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3554 yearday += month*MONTH_TO_DAYS + mday + jday;
3556 * Note that we don't know when leap-seconds were or will be,
3557 * so we have to trust the user if we get something which looks
3558 * like a sensible leap-second. Wild values for seconds will
3559 * be rationalised, however.
3561 if ((unsigned) ptm->tm_sec <= 60) {
3568 secs += 60 * ptm->tm_min;
3569 secs += SECS_PER_HOUR * ptm->tm_hour;
3571 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3572 /* got negative remainder, but need positive time */
3573 /* back off an extra day to compensate */
3574 yearday += (secs/SECS_PER_DAY)-1;
3575 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3578 yearday += (secs/SECS_PER_DAY);
3579 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3582 else if (secs >= SECS_PER_DAY) {
3583 yearday += (secs/SECS_PER_DAY);
3584 secs %= SECS_PER_DAY;
3586 ptm->tm_hour = secs/SECS_PER_HOUR;
3587 secs %= SECS_PER_HOUR;
3588 ptm->tm_min = secs/60;
3590 ptm->tm_sec += secs;
3591 /* done with time of day effects */
3593 * The algorithm for yearday has (so far) left it high by 428.
3594 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3595 * bias it by 123 while trying to figure out what year it
3596 * really represents. Even with this tweak, the reverse
3597 * translation fails for years before A.D. 0001.
3598 * It would still fail for Feb 29, but we catch that one below.
3600 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3601 yearday -= YEAR_ADJUST;
3602 year = (yearday / DAYS_PER_QCENT) * 400;
3603 yearday %= DAYS_PER_QCENT;
3604 odd_cent = yearday / DAYS_PER_CENT;
3605 year += odd_cent * 100;
3606 yearday %= DAYS_PER_CENT;
3607 year += (yearday / DAYS_PER_QYEAR) * 4;
3608 yearday %= DAYS_PER_QYEAR;
3609 odd_year = yearday / DAYS_PER_YEAR;
3611 yearday %= DAYS_PER_YEAR;
3612 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3617 yearday += YEAR_ADJUST; /* recover March 1st crock */
3618 month = yearday*DAYS_TO_MONTH;
3619 yearday -= month*MONTH_TO_DAYS;
3620 /* recover other leap-year adjustment */
3629 ptm->tm_year = year - 1900;
3631 ptm->tm_mday = yearday;
3632 ptm->tm_mon = month;
3636 ptm->tm_mon = month - 1;
3638 /* re-build yearday based on Jan 1 to get tm_yday */
3640 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3641 yearday += 14*MONTH_TO_DAYS + 1;
3642 ptm->tm_yday = jday - yearday;
3643 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3647 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)
3655 PERL_ARGS_ASSERT_MY_STRFTIME;
3657 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3660 mytm.tm_hour = hour;
3661 mytm.tm_mday = mday;
3663 mytm.tm_year = year;
3664 mytm.tm_wday = wday;
3665 mytm.tm_yday = yday;
3666 mytm.tm_isdst = isdst;
3668 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3669 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3674 #ifdef HAS_TM_TM_GMTOFF
3675 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3677 #ifdef HAS_TM_TM_ZONE
3678 mytm.tm_zone = mytm2.tm_zone;
3683 Newx(buf, buflen, char);
3684 len = strftime(buf, buflen, fmt, &mytm);
3686 ** The following is needed to handle to the situation where
3687 ** tmpbuf overflows. Basically we want to allocate a buffer
3688 ** and try repeatedly. The reason why it is so complicated
3689 ** is that getting a return value of 0 from strftime can indicate
3690 ** one of the following:
3691 ** 1. buffer overflowed,
3692 ** 2. illegal conversion specifier, or
3693 ** 3. the format string specifies nothing to be returned(not
3694 ** an error). This could be because format is an empty string
3695 ** or it specifies %p that yields an empty string in some locale.
3696 ** If there is a better way to make it portable, go ahead by
3699 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3702 /* Possibly buf overflowed - try again with a bigger buf */
3703 const int fmtlen = strlen(fmt);
3704 int bufsize = fmtlen + buflen;
3706 Renew(buf, bufsize, char);
3708 buflen = strftime(buf, bufsize, fmt, &mytm);
3709 if (buflen > 0 && buflen < bufsize)
3711 /* heuristic to prevent out-of-memory errors */
3712 if (bufsize > 100*fmtlen) {
3718 Renew(buf, bufsize, char);
3723 Perl_croak(aTHX_ "panic: no strftime");
3729 #define SV_CWD_RETURN_UNDEF \
3730 sv_setsv(sv, &PL_sv_undef); \
3733 #define SV_CWD_ISDOT(dp) \
3734 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3735 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3738 =head1 Miscellaneous Functions
3740 =for apidoc getcwd_sv
3742 Fill the sv with current working directory
3747 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3748 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3749 * getcwd(3) if available
3750 * Comments from the orignal:
3751 * This is a faster version of getcwd. It's also more dangerous
3752 * because you might chdir out of a directory that you can't chdir
3756 Perl_getcwd_sv(pTHX_ SV *sv)
3762 PERL_ARGS_ASSERT_GETCWD_SV;
3766 char buf[MAXPATHLEN];
3768 /* Some getcwd()s automatically allocate a buffer of the given
3769 * size from the heap if they are given a NULL buffer pointer.
3770 * The problem is that this behaviour is not portable. */
3771 if (getcwd(buf, sizeof(buf) - 1)) {
3776 sv_setsv(sv, &PL_sv_undef);
3784 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3788 SvUPGRADE(sv, SVt_PV);
3790 if (PerlLIO_lstat(".", &statbuf) < 0) {
3791 SV_CWD_RETURN_UNDEF;
3794 orig_cdev = statbuf.st_dev;
3795 orig_cino = statbuf.st_ino;
3805 if (PerlDir_chdir("..") < 0) {
3806 SV_CWD_RETURN_UNDEF;
3808 if (PerlLIO_stat(".", &statbuf) < 0) {
3809 SV_CWD_RETURN_UNDEF;
3812 cdev = statbuf.st_dev;
3813 cino = statbuf.st_ino;
3815 if (odev == cdev && oino == cino) {
3818 if (!(dir = PerlDir_open("."))) {
3819 SV_CWD_RETURN_UNDEF;
3822 while ((dp = PerlDir_read(dir)) != NULL) {
3824 namelen = dp->d_namlen;
3826 namelen = strlen(dp->d_name);
3829 if (SV_CWD_ISDOT(dp)) {
3833 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3834 SV_CWD_RETURN_UNDEF;
3837 tdev = statbuf.st_dev;
3838 tino = statbuf.st_ino;
3839 if (tino == oino && tdev == odev) {
3845 SV_CWD_RETURN_UNDEF;
3848 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3849 SV_CWD_RETURN_UNDEF;
3852 SvGROW(sv, pathlen + namelen + 1);
3856 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3859 /* prepend current directory to the front */
3861 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3862 pathlen += (namelen + 1);
3864 #ifdef VOID_CLOSEDIR
3867 if (PerlDir_close(dir) < 0) {
3868 SV_CWD_RETURN_UNDEF;
3874 SvCUR_set(sv, pathlen);
3878 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3879 SV_CWD_RETURN_UNDEF;
3882 if (PerlLIO_stat(".", &statbuf) < 0) {
3883 SV_CWD_RETURN_UNDEF;
3886 cdev = statbuf.st_dev;
3887 cino = statbuf.st_ino;
3889 if (cdev != orig_cdev || cino != orig_cino) {
3890 Perl_croak(aTHX_ "Unstable directory path, "
3891 "current directory changed unexpectedly");
3902 #define VERSION_MAX 0x7FFFFFFF
3905 =for apidoc prescan_version
3907 Validate that a given string can be parsed as a version object, but doesn't
3908 actually perform the parsing. Can use either strict or lax validation rules.
3909 Can optionally set a number of hint variables to save the parsing code
3910 some time when tokenizing.
3915 Perl_prescan_version(pTHX_ const char *s, bool strict,
3916 const char **errstr,
3917 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3918 bool qv = (sqv ? *sqv : FALSE);
3920 int saw_decimal = 0;
3924 PERL_ARGS_ASSERT_PRESCAN_VERSION;
3926 if (qv && isDIGIT(*d))
3927 goto dotted_decimal_version;
3929 if (*d == 'v') { /* explicit v-string */
3934 else { /* degenerate v-string */
3935 /* requires v1.2.3 */
3936 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3939 dotted_decimal_version:
3940 if (strict && d[0] == '0' && isDIGIT(d[1])) {
3941 /* no leading zeros allowed */
3942 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3945 while (isDIGIT(*d)) /* integer part */
3951 d++; /* decimal point */
3956 /* require v1.2.3 */
3957 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3960 goto version_prescan_finish;
3967 while (isDIGIT(*d)) { /* just keep reading */
3969 while (isDIGIT(*d)) {
3971 /* maximum 3 digits between decimal */
3972 if (strict && j > 3) {
3973 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
3978 BADVERSION(s,errstr,"Invalid version format (no underscores)");
3981 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
3986 else if (*d == '.') {
3988 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
3993 else if (!isDIGIT(*d)) {
3999 if (strict && i < 2) {
4000 /* requires v1.2.3 */
4001 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4004 } /* end if dotted-decimal */
4006 { /* decimal versions */
4007 int j = 0; /* may need this later */
4008 /* special strict case for leading '.' or '0' */
4011 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4013 if (*d == '0' && isDIGIT(d[1])) {
4014 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4018 /* and we never support negative versions */
4020 BADVERSION(s,errstr,"Invalid version format (negative version number)");
4023 /* consume all of the integer part */
4027 /* look for a fractional part */
4029 /* we found it, so consume it */
4033 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4036 BADVERSION(s,errstr,"Invalid version format (version required)");
4038 /* found just an integer */
4039 goto version_prescan_finish;
4041 else if ( d == s ) {
4042 /* didn't find either integer or period */
4043 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4045 else if (*d == '_') {
4046 /* underscore can't come after integer part */
4048 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4050 else if (isDIGIT(d[1])) {
4051 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4054 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4058 /* anything else after integer part is just invalid data */
4059 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4062 /* scan the fractional part after the decimal point*/
4064 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4065 /* strict or lax-but-not-the-end */
4066 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4069 while (isDIGIT(*d)) {
4071 if (*d == '.' && isDIGIT(d[-1])) {
4073 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4076 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4078 d = (char *)s; /* start all over again */
4080 goto dotted_decimal_version;
4084 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4087 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4089 if ( ! isDIGIT(d[1]) ) {
4090 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4099 version_prescan_finish:
4103 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4104 /* trailing non-numeric data */
4105 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4113 *ssaw_decimal = saw_decimal;
4120 =for apidoc scan_version
4122 Returns a pointer to the next character after the parsed
4123 version string, as well as upgrading the passed in SV to
4126 Function must be called with an already existing SV like
4129 s = scan_version(s, SV *sv, bool qv);
4131 Performs some preprocessing to the string to ensure that
4132 it has the correct characteristics of a version. Flags the
4133 object if it contains an underscore (which denotes this
4134 is an alpha version). The boolean qv denotes that the version
4135 should be interpreted as if it had multiple decimals, even if
4142 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4144 const char *start = s;
4147 const char *errstr = NULL;
4148 int saw_decimal = 0;
4155 PERL_ARGS_ASSERT_SCAN_VERSION;
4157 while (isSPACE(*s)) /* leading whitespace is OK */
4160 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4162 /* "undef" is a special case and not an error */
4163 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4165 Perl_croak(aTHX_ "%s", errstr);
4174 /* Now that we are through the prescan, start creating the object */
4176 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4177 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4179 #ifndef NODEFAULT_SHAREKEYS
4180 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4184 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4186 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4187 if ( !qv && width < 3 )
4188 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4190 while (isDIGIT(*pos))
4192 if (!isALPHA(*pos)) {
4198 /* this is atoi() that delimits on underscores */
4199 const char *end = pos;
4203 /* the following if() will only be true after the decimal
4204 * point of a version originally created with a bare
4205 * floating point number, i.e. not quoted in any way
4207 if ( !qv && s > start && saw_decimal == 1 ) {
4211 rev += (*s - '0') * mult;
4213 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4214 || (PERL_ABS(rev) > VERSION_MAX )) {
4215 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4216 "Integer overflow in version %d",VERSION_MAX);
4227 while (--end >= s) {
4229 rev += (*end - '0') * mult;
4231 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4232 || (PERL_ABS(rev) > VERSION_MAX )) {
4233 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4234 "Integer overflow in version");
4243 /* Append revision */
4244 av_push(av, newSViv(rev));
4249 else if ( *pos == '.' )
4251 else if ( *pos == '_' && isDIGIT(pos[1]) )
4253 else if ( *pos == ',' && isDIGIT(pos[1]) )
4255 else if ( isDIGIT(*pos) )
4262 while ( isDIGIT(*pos) )
4267 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4275 if ( qv ) { /* quoted versions always get at least three terms*/
4276 SSize_t len = av_len(av);
4277 /* This for loop appears to trigger a compiler bug on OS X, as it
4278 loops infinitely. Yes, len is negative. No, it makes no sense.
4279 Compiler in question is:
4280 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4281 for ( len = 2 - len; len > 0; len-- )
4282 av_push(MUTABLE_AV(sv), newSViv(0));
4286 av_push(av, newSViv(0));
4289 /* need to save off the current version string for later */
4291 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4292 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4293 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4295 else if ( s > start ) {
4296 SV * orig = newSVpvn(start,s-start);
4297 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4298 /* need to insert a v to be consistent */
4299 sv_insert(orig, 0, 0, "v", 1);
4301 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4304 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4305 av_push(av, newSViv(0));
4308 /* And finally, store the AV in the hash */
4309 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4311 /* fix RT#19517 - special case 'undef' as string */
4312 if ( *s == 'u' && strEQ(s,"undef") ) {
4320 =for apidoc new_version
4322 Returns a new version object based on the passed in SV:
4324 SV *sv = new_version(SV *ver);
4326 Does not alter the passed in ver SV. See "upg_version" if you
4327 want to upgrade the SV.
4333 Perl_new_version(pTHX_ SV *ver)
4336 SV * const rv = newSV(0);
4337 PERL_ARGS_ASSERT_NEW_VERSION;
4338 if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4339 /* can just copy directly */
4342 AV * const av = newAV();
4344 /* This will get reblessed later if a derived class*/
4345 SV * const hv = newSVrv(rv, "version");
4346 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4347 #ifndef NODEFAULT_SHAREKEYS
4348 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4354 /* Begin copying all of the elements */
4355 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4356 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4358 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4359 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4361 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4363 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4364 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4367 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4369 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4370 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4373 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4374 /* This will get reblessed later if a derived class*/
4375 for ( key = 0; key <= av_len(sav); key++ )
4377 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4378 av_push(av, newSViv(rev));
4381 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4386 const MAGIC* const mg = SvVSTRING_mg(ver);
4387 if ( mg ) { /* already a v-string */
4388 const STRLEN len = mg->mg_len;
4389 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4390 sv_setpvn(rv,version,len);
4391 /* this is for consistency with the pure Perl class */
4392 if ( isDIGIT(*version) )
4393 sv_insert(rv, 0, 0, "v", 1);
4398 sv_setsv(rv,ver); /* make a duplicate */
4403 return upg_version(rv, FALSE);
4407 =for apidoc upg_version
4409 In-place upgrade of the supplied SV to a version object.
4411 SV *sv = upg_version(SV *sv, bool qv);
4413 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4414 to force this SV to be interpreted as an "extended" version.
4420 Perl_upg_version(pTHX_ SV *ver, bool qv)
4422 const char *version, *s;
4427 PERL_ARGS_ASSERT_UPG_VERSION;
4429 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4433 /* may get too much accuracy */
4435 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4437 #ifdef USE_LOCALE_NUMERIC
4439 if (! PL_numeric_standard) {
4440 loc = savepv(setlocale(LC_NUMERIC, NULL));
4441 setlocale(LC_NUMERIC, "C");
4445 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4446 buf = SvPV(sv, len);
4449 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4452 #ifdef USE_LOCALE_NUMERIC
4454 setlocale(LC_NUMERIC, loc);
4458 while (buf[len-1] == '0' && len > 0) len--;
4459 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4460 version = savepvn(buf, len);
4464 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4465 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4469 else /* must be a string or something like a string */
4472 version = savepv(SvPV(ver,len));
4474 # if PERL_VERSION > 5
4475 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4476 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4477 /* may be a v-string */
4478 char *testv = (char *)version;
4480 for (tlen=0; tlen < len; tlen++, testv++) {
4481 /* if one of the characters is non-text assume v-string */
4482 if (testv[0] < ' ') {
4483 SV * const nsv = sv_newmortal();
4486 int saw_decimal = 0;
4487 sv_setpvf(nsv,"v%vd",ver);
4488 pos = nver = savepv(SvPV_nolen(nsv));
4490 /* scan the resulting formatted string */
4491 pos++; /* skip the leading 'v' */
4492 while ( *pos == '.' || isDIGIT(*pos) ) {
4498 /* is definitely a v-string */
4499 if ( saw_decimal >= 2 ) {
4511 s = scan_version(version, ver, qv);
4513 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4514 "Version string '%s' contains invalid data; "
4515 "ignoring: '%s'", version, s);
4523 Validates that the SV contains valid internal structure for a version object.
4524 It may be passed either the version object (RV) or the hash itself (HV). If
4525 the structure is valid, it returns the HV. If the structure is invalid,
4528 SV *hv = vverify(sv);
4530 Note that it only confirms the bare minimum structure (so as not to get
4531 confused by derived classes which may contain additional hash entries):
4535 =item * The SV is an HV or a reference to an HV
4537 =item * The hash contains a "version" key
4539 =item * The "version" key has a reference to an AV as its value
4547 Perl_vverify(pTHX_ SV *vs)
4551 PERL_ARGS_ASSERT_VVERIFY;
4556 /* see if the appropriate elements exist */
4557 if ( SvTYPE(vs) == SVt_PVHV
4558 && hv_exists(MUTABLE_HV(vs), "version", 7)
4559 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4560 && SvTYPE(sv) == SVt_PVAV )
4569 Accepts a version object and returns the normalized floating
4570 point representation. Call like:
4574 NOTE: you can pass either the object directly or the SV
4575 contained within the RV.
4577 The SV returned has a refcount of 1.
4583 Perl_vnumify(pTHX_ SV *vs)
4592 PERL_ARGS_ASSERT_VNUMIFY;
4594 /* extract the HV from the object */
4597 Perl_croak(aTHX_ "Invalid version object");
4599 /* see if various flags exist */
4600 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4602 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4603 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4608 /* attempt to retrieve the version array */
4609 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4610 return newSVpvs("0");
4616 return newSVpvs("0");
4619 digit = SvIV(*av_fetch(av, 0, 0));
4620 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4621 for ( i = 1 ; i < len ; i++ )
4623 digit = SvIV(*av_fetch(av, i, 0));
4625 const int denom = (width == 2 ? 10 : 100);
4626 const div_t term = div((int)PERL_ABS(digit),denom);
4627 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4630 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4636 digit = SvIV(*av_fetch(av, len, 0));
4637 if ( alpha && width == 3 ) /* alpha version */
4639 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4643 sv_catpvs(sv, "000");
4651 Accepts a version object and returns the normalized string
4652 representation. Call like:
4656 NOTE: you can pass either the object directly or the SV
4657 contained within the RV.
4659 The SV returned has a refcount of 1.
4665 Perl_vnormal(pTHX_ SV *vs)
4672 PERL_ARGS_ASSERT_VNORMAL;
4674 /* extract the HV from the object */
4677 Perl_croak(aTHX_ "Invalid version object");
4679 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4681 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4686 return newSVpvs("");
4688 digit = SvIV(*av_fetch(av, 0, 0));
4689 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4690 for ( i = 1 ; i < len ; i++ ) {
4691 digit = SvIV(*av_fetch(av, i, 0));
4692 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4697 /* handle last digit specially */
4698 digit = SvIV(*av_fetch(av, len, 0));
4700 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4702 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4705 if ( len <= 2 ) { /* short version, must be at least three */
4706 for ( len = 2 - len; len != 0; len-- )
4713 =for apidoc vstringify
4715 In order to maintain maximum compatibility with earlier versions
4716 of Perl, this function will return either the floating point
4717 notation or the multiple dotted notation, depending on whether
4718 the original version contained 1 or more dots, respectively.
4720 The SV returned has a refcount of 1.
4726 Perl_vstringify(pTHX_ SV *vs)
4728 PERL_ARGS_ASSERT_VSTRINGIFY;
4730 /* extract the HV from the object */
4733 Perl_croak(aTHX_ "Invalid version object");
4735 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
4737 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4741 return &PL_sv_undef;
4744 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4754 Version object aware cmp. Both operands must already have been
4755 converted into version objects.
4761 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4765 bool lalpha = FALSE;
4766 bool ralpha = FALSE;
4771 PERL_ARGS_ASSERT_VCMP;
4773 /* extract the HVs from the objects */
4776 if ( ! ( lhv && rhv ) )
4777 Perl_croak(aTHX_ "Invalid version object");
4779 /* get the left hand term */
4780 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4781 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4784 /* and the right hand term */
4785 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4786 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4794 while ( i <= m && retval == 0 )
4796 left = SvIV(*av_fetch(lav,i,0));
4797 right = SvIV(*av_fetch(rav,i,0));
4805 /* tiebreaker for alpha with identical terms */
4806 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4808 if ( lalpha && !ralpha )
4812 else if ( ralpha && !lalpha)
4818 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4822 while ( i <= r && retval == 0 )
4824 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4825 retval = -1; /* not a match after all */
4831 while ( i <= l && retval == 0 )
4833 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4834 retval = +1; /* not a match after all */
4842 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4843 # define EMULATE_SOCKETPAIR_UDP
4846 #ifdef EMULATE_SOCKETPAIR_UDP
4848 S_socketpair_udp (int fd[2]) {
4850 /* Fake a datagram socketpair using UDP to localhost. */
4851 int sockets[2] = {-1, -1};
4852 struct sockaddr_in addresses[2];
4854 Sock_size_t size = sizeof(struct sockaddr_in);
4855 unsigned short port;
4858 memset(&addresses, 0, sizeof(addresses));
4861 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4862 if (sockets[i] == -1)
4863 goto tidy_up_and_fail;
4865 addresses[i].sin_family = AF_INET;
4866 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4867 addresses[i].sin_port = 0; /* kernel choses port. */
4868 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4869 sizeof(struct sockaddr_in)) == -1)
4870 goto tidy_up_and_fail;
4873 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4874 for each connect the other socket to it. */
4877 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4879 goto tidy_up_and_fail;
4880 if (size != sizeof(struct sockaddr_in))
4881 goto abort_tidy_up_and_fail;
4882 /* !1 is 0, !0 is 1 */
4883 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4884 sizeof(struct sockaddr_in)) == -1)
4885 goto tidy_up_and_fail;
4888 /* Now we have 2 sockets connected to each other. I don't trust some other
4889 process not to have already sent a packet to us (by random) so send
4890 a packet from each to the other. */
4893 /* I'm going to send my own port number. As a short.
4894 (Who knows if someone somewhere has sin_port as a bitfield and needs
4895 this routine. (I'm assuming crays have socketpair)) */
4896 port = addresses[i].sin_port;
4897 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4898 if (got != sizeof(port)) {
4900 goto tidy_up_and_fail;
4901 goto abort_tidy_up_and_fail;
4905 /* Packets sent. I don't trust them to have arrived though.
4906 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4907 connect to localhost will use a second kernel thread. In 2.6 the
4908 first thread running the connect() returns before the second completes,
4909 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4910 returns 0. Poor programs have tripped up. One poor program's authors'
4911 had a 50-1 reverse stock split. Not sure how connected these were.)
4912 So I don't trust someone not to have an unpredictable UDP stack.
4916 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4917 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4921 FD_SET((unsigned int)sockets[0], &rset);
4922 FD_SET((unsigned int)sockets[1], &rset);
4924 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4925 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4926 || !FD_ISSET(sockets[1], &rset)) {
4927 /* I hope this is portable and appropriate. */
4929 goto tidy_up_and_fail;
4930 goto abort_tidy_up_and_fail;
4934 /* And the paranoia department even now doesn't trust it to have arrive
4935 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4937 struct sockaddr_in readfrom;
4938 unsigned short buffer[2];
4943 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4944 sizeof(buffer), MSG_DONTWAIT,
4945 (struct sockaddr *) &readfrom, &size);
4947 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4949 (struct sockaddr *) &readfrom, &size);
4953 goto tidy_up_and_fail;
4954 if (got != sizeof(port)
4955 || size != sizeof(struct sockaddr_in)
4956 /* Check other socket sent us its port. */
4957 || buffer[0] != (unsigned short) addresses[!i].sin_port
4958 /* Check kernel says we got the datagram from that socket */
4959 || readfrom.sin_family != addresses[!i].sin_family
4960 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4961 || readfrom.sin_port != addresses[!i].sin_port)
4962 goto abort_tidy_up_and_fail;
4965 /* My caller (my_socketpair) has validated that this is non-NULL */
4968 /* I hereby declare this connection open. May God bless all who cross
4972 abort_tidy_up_and_fail:
4973 errno = ECONNABORTED;
4977 if (sockets[0] != -1)
4978 PerlLIO_close(sockets[0]);
4979 if (sockets[1] != -1)
4980 PerlLIO_close(sockets[1]);
4985 #endif /* EMULATE_SOCKETPAIR_UDP */
4987 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4989 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4990 /* Stevens says that family must be AF_LOCAL, protocol 0.
4991 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4996 struct sockaddr_in listen_addr;
4997 struct sockaddr_in connect_addr;
5002 || family != AF_UNIX
5005 errno = EAFNOSUPPORT;
5013 #ifdef EMULATE_SOCKETPAIR_UDP
5014 if (type == SOCK_DGRAM)
5015 return S_socketpair_udp(fd);
5018 aTHXa(PERL_GET_THX);
5019 listener = PerlSock_socket(AF_INET, type, 0);
5022 memset(&listen_addr, 0, sizeof(listen_addr));
5023 listen_addr.sin_family = AF_INET;
5024 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5025 listen_addr.sin_port = 0; /* kernel choses port. */
5026 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5027 sizeof(listen_addr)) == -1)
5028 goto tidy_up_and_fail;
5029 if (PerlSock_listen(listener, 1) == -1)
5030 goto tidy_up_and_fail;
5032 connector = PerlSock_socket(AF_INET, type, 0);
5033 if (connector == -1)
5034 goto tidy_up_and_fail;
5035 /* We want to find out the port number to connect to. */
5036 size = sizeof(connect_addr);
5037 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5039 goto tidy_up_and_fail;
5040 if (size != sizeof(connect_addr))
5041 goto abort_tidy_up_and_fail;
5042 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5043 sizeof(connect_addr)) == -1)
5044 goto tidy_up_and_fail;
5046 size = sizeof(listen_addr);
5047 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5050 goto tidy_up_and_fail;
5051 if (size != sizeof(listen_addr))
5052 goto abort_tidy_up_and_fail;
5053 PerlLIO_close(listener);
5054 /* Now check we are talking to ourself by matching port and host on the
5056 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5058 goto tidy_up_and_fail;
5059 if (size != sizeof(connect_addr)
5060 || listen_addr.sin_family != connect_addr.sin_family
5061 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5062 || listen_addr.sin_port != connect_addr.sin_port) {
5063 goto abort_tidy_up_and_fail;
5069 abort_tidy_up_and_fail:
5071 errno = ECONNABORTED; /* This would be the standard thing to do. */
5073 # ifdef ECONNREFUSED
5074 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5076 errno = ETIMEDOUT; /* Desperation time. */
5083 PerlLIO_close(listener);
5084 if (connector != -1)
5085 PerlLIO_close(connector);
5087 PerlLIO_close(acceptor);
5093 /* In any case have a stub so that there's code corresponding
5094 * to the my_socketpair in embed.fnc. */
5096 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5097 #ifdef HAS_SOCKETPAIR
5098 return socketpair(family, type, protocol, fd);
5107 =for apidoc sv_nosharing
5109 Dummy routine which "shares" an SV when there is no sharing module present.
5110 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5111 Exists to avoid test for a NULL function pointer and because it could
5112 potentially warn under some level of strict-ness.
5118 Perl_sv_nosharing(pTHX_ SV *sv)
5120 PERL_UNUSED_CONTEXT;
5121 PERL_UNUSED_ARG(sv);
5126 =for apidoc sv_destroyable
5128 Dummy routine which reports that object can be destroyed when there is no
5129 sharing module present. It ignores its single SV argument, and returns
5130 'true'. Exists to avoid test for a NULL function pointer and because it
5131 could potentially warn under some level of strict-ness.
5137 Perl_sv_destroyable(pTHX_ SV *sv)
5139 PERL_UNUSED_CONTEXT;
5140 PERL_UNUSED_ARG(sv);
5145 Perl_parse_unicode_opts(pTHX_ const char **popt)
5147 const char *p = *popt;
5150 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5154 opt = (U32) atoi(p);
5157 if (*p && *p != '\n' && *p != '\r') {
5158 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5160 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5166 case PERL_UNICODE_STDIN:
5167 opt |= PERL_UNICODE_STDIN_FLAG; break;
5168 case PERL_UNICODE_STDOUT:
5169 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5170 case PERL_UNICODE_STDERR:
5171 opt |= PERL_UNICODE_STDERR_FLAG; break;
5172 case PERL_UNICODE_STD:
5173 opt |= PERL_UNICODE_STD_FLAG; break;
5174 case PERL_UNICODE_IN:
5175 opt |= PERL_UNICODE_IN_FLAG; break;
5176 case PERL_UNICODE_OUT:
5177 opt |= PERL_UNICODE_OUT_FLAG; break;
5178 case PERL_UNICODE_INOUT:
5179 opt |= PERL_UNICODE_INOUT_FLAG; break;
5180 case PERL_UNICODE_LOCALE:
5181 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5182 case PERL_UNICODE_ARGV:
5183 opt |= PERL_UNICODE_ARGV_FLAG; break;
5184 case PERL_UNICODE_UTF8CACHEASSERT:
5185 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5187 if (*p != '\n' && *p != '\r') {
5188 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5191 "Unknown Unicode option letter '%c'", *p);
5198 opt = PERL_UNICODE_DEFAULT_FLAGS;
5200 the_end_of_the_opts_parser:
5202 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5203 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5204 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5212 # include <starlet.h>
5220 * This is really just a quick hack which grabs various garbage
5221 * values. It really should be a real hash algorithm which
5222 * spreads the effect of every input bit onto every output bit,
5223 * if someone who knows about such things would bother to write it.
5224 * Might be a good idea to add that function to CORE as well.
5225 * No numbers below come from careful analysis or anything here,
5226 * except they are primes and SEED_C1 > 1E6 to get a full-width
5227 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5228 * probably be bigger too.
5231 # define SEED_C1 1000003
5232 #define SEED_C4 73819
5234 # define SEED_C1 25747
5235 #define SEED_C4 20639
5239 #define SEED_C5 26107
5241 #ifndef PERL_NO_DEV_RANDOM
5246 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5247 * in 100-ns units, typically incremented ever 10 ms. */
5248 unsigned int when[2];
5250 # ifdef HAS_GETTIMEOFDAY
5251 struct timeval when;
5257 /* This test is an escape hatch, this symbol isn't set by Configure. */
5258 #ifndef PERL_NO_DEV_RANDOM
5259 #ifndef PERL_RANDOM_DEVICE
5260 /* /dev/random isn't used by default because reads from it will block
5261 * if there isn't enough entropy available. You can compile with
5262 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5263 * is enough real entropy to fill the seed. */
5264 # define PERL_RANDOM_DEVICE "/dev/urandom"
5266 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5268 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5277 _ckvmssts(sys$gettim(when));
5278 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5280 # ifdef HAS_GETTIMEOFDAY
5281 PerlProc_gettimeofday(&when,NULL);
5282 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5285 u = (U32)SEED_C1 * when;
5288 u += SEED_C3 * (U32)PerlProc_getpid();
5289 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5290 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5291 u += SEED_C5 * (U32)PTR2UV(&when);
5297 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
5303 PERL_ARGS_ASSERT_GET_HASH_SEED;
5305 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
5308 #ifndef USE_HASH_SEED_EXPLICIT
5310 /* ignore leading spaces */
5311 while (isSPACE(*env_pv))
5313 #ifdef USE_PERL_PERTURB_KEYS
5314 /* if they set it to "0" we disable key traversal randomization completely */
5315 if (strEQ(env_pv,"0")) {
5316 PL_hash_rand_bits_enabled= 0;
5318 /* otherwise switch to deterministic mode */
5319 PL_hash_rand_bits_enabled= 2;
5322 /* ignore a leading 0x... if it is there */
5323 if (env_pv[0] == '0' && env_pv[1] == 'x')
5326 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
5327 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
5328 if ( isXDIGIT(*env_pv)) {
5329 seed_buffer[i] |= READ_XDIGIT(env_pv);
5332 while (isSPACE(*env_pv))
5335 if (*env_pv && !isXDIGIT(*env_pv)) {
5336 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
5338 /* should we check for unparsed crap? */
5339 /* should we warn about unused hex? */
5340 /* should we warn about insufficient hex? */
5345 (void)seedDrand01((Rand_seed_t)seed());
5347 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
5348 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
5351 #ifdef USE_PERL_PERTURB_KEYS
5352 { /* initialize PL_hash_rand_bits from the hash seed.
5353 * This value is highly volatile, it is updated every
5354 * hash insert, and is used as part of hash bucket chain
5355 * randomization and hash iterator randomization. */
5356 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
5357 for( i = 0; i < sizeof(UV) ; i++ ) {
5358 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
5359 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
5362 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
5364 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
5365 PL_hash_rand_bits_enabled= 0;
5366 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
5367 PL_hash_rand_bits_enabled= 1;
5368 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
5369 PL_hash_rand_bits_enabled= 2;
5371 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
5377 #ifdef PERL_GLOBAL_STRUCT
5379 #define PERL_GLOBAL_STRUCT_INIT
5380 #include "opcode.h" /* the ppaddr and check */
5383 Perl_init_global_struct(pTHX)
5385 struct perl_vars *plvarsp = NULL;
5386 # ifdef PERL_GLOBAL_STRUCT
5387 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5388 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5389 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5390 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5391 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5395 plvarsp = PL_VarsPtr;
5396 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5401 # define PERLVAR(prefix,var,type) /**/
5402 # define PERLVARA(prefix,var,n,type) /**/
5403 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5404 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5405 # include "perlvars.h"
5410 # ifdef PERL_GLOBAL_STRUCT
5413 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5414 if (!plvarsp->Gppaddr)
5418 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5419 if (!plvarsp->Gcheck)
5421 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5422 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5424 # ifdef PERL_SET_VARS
5425 PERL_SET_VARS(plvarsp);
5427 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5428 plvarsp->Gsv_placeholder.sv_flags = 0;
5429 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
5431 # undef PERL_GLOBAL_STRUCT_INIT
5436 #endif /* PERL_GLOBAL_STRUCT */
5438 #ifdef PERL_GLOBAL_STRUCT
5441 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5443 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5444 # ifdef PERL_GLOBAL_STRUCT
5445 # ifdef PERL_UNSET_VARS
5446 PERL_UNSET_VARS(plvarsp);
5448 free(plvarsp->Gppaddr);
5449 free(plvarsp->Gcheck);
5450 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5456 #endif /* PERL_GLOBAL_STRUCT */
5460 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5461 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5462 * given, and you supply your own implementation.
5464 * The default implementation reads a single env var, PERL_MEM_LOG,
5465 * expecting one or more of the following:
5467 * \d+ - fd fd to write to : must be 1st (atoi)
5468 * 'm' - memlog was PERL_MEM_LOG=1
5469 * 's' - svlog was PERL_SV_LOG=1
5470 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5472 * This makes the logger controllable enough that it can reasonably be
5473 * added to the system perl.
5476 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5477 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5479 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5481 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5482 * writes to. In the default logger, this is settable at runtime.
5484 #ifndef PERL_MEM_LOG_FD
5485 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5488 #ifndef PERL_MEM_LOG_NOIMPL
5490 # ifdef DEBUG_LEAKING_SCALARS
5491 # define SV_LOG_SERIAL_FMT " [%lu]"
5492 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5494 # define SV_LOG_SERIAL_FMT
5495 # define _SV_LOG_SERIAL_ARG(sv)
5499 S_mem_log_common(enum mem_log_type mlt, const UV n,
5500 const UV typesize, const char *type_name, const SV *sv,
5501 Malloc_t oldalloc, Malloc_t newalloc,
5502 const char *filename, const int linenumber,
5503 const char *funcname)
5507 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5509 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5512 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5514 /* We can't use SVs or PerlIO for obvious reasons,
5515 * so we'll use stdio and low-level IO instead. */
5516 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5518 # ifdef HAS_GETTIMEOFDAY
5519 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5520 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5522 gettimeofday(&tv, 0);
5524 # define MEM_LOG_TIME_FMT "%10d: "
5525 # define MEM_LOG_TIME_ARG (int)when
5529 /* If there are other OS specific ways of hires time than
5530 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5531 * probably that they would be used to fill in the struct
5535 int fd = atoi(pmlenv);
5537 fd = PERL_MEM_LOG_FD;
5539 if (strchr(pmlenv, 't')) {
5540 len = my_snprintf(buf, sizeof(buf),
5541 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5542 PerlLIO_write(fd, buf, len);
5546 len = my_snprintf(buf, sizeof(buf),
5547 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5548 " %s = %"IVdf": %"UVxf"\n",
5549 filename, linenumber, funcname, n, typesize,
5550 type_name, n * typesize, PTR2UV(newalloc));
5553 len = my_snprintf(buf, sizeof(buf),
5554 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5555 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5556 filename, linenumber, funcname, n, typesize,
5557 type_name, n * typesize, PTR2UV(oldalloc),
5561 len = my_snprintf(buf, sizeof(buf),
5562 "free: %s:%d:%s: %"UVxf"\n",
5563 filename, linenumber, funcname,
5568 len = my_snprintf(buf, sizeof(buf),
5569 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5570 mlt == MLT_NEW_SV ? "new" : "del",
5571 filename, linenumber, funcname,
5572 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5577 PerlLIO_write(fd, buf, len);
5581 #endif /* !PERL_MEM_LOG_NOIMPL */
5583 #ifndef PERL_MEM_LOG_NOIMPL
5585 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5586 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5588 /* this is suboptimal, but bug compatible. User is providing their
5589 own implementation, but is getting these functions anyway, and they
5590 do nothing. But _NOIMPL users should be able to cope or fix */
5592 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5593 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5597 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5599 const char *filename, const int linenumber,
5600 const char *funcname)
5602 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5603 NULL, NULL, newalloc,
5604 filename, linenumber, funcname);
5609 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5610 Malloc_t oldalloc, Malloc_t newalloc,
5611 const char *filename, const int linenumber,
5612 const char *funcname)
5614 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5615 NULL, oldalloc, newalloc,
5616 filename, linenumber, funcname);
5621 Perl_mem_log_free(Malloc_t oldalloc,
5622 const char *filename, const int linenumber,
5623 const char *funcname)
5625 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5626 filename, linenumber, funcname);
5631 Perl_mem_log_new_sv(const SV *sv,
5632 const char *filename, const int linenumber,
5633 const char *funcname)
5635 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5636 filename, linenumber, funcname);
5640 Perl_mem_log_del_sv(const SV *sv,
5641 const char *filename, const int linenumber,
5642 const char *funcname)
5644 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5645 filename, linenumber, funcname);
5648 #endif /* PERL_MEM_LOG */
5651 =for apidoc my_sprintf
5653 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5654 the length of the string written to the buffer. Only rare pre-ANSI systems
5655 need the wrapper function - usually this is a direct call to C<sprintf>.
5659 #ifndef SPRINTF_RETURNS_STRLEN
5661 Perl_my_sprintf(char *buffer, const char* pat, ...)
5664 PERL_ARGS_ASSERT_MY_SPRINTF;
5665 va_start(args, pat);
5666 vsprintf(buffer, pat, args);
5668 return strlen(buffer);
5673 =for apidoc my_snprintf
5675 The C library C<snprintf> functionality, if available and
5676 standards-compliant (uses C<vsnprintf>, actually). However, if the
5677 C<vsnprintf> is not available, will unfortunately use the unsafe
5678 C<vsprintf> which can overrun the buffer (there is an overrun check,
5679 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5680 getting C<vsnprintf>.
5685 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5689 PERL_ARGS_ASSERT_MY_SNPRINTF;
5690 va_start(ap, format);
5691 #ifdef HAS_VSNPRINTF
5692 retval = vsnprintf(buffer, len, format, ap);
5694 retval = vsprintf(buffer, format, ap);
5697 /* vsprintf() shows failure with < 0 */
5699 #ifdef HAS_VSNPRINTF
5700 /* vsnprintf() shows failure with >= len */
5702 (len > 0 && (Size_t)retval >= len)
5705 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5710 =for apidoc my_vsnprintf
5712 The C library C<vsnprintf> if available and standards-compliant.
5713 However, if if the C<vsnprintf> is not available, will unfortunately
5714 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5715 overrun check, but that may be too late). Consider using
5716 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5721 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5727 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5729 Perl_va_copy(ap, apc);
5730 # ifdef HAS_VSNPRINTF
5731 retval = vsnprintf(buffer, len, format, apc);
5733 retval = vsprintf(buffer, format, apc);
5736 # ifdef HAS_VSNPRINTF
5737 retval = vsnprintf(buffer, len, format, ap);
5739 retval = vsprintf(buffer, format, ap);
5741 #endif /* #ifdef NEED_VA_COPY */
5742 /* vsprintf() shows failure with < 0 */
5744 #ifdef HAS_VSNPRINTF
5745 /* vsnprintf() shows failure with >= len */
5747 (len > 0 && (Size_t)retval >= len)
5750 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5755 Perl_my_clearenv(pTHX)
5758 #if ! defined(PERL_MICRO)
5759 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5761 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5762 # if defined(USE_ENVIRON_ARRAY)
5763 # if defined(USE_ITHREADS)
5764 /* only the parent thread can clobber the process environment */
5765 if (PL_curinterp == aTHX)
5766 # endif /* USE_ITHREADS */
5768 # if ! defined(PERL_USE_SAFE_PUTENV)
5769 if ( !PL_use_safe_putenv) {
5771 if (environ == PL_origenviron)
5772 environ = (char**)safesysmalloc(sizeof(char*));
5774 for (i = 0; environ[i]; i++)
5775 (void)safesysfree(environ[i]);
5778 # else /* PERL_USE_SAFE_PUTENV */
5779 # if defined(HAS_CLEARENV)
5781 # elif defined(HAS_UNSETENV)
5782 int bsiz = 80; /* Most envvar names will be shorter than this. */
5783 char *buf = (char*)safesysmalloc(bsiz);
5784 while (*environ != NULL) {
5785 char *e = strchr(*environ, '=');
5786 int l = e ? e - *environ : (int)strlen(*environ);
5788 (void)safesysfree(buf);
5789 bsiz = l + 1; /* + 1 for the \0. */
5790 buf = (char*)safesysmalloc(bsiz);
5792 memcpy(buf, *environ, l);
5794 (void)unsetenv(buf);
5796 (void)safesysfree(buf);
5797 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5798 /* Just null environ and accept the leakage. */
5800 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5801 # endif /* ! PERL_USE_SAFE_PUTENV */
5803 # endif /* USE_ENVIRON_ARRAY */
5804 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5805 #endif /* PERL_MICRO */
5808 #ifdef PERL_IMPLICIT_CONTEXT
5810 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5811 the global PL_my_cxt_index is incremented, and that value is assigned to
5812 that module's static my_cxt_index (who's address is passed as an arg).
5813 Then, for each interpreter this function is called for, it makes sure a
5814 void* slot is available to hang the static data off, by allocating or
5815 extending the interpreter's PL_my_cxt_list array */
5817 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5819 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5823 PERL_ARGS_ASSERT_MY_CXT_INIT;
5825 /* this module hasn't been allocated an index yet */
5826 #if defined(USE_ITHREADS)
5827 MUTEX_LOCK(&PL_my_ctx_mutex);
5829 *index = PL_my_cxt_index++;
5830 #if defined(USE_ITHREADS)
5831 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5835 /* make sure the array is big enough */
5836 if (PL_my_cxt_size <= *index) {
5837 if (PL_my_cxt_size) {
5838 while (PL_my_cxt_size <= *index)
5839 PL_my_cxt_size *= 2;
5840 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5843 PL_my_cxt_size = 16;
5844 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5847 /* newSV() allocates one more than needed */
5848 p = (void*)SvPVX(newSV(size-1));
5849 PL_my_cxt_list[*index] = p;
5850 Zero(p, size, char);
5854 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5857 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5862 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5864 for (index = 0; index < PL_my_cxt_index; index++) {
5865 const char *key = PL_my_cxt_keys[index];
5866 /* try direct pointer compare first - there are chances to success,
5867 * and it's much faster.
5869 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5876 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5882 PERL_ARGS_ASSERT_MY_CXT_INIT;
5884 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5886 /* this module hasn't been allocated an index yet */
5887 #if defined(USE_ITHREADS)
5888 MUTEX_LOCK(&PL_my_ctx_mutex);
5890 index = PL_my_cxt_index++;
5891 #if defined(USE_ITHREADS)
5892 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5896 /* make sure the array is big enough */
5897 if (PL_my_cxt_size <= index) {
5898 int old_size = PL_my_cxt_size;
5900 if (PL_my_cxt_size) {
5901 while (PL_my_cxt_size <= index)
5902 PL_my_cxt_size *= 2;
5903 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5904 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5907 PL_my_cxt_size = 16;
5908 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5909 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5911 for (i = old_size; i < PL_my_cxt_size; i++) {
5912 PL_my_cxt_keys[i] = 0;
5913 PL_my_cxt_list[i] = 0;
5916 PL_my_cxt_keys[index] = my_cxt_key;
5917 /* newSV() allocates one more than needed */
5918 p = (void*)SvPVX(newSV(size-1));
5919 PL_my_cxt_list[index] = p;
5920 Zero(p, size, char);
5923 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5924 #endif /* PERL_IMPLICIT_CONTEXT */
5927 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5931 const char *vn = NULL;
5932 SV *const module = PL_stack_base[ax];
5934 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5936 if (items >= 2) /* version supplied as bootstrap arg */
5937 sv = PL_stack_base[ax + 1];
5939 /* XXX GV_ADDWARN */
5941 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5942 if (!sv || !SvOK(sv)) {
5944 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5948 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5949 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5950 ? sv : sv_2mortal(new_version(sv));
5951 xssv = upg_version(xssv, 0);
5952 if ( vcmp(pmsv,xssv) ) {
5953 SV *string = vstringify(xssv);
5954 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5955 " does not match ", module, string);
5957 SvREFCNT_dec(string);
5958 string = vstringify(pmsv);
5961 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5964 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
5966 SvREFCNT_dec(string);
5968 Perl_sv_2mortal(aTHX_ xpt);
5969 Perl_croak_sv(aTHX_ xpt);
5975 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
5979 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
5982 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
5984 /* This might croak */
5985 compver = upg_version(compver, 0);
5986 /* This should never croak */
5987 runver = new_version(PL_apiversion);
5988 if (vcmp(compver, runver)) {
5989 SV *compver_string = vstringify(compver);
5990 SV *runver_string = vstringify(runver);
5991 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
5992 " of %"SVf" does not match %"SVf,
5993 compver_string, module, runver_string);
5994 Perl_sv_2mortal(aTHX_ xpt);
5996 SvREFCNT_dec(compver_string);
5997 SvREFCNT_dec(runver_string);
5999 SvREFCNT_dec(runver);
6001 Perl_croak_sv(aTHX_ xpt);
6005 =for apidoc my_strlcat
6007 The C library C<strlcat> if available, or a Perl implementation of it.
6008 This operates on C NUL-terminated strings.
6010 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
6011 most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
6012 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
6013 practice this should not happen as it means that either C<size> is incorrect or
6014 that C<dst> is not a proper NUL-terminated string).
6016 Note that C<size> is the full size of the destination buffer and
6017 the result is guaranteed to be NUL-terminated if there is room. Note that room
6018 for the NUL should be included in C<size>.
6022 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
6026 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6028 Size_t used, length, copy;
6031 length = strlen(src);
6032 if (size > 0 && used < size - 1) {
6033 copy = (length >= size - used) ? size - used - 1 : length;
6034 memcpy(dst + used, src, copy);
6035 dst[used + copy] = '\0';
6037 return used + length;
6043 =for apidoc my_strlcpy
6045 The C library C<strlcpy> if available, or a Perl implementation of it.
6046 This operates on C NUL-terminated strings.
6048 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
6049 to C<dst>, NUL-terminating the result if C<size> is not 0.
6053 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
6057 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6059 Size_t length, copy;
6061 length = strlen(src);
6063 copy = (length >= size) ? size - 1 : length;
6064 memcpy(dst, src, copy);
6071 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6072 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6073 long _ftol( double ); /* Defined by VC6 C libs. */
6074 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6077 PERL_STATIC_INLINE bool
6078 S_gv_has_usable_name(pTHX_ GV *gv)
6082 && HvENAME(GvSTASH(gv))
6083 && (gvp = (GV **)hv_fetch(
6084 GvSTASH(gv), GvNAME(gv),
6085 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6091 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6094 SV * const dbsv = GvSVn(PL_DBsub);
6095 const bool save_taint = TAINT_get;
6097 /* When we are called from pp_goto (svp is null),
6098 * we do not care about using dbsv to call CV;
6099 * it's for informational purposes only.
6102 PERL_ARGS_ASSERT_GET_DB_SUB;
6106 if (!PERLDB_SUB_NN) {
6110 gv_efullname3(dbsv, gv, NULL);
6112 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6113 || strEQ(GvNAME(gv), "END")
6114 || ( /* Could be imported, and old sub redefined. */
6115 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6117 !( (SvTYPE(*svp) == SVt_PVGV)
6118 && (GvCV((const GV *)*svp) == cv)
6119 /* Use GV from the stack as a fallback. */
6120 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6124 /* GV is potentially non-unique, or contain different CV. */
6125 SV * const tmp = newRV(MUTABLE_SV(cv));
6126 sv_setsv(dbsv, tmp);
6130 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6131 sv_catpvs(dbsv, "::");
6133 dbsv, GvNAME(gv), GvNAMELEN(gv),
6134 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6139 const int type = SvTYPE(dbsv);
6140 if (type < SVt_PVIV && type != SVt_IV)
6141 sv_upgrade(dbsv, SVt_PVIV);
6142 (void)SvIOK_on(dbsv);
6143 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6145 TAINT_IF(save_taint);
6146 #ifdef NO_TAINT_SUPPORT
6147 PERL_UNUSED_VAR(save_taint);
6152 Perl_my_dirfd(pTHX_ DIR * dir) {
6154 /* Most dirfd implementations have problems when passed NULL. */
6159 #elif defined(HAS_DIR_DD_FD)
6162 Perl_die(aTHX_ PL_no_func, "dirfd");
6163 assert(0); /* NOT REACHED */
6169 Perl_get_re_arg(pTHX_ SV *sv) {
6175 sv = MUTABLE_SV(SvRV(sv));
6176 if (SvTYPE(sv) == SVt_REGEXP)
6177 return (REGEXP*) sv;
6184 * This code is derived from drand48() implementation from FreeBSD,
6185 * found in lib/libc/gen/_rand48.c.
6187 * The U64 implementation is original, based on the POSIX
6188 * specification for drand48().
6192 * Copyright (c) 1993 Martin Birgmeier
6193 * All rights reserved.
6195 * You may redistribute unmodified or modified versions of this source
6196 * code provided that the above copyright notice and this and the
6197 * following conditions are retained.
6199 * This software is provided ``as is'', and comes with no warranties
6200 * of any kind. I shall in no event be liable for anything that happens
6201 * to anyone/anything when using this software.
6204 #define FREEBSD_DRAND48_SEED_0 (0x330e)
6206 #ifdef PERL_DRAND48_QUAD
6208 #define DRAND48_MULT U64_CONST(0x5deece66d)
6209 #define DRAND48_ADD 0xb
6210 #define DRAND48_MASK U64_CONST(0xffffffffffff)
6214 #define FREEBSD_DRAND48_SEED_1 (0xabcd)
6215 #define FREEBSD_DRAND48_SEED_2 (0x1234)
6216 #define FREEBSD_DRAND48_MULT_0 (0xe66d)
6217 #define FREEBSD_DRAND48_MULT_1 (0xdeec)
6218 #define FREEBSD_DRAND48_MULT_2 (0x0005)
6219 #define FREEBSD_DRAND48_ADD (0x000b)
6221 const unsigned short _rand48_mult[3] = {
6222 FREEBSD_DRAND48_MULT_0,
6223 FREEBSD_DRAND48_MULT_1,
6224 FREEBSD_DRAND48_MULT_2
6226 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
6231 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
6233 PERL_ARGS_ASSERT_DRAND48_INIT_R;
6235 #ifdef PERL_DRAND48_QUAD
6236 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
6238 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
6239 random_state->seed[1] = (U16) seed;
6240 random_state->seed[2] = (U16) (seed >> 16);
6245 Perl_drand48_r(perl_drand48_t *random_state)
6247 PERL_ARGS_ASSERT_DRAND48_R;
6249 #ifdef PERL_DRAND48_QUAD
6250 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
6253 return ldexp(*random_state, -48);
6259 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
6260 + (U32) _rand48_add;
6261 temp[0] = (U16) accu; /* lower 16 bits */
6262 accu >>= sizeof(U16) * 8;
6263 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
6264 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
6265 temp[1] = (U16) accu; /* middle 16 bits */
6266 accu >>= sizeof(U16) * 8;
6267 accu += _rand48_mult[0] * random_state->seed[2]
6268 + _rand48_mult[1] * random_state->seed[1]
6269 + _rand48_mult[2] * random_state->seed[0];
6270 random_state->seed[0] = temp[0];
6271 random_state->seed[1] = temp[1];
6272 random_state->seed[2] = (U16) accu;
6274 return ldexp((double) random_state->seed[0], -48) +
6275 ldexp((double) random_state->seed[1], -32) +
6276 ldexp((double) random_state->seed[2], -16);
6284 * c-indentation-style: bsd
6286 * indent-tabs-mode: nil
6289 * ex: set ts=8 sts=4 sw=4 et: