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
31 # define SIG_ERR ((Sighandler_t) -1)
36 /* Missing protos on LynxOS */
41 # include <sys/wait.h>
46 # include <sys/select.h>
52 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
53 # define FD_CLOEXEC 1 /* NeXT needs this */
56 /* NOTE: Do not call the next three routines directly. Use the macros
57 * in handy.h, so that we can easily redefine everything to do tracking of
58 * allocated hunks back to the original New to track down any memory leaks.
59 * XXX This advice seems to be widely ignored :-( --AD August 1996.
66 /* Can't use PerlIO to write as it allocates memory */
67 PerlLIO_write(PerlIO_fileno(Perl_error_log),
68 PL_no_mem, strlen(PL_no_mem));
70 NORETURN_FUNCTION_END;
73 /* paranoid version of system's malloc() */
76 Perl_safesysmalloc(MEM_SIZE size)
82 PerlIO_printf(Perl_error_log,
83 "Allocation too large: %lx\n", size) FLUSH;
86 #endif /* HAS_64K_LIMIT */
87 #ifdef PERL_TRACK_MEMPOOL
92 Perl_croak_nocontext("panic: malloc");
94 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
95 PERL_ALLOC_CHECK(ptr);
96 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
98 #ifdef PERL_TRACK_MEMPOOL
99 struct perl_memory_debug_header *const header
100 = (struct perl_memory_debug_header *)ptr;
104 PoisonNew(((char *)ptr), size, char);
107 #ifdef PERL_TRACK_MEMPOOL
108 header->interpreter = aTHX;
109 /* Link us into the list. */
110 header->prev = &PL_memory_debug_header;
111 header->next = PL_memory_debug_header.next;
112 PL_memory_debug_header.next = header;
113 header->next->prev = header;
117 ptr = (Malloc_t)((char*)ptr+sTHX);
124 return write_no_mem();
129 /* paranoid version of system's realloc() */
132 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
136 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
137 Malloc_t PerlMem_realloc();
138 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
142 PerlIO_printf(Perl_error_log,
143 "Reallocation too large: %lx\n", size) FLUSH;
146 #endif /* HAS_64K_LIMIT */
153 return safesysmalloc(size);
154 #ifdef PERL_TRACK_MEMPOOL
155 where = (Malloc_t)((char*)where-sTHX);
158 struct perl_memory_debug_header *const header
159 = (struct perl_memory_debug_header *)where;
161 if (header->interpreter != aTHX) {
162 Perl_croak_nocontext("panic: realloc from wrong pool");
164 assert(header->next->prev == header);
165 assert(header->prev->next == header);
167 if (header->size > size) {
168 const MEM_SIZE freed_up = header->size - size;
169 char *start_of_freed = ((char *)where) + size;
170 PoisonFree(start_of_freed, freed_up, char);
178 Perl_croak_nocontext("panic: realloc");
180 ptr = (Malloc_t)PerlMem_realloc(where,size);
181 PERL_ALLOC_CHECK(ptr);
183 /* MUST do this fixup first, before doing ANYTHING else, as anything else
184 might allocate memory/free/move memory, and until we do the fixup, it
185 may well be chasing (and writing to) free memory. */
186 #ifdef PERL_TRACK_MEMPOOL
188 struct perl_memory_debug_header *const header
189 = (struct perl_memory_debug_header *)ptr;
192 if (header->size < size) {
193 const MEM_SIZE fresh = size - header->size;
194 char *start_of_fresh = ((char *)ptr) + size;
195 PoisonNew(start_of_fresh, fresh, char);
199 header->next->prev = header;
200 header->prev->next = header;
202 ptr = (Malloc_t)((char*)ptr+sTHX);
206 /* In particular, must do that fixup above before logging anything via
207 *printf(), as it can reallocate memory, which can cause SEGVs. */
209 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
210 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
219 return write_no_mem();
224 /* safe version of system's free() */
227 Perl_safesysfree(Malloc_t where)
229 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
234 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
236 #ifdef PERL_TRACK_MEMPOOL
237 where = (Malloc_t)((char*)where-sTHX);
239 struct perl_memory_debug_header *const header
240 = (struct perl_memory_debug_header *)where;
242 if (header->interpreter != aTHX) {
243 Perl_croak_nocontext("panic: free from wrong pool");
246 Perl_croak_nocontext("panic: duplicate free");
248 if (!(header->next) || header->next->prev != header
249 || header->prev->next != header) {
250 Perl_croak_nocontext("panic: bad free");
252 /* Unlink us from the chain. */
253 header->next->prev = header->prev;
254 header->prev->next = header->next;
256 PoisonNew(where, header->size, char);
258 /* Trigger the duplicate free warning. */
266 /* safe version of system's calloc() */
269 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
273 MEM_SIZE total_size = 0;
275 /* Even though calloc() for zero bytes is strange, be robust. */
276 if (size && (count <= MEM_SIZE_MAX / size))
277 total_size = size * count;
279 Perl_croak_nocontext("%s", PL_memory_wrap);
280 #ifdef PERL_TRACK_MEMPOOL
281 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
284 Perl_croak_nocontext("%s", PL_memory_wrap);
287 if (total_size > 0xffff) {
288 PerlIO_printf(Perl_error_log,
289 "Allocation too large: %lx\n", total_size) FLUSH;
292 #endif /* HAS_64K_LIMIT */
294 if ((long)size < 0 || (long)count < 0)
295 Perl_croak_nocontext("panic: calloc");
297 #ifdef PERL_TRACK_MEMPOOL
298 /* Have to use malloc() because we've added some space for our tracking
300 /* malloc(0) is non-portable. */
301 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
303 /* Use calloc() because it might save a memset() if the memory is fresh
304 and clean from the OS. */
306 ptr = (Malloc_t)PerlMem_calloc(count, size);
307 else /* calloc(0) is non-portable. */
308 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
310 PERL_ALLOC_CHECK(ptr);
311 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));
313 #ifdef PERL_TRACK_MEMPOOL
315 struct perl_memory_debug_header *const header
316 = (struct perl_memory_debug_header *)ptr;
318 memset((void*)ptr, 0, total_size);
319 header->interpreter = aTHX;
320 /* Link us into the list. */
321 header->prev = &PL_memory_debug_header;
322 header->next = PL_memory_debug_header.next;
323 PL_memory_debug_header.next = header;
324 header->next->prev = header;
326 header->size = total_size;
328 ptr = (Malloc_t)((char*)ptr+sTHX);
335 return write_no_mem();
338 /* These must be defined when not using Perl's malloc for binary
343 Malloc_t Perl_malloc (MEM_SIZE nbytes)
346 return (Malloc_t)PerlMem_malloc(nbytes);
349 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
352 return (Malloc_t)PerlMem_calloc(elements, size);
355 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
358 return (Malloc_t)PerlMem_realloc(where, nbytes);
361 Free_t Perl_mfree (Malloc_t where)
369 /* copy a string up to some (non-backslashed) delimiter, if any */
372 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
376 PERL_ARGS_ASSERT_DELIMCPY;
378 for (tolen = 0; from < fromend; from++, tolen++) {
380 if (from[1] != delim) {
387 else if (*from == delim)
398 /* return ptr to little string in big string, NULL if not found */
399 /* This routine was donated by Corey Satten. */
402 Perl_instr(register const char *big, register const char *little)
406 PERL_ARGS_ASSERT_INSTR;
414 register const char *s, *x;
417 for (x=big,s=little; *s; /**/ ) {
428 return (char*)(big-1);
433 /* same as instr but allow embedded nulls */
436 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
438 PERL_ARGS_ASSERT_NINSTR;
442 const char first = *little;
444 bigend -= lend - little++;
446 while (big <= bigend) {
447 if (*big++ == first) {
448 for (x=big,s=little; s < lend; x++,s++) {
452 return (char*)(big-1);
459 /* reverse of the above--find last substring */
462 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
464 register const char *bigbeg;
465 register const I32 first = *little;
466 register const char * const littleend = lend;
468 PERL_ARGS_ASSERT_RNINSTR;
470 if (little >= littleend)
471 return (char*)bigend;
473 big = bigend - (littleend - little++);
474 while (big >= bigbeg) {
475 register const char *s, *x;
478 for (x=big+2,s=little; s < littleend; /**/ ) {
487 return (char*)(big+1);
492 /* As a space optimization, we do not compile tables for strings of length
493 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
494 special-cased in fbm_instr().
496 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
499 =head1 Miscellaneous Functions
501 =for apidoc fbm_compile
503 Analyses the string in order to make fast searches on it using fbm_instr()
504 -- the Boyer-Moore algorithm.
510 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
513 register const U8 *s;
519 PERL_ARGS_ASSERT_FBM_COMPILE;
521 if (flags & FBMcf_TAIL) {
522 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
523 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
524 if (mg && mg->mg_len >= 0)
527 s = (U8*)SvPV_force_mutable(sv, len);
528 if (len == 0) /* TAIL might be on a zero-length string. */
530 SvUPGRADE(sv, SVt_PVGV);
535 const unsigned char *sb;
536 const U8 mlen = (len>255) ? 255 : (U8)len;
539 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
541 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
542 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
543 memset((void*)table, mlen, 256);
545 sb = s - mlen + 1; /* first char (maybe) */
547 if (table[*s] == mlen)
552 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
554 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
556 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
557 for (i = 0; i < len; i++) {
558 if (PL_freq[s[i]] < frequency) {
560 frequency = PL_freq[s[i]];
563 BmFLAGS(sv) = (U8)flags;
564 BmRARE(sv) = s[rarest];
565 BmPREVIOUS(sv) = rarest;
566 BmUSEFUL(sv) = 100; /* Initial value */
567 if (flags & FBMcf_TAIL)
569 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
570 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
573 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
574 /* If SvTAIL is actually due to \Z or \z, this gives false positives
578 =for apidoc fbm_instr
580 Returns the location of the SV in the string delimited by C<str> and
581 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
582 does not have to be fbm_compiled, but the search will not be as fast
589 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
591 register unsigned char *s;
593 register const unsigned char *little
594 = (const unsigned char *)SvPV_const(littlestr,l);
595 register STRLEN littlelen = l;
596 register const I32 multiline = flags & FBMrf_MULTILINE;
598 PERL_ARGS_ASSERT_FBM_INSTR;
600 if ((STRLEN)(bigend - big) < littlelen) {
601 if ( SvTAIL(littlestr)
602 && ((STRLEN)(bigend - big) == littlelen - 1)
604 || (*big == *little &&
605 memEQ((char *)big, (char *)little, littlelen - 1))))
610 if (littlelen <= 2) { /* Special-cased */
612 if (littlelen == 1) {
613 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
614 /* Know that bigend != big. */
615 if (bigend[-1] == '\n')
616 return (char *)(bigend - 1);
617 return (char *) bigend;
625 if (SvTAIL(littlestr))
626 return (char *) bigend;
630 return (char*)big; /* Cannot be SvTAIL! */
633 if (SvTAIL(littlestr) && !multiline) {
634 if (bigend[-1] == '\n' && bigend[-2] == *little)
635 return (char*)bigend - 2;
636 if (bigend[-1] == *little)
637 return (char*)bigend - 1;
641 /* This should be better than FBM if c1 == c2, and almost
642 as good otherwise: maybe better since we do less indirection.
643 And we save a lot of memory by caching no table. */
644 const unsigned char c1 = little[0];
645 const unsigned char c2 = little[1];
650 while (s <= bigend) {
660 goto check_1char_anchor;
671 goto check_1char_anchor;
674 while (s <= bigend) {
679 goto check_1char_anchor;
688 check_1char_anchor: /* One char and anchor! */
689 if (SvTAIL(littlestr) && (*bigend == *little))
690 return (char *)bigend; /* bigend is already decremented. */
693 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
694 s = bigend - littlelen;
695 if (s >= big && bigend[-1] == '\n' && *s == *little
696 /* Automatically of length > 2 */
697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
699 return (char*)s; /* how sweet it is */
702 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
704 return (char*)s + 1; /* how sweet it is */
708 if (!SvVALID(littlestr)) {
709 char * const b = ninstr((char*)big,(char*)bigend,
710 (char*)little, (char*)little + littlelen);
712 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
713 /* Chop \n from littlestr: */
714 s = bigend - littlelen + 1;
716 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
726 if (littlelen > (STRLEN)(bigend - big))
730 register const unsigned char * const table
731 = little + littlelen + PERL_FBM_TABLE_OFFSET;
732 register const unsigned char *oldlittle;
734 --littlelen; /* Last char found by table lookup */
737 little += littlelen; /* last char */
743 if ((tmp = table[*s])) {
744 if ((s += tmp) < bigend)
748 else { /* less expensive than calling strncmp() */
749 register unsigned char * const olds = s;
754 if (*--s == *--little)
756 s = olds + 1; /* here we pay the price for failure */
758 if (s < bigend) /* fake up continue to outer loop */
767 && (BmFLAGS(littlestr) & FBMcf_TAIL)
768 && memEQ((char *)(bigend - littlelen),
769 (char *)(oldlittle - littlelen), littlelen) )
770 return (char*)bigend - littlelen;
775 /* start_shift, end_shift are positive quantities which give offsets
776 of ends of some substring of bigstr.
777 If "last" we want the last occurrence.
778 old_posp is the way of communication between consequent calls if
779 the next call needs to find the .
780 The initial *old_posp should be -1.
782 Note that we take into account SvTAIL, so one can get extra
783 optimizations if _ALL flag is set.
786 /* If SvTAIL is actually due to \Z or \z, this gives false positives
787 if PL_multiline. In fact if !PL_multiline the authoritative answer
788 is not supported yet. */
791 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
794 register const unsigned char *big;
796 register I32 previous;
798 register const unsigned char *little;
799 register I32 stop_pos;
800 register const unsigned char *littleend;
803 PERL_ARGS_ASSERT_SCREAMINSTR;
805 assert(SvTYPE(littlestr) == SVt_PVGV);
806 assert(SvVALID(littlestr));
809 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
810 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
812 if ( BmRARE(littlestr) == '\n'
813 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
814 little = (const unsigned char *)(SvPVX_const(littlestr));
815 littleend = little + SvCUR(littlestr);
822 little = (const unsigned char *)(SvPVX_const(littlestr));
823 littleend = little + SvCUR(littlestr);
825 /* The value of pos we can start at: */
826 previous = BmPREVIOUS(littlestr);
827 big = (const unsigned char *)(SvPVX_const(bigstr));
828 /* The value of pos we can stop at: */
829 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
830 if (previous + start_shift > stop_pos) {
832 stop_pos does not include SvTAIL in the count, so this check is incorrect
833 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
836 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
841 while (pos < previous + start_shift) {
842 if (!(pos += PL_screamnext[pos]))
847 register const unsigned char *s, *x;
848 if (pos >= stop_pos) break;
849 if (big[pos] != first)
851 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
857 if (s == littleend) {
859 if (!last) return (char *)(big+pos);
862 } while ( pos += PL_screamnext[pos] );
864 return (char *)(big+(*old_posp));
866 if (!SvTAIL(littlestr) || (end_shift > 0))
868 /* Ignore the trailing "\n". This code is not microoptimized */
869 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
870 stop_pos = littleend - little; /* Actual littlestr len */
875 && ((stop_pos == 1) ||
876 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
884 Returns true if the leading len bytes of the strings s1 and s2 are the same
885 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
886 match themselves and their opposite case counterparts. Non-cased and non-ASCII
887 range bytes match only themselves.
894 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
896 register const U8 *a = (const U8 *)s1;
897 register const U8 *b = (const U8 *)s2;
899 PERL_ARGS_ASSERT_FOLDEQ;
902 if (*a != *b && *a != PL_fold[*b])
910 =for apidoc foldEQ_locale
912 Returns true if the leading len bytes of the strings s1 and s2 are the same
913 case-insensitively in the current locale; false otherwise.
919 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
922 register const U8 *a = (const U8 *)s1;
923 register const U8 *b = (const U8 *)s2;
925 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
928 if (*a != *b && *a != PL_fold_locale[*b])
935 /* copy a string to a safe spot */
938 =head1 Memory Management
942 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
943 string which is a duplicate of C<pv>. The size of the string is
944 determined by C<strlen()>. The memory allocated for the new string can
945 be freed with the C<Safefree()> function.
951 Perl_savepv(pTHX_ const char *pv)
958 const STRLEN pvlen = strlen(pv)+1;
959 Newx(newaddr, pvlen, char);
960 return (char*)memcpy(newaddr, pv, pvlen);
964 /* same thing but with a known length */
969 Perl's version of what C<strndup()> would be if it existed. Returns a
970 pointer to a newly allocated string which is a duplicate of the first
971 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
972 the new string can be freed with the C<Safefree()> function.
978 Perl_savepvn(pTHX_ const char *pv, register I32 len)
980 register char *newaddr;
983 Newx(newaddr,len+1,char);
984 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
986 /* might not be null terminated */
988 return (char *) CopyD(pv,newaddr,len,char);
991 return (char *) ZeroD(newaddr,len+1,char);
996 =for apidoc savesharedpv
998 A version of C<savepv()> which allocates the duplicate string in memory
999 which is shared between threads.
1004 Perl_savesharedpv(pTHX_ const char *pv)
1006 register char *newaddr;
1011 pvlen = strlen(pv)+1;
1012 newaddr = (char*)PerlMemShared_malloc(pvlen);
1014 return write_no_mem();
1016 return (char*)memcpy(newaddr, pv, pvlen);
1020 =for apidoc savesharedpvn
1022 A version of C<savepvn()> which allocates the duplicate string in memory
1023 which is shared between threads. (With the specific difference that a NULL
1024 pointer is not acceptable)
1029 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1031 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1033 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1036 return write_no_mem();
1038 newaddr[len] = '\0';
1039 return (char*)memcpy(newaddr, pv, len);
1043 =for apidoc savesvpv
1045 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1046 the passed in SV using C<SvPV()>
1052 Perl_savesvpv(pTHX_ SV *sv)
1055 const char * const pv = SvPV_const(sv, len);
1056 register char *newaddr;
1058 PERL_ARGS_ASSERT_SAVESVPV;
1061 Newx(newaddr,len,char);
1062 return (char *) CopyD(pv,newaddr,len,char);
1066 /* the SV for Perl_form() and mess() is not kept in an arena */
1076 return newSVpvs_flags("", SVs_TEMP);
1081 /* Create as PVMG now, to avoid any upgrading later */
1083 Newxz(any, 1, XPVMG);
1084 SvFLAGS(sv) = SVt_PVMG;
1085 SvANY(sv) = (void*)any;
1087 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1092 #if defined(PERL_IMPLICIT_CONTEXT)
1094 Perl_form_nocontext(const char* pat, ...)
1099 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1100 va_start(args, pat);
1101 retval = vform(pat, &args);
1105 #endif /* PERL_IMPLICIT_CONTEXT */
1108 =head1 Miscellaneous Functions
1111 Takes a sprintf-style format pattern and conventional
1112 (non-SV) arguments and returns the formatted string.
1114 (char *) Perl_form(pTHX_ const char* pat, ...)
1116 can be used any place a string (char *) is required:
1118 char * s = Perl_form("%d.%d",major,minor);
1120 Uses a single private buffer so if you want to format several strings you
1121 must explicitly copy the earlier strings away (and free the copies when you
1128 Perl_form(pTHX_ const char* pat, ...)
1132 PERL_ARGS_ASSERT_FORM;
1133 va_start(args, pat);
1134 retval = vform(pat, &args);
1140 Perl_vform(pTHX_ const char *pat, va_list *args)
1142 SV * const sv = mess_alloc();
1143 PERL_ARGS_ASSERT_VFORM;
1144 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1149 =for apidoc Am|SV *|mess|const char *pat|...
1151 Take a sprintf-style format pattern and argument list. These are used to
1152 generate a string message. If the message does not end with a newline,
1153 then it will be extended with some indication of the current location
1154 in the code, as described for L</mess_sv>.
1156 Normally, the resulting message is returned in a new mortal SV.
1157 During global destruction a single SV may be shared between uses of
1163 #if defined(PERL_IMPLICIT_CONTEXT)
1165 Perl_mess_nocontext(const char *pat, ...)
1170 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1171 va_start(args, pat);
1172 retval = vmess(pat, &args);
1176 #endif /* PERL_IMPLICIT_CONTEXT */
1179 Perl_mess(pTHX_ const char *pat, ...)
1183 PERL_ARGS_ASSERT_MESS;
1184 va_start(args, pat);
1185 retval = vmess(pat, &args);
1191 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1194 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1196 PERL_ARGS_ASSERT_CLOSEST_COP;
1198 if (!o || o == PL_op)
1201 if (o->op_flags & OPf_KIDS) {
1203 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1206 /* If the OP_NEXTSTATE has been optimised away we can still use it
1207 * the get the file and line number. */
1209 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1210 cop = (const COP *)kid;
1212 /* Keep searching, and return when we've found something. */
1214 new_cop = closest_cop(cop, kid);
1220 /* Nothing found. */
1226 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1228 Expands a message, intended for the user, to include an indication of
1229 the current location in the code, if the message does not already appear
1232 C<basemsg> is the initial message or object. If it is a reference, it
1233 will be used as-is and will be the result of this function. Otherwise it
1234 is used as a string, and if it already ends with a newline, it is taken
1235 to be complete, and the result of this function will be the same string.
1236 If the message does not end with a newline, then a segment such as C<at
1237 foo.pl line 37> will be appended, and possibly other clauses indicating
1238 the current state of execution. The resulting message will end with a
1241 Normally, the resulting message is returned in a new mortal SV.
1242 During global destruction a single SV may be shared between uses of this
1243 function. If C<consume> is true, then the function is permitted (but not
1244 required) to modify and return C<basemsg> instead of allocating a new SV.
1250 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1255 PERL_ARGS_ASSERT_MESS_SV;
1257 if (SvROK(basemsg)) {
1263 sv_setsv(sv, basemsg);
1268 if (SvPOK(basemsg) && consume) {
1273 sv_copypv(sv, basemsg);
1276 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1278 * Try and find the file and line for PL_op. This will usually be
1279 * PL_curcop, but it might be a cop that has been optimised away. We
1280 * can try to find such a cop by searching through the optree starting
1281 * from the sibling of PL_curcop.
1284 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1289 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1290 OutCopFILE(cop), (IV)CopLINE(cop));
1291 /* Seems that GvIO() can be untrustworthy during global destruction. */
1292 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1293 && IoLINES(GvIOp(PL_last_in_gv)))
1295 const bool line_mode = (RsSIMPLE(PL_rs) &&
1296 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1297 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1298 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1299 line_mode ? "line" : "chunk",
1300 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1303 sv_catpvs(sv, " during global destruction");
1304 sv_catpvs(sv, ".\n");
1310 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1312 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1313 argument list. These are used to generate a string message. If the
1314 message does not end with a newline, then it will be extended with
1315 some indication of the current location in the code, as described for
1318 Normally, the resulting message is returned in a new mortal SV.
1319 During global destruction a single SV may be shared between uses of
1326 Perl_vmess(pTHX_ const char *pat, va_list *args)
1329 SV * const sv = mess_alloc();
1331 PERL_ARGS_ASSERT_VMESS;
1333 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1334 return mess_sv(sv, 1);
1338 Perl_write_to_stderr(pTHX_ SV* msv)
1344 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1346 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1347 && (io = GvIO(PL_stderrgv))
1348 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1355 SAVESPTR(PL_stderrgv);
1358 PUSHSTACKi(PERLSI_MAGIC);
1362 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1365 call_method("PRINT", G_SCALAR);
1373 /* SFIO can really mess with your errno */
1376 PerlIO * const serr = Perl_error_log;
1378 const char* message = SvPVx_const(msv, msglen);
1380 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1381 (void)PerlIO_flush(serr);
1389 =head1 Warning and Dieing
1392 /* Common code used in dieing and warning */
1395 S_with_queued_errors(pTHX_ SV *ex)
1397 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1398 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1399 sv_catsv(PL_errors, ex);
1400 ex = sv_mortalcopy(PL_errors);
1401 SvCUR_set(PL_errors, 0);
1407 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1413 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1414 /* sv_2cv might call Perl_croak() or Perl_warner() */
1415 SV * const oldhook = *hook;
1423 cv = sv_2cv(oldhook, &stash, &gv, 0);
1425 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1435 exarg = newSVsv(ex);
1436 SvREADONLY_on(exarg);
1439 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1443 call_sv(MUTABLE_SV(cv), G_DISCARD);
1452 =for apidoc Am|OP *|die_sv|SV *baseex
1454 Behaves the same as L</croak_sv>, except for the return type.
1455 It should be used only where the C<OP *> return type is required.
1456 The function never actually returns.
1462 Perl_die_sv(pTHX_ SV *baseex)
1464 PERL_ARGS_ASSERT_DIE_SV;
1471 =for apidoc Am|OP *|die|const char *pat|...
1473 Behaves the same as L</croak>, except for the return type.
1474 It should be used only where the C<OP *> return type is required.
1475 The function never actually returns.
1480 #if defined(PERL_IMPLICIT_CONTEXT)
1482 Perl_die_nocontext(const char* pat, ...)
1486 va_start(args, pat);
1492 #endif /* PERL_IMPLICIT_CONTEXT */
1495 Perl_die(pTHX_ const char* pat, ...)
1498 va_start(args, pat);
1506 =for apidoc Am|void|croak_sv|SV *baseex
1508 This is an XS interface to Perl's C<die> function.
1510 C<baseex> is the error message or object. If it is a reference, it
1511 will be used as-is. Otherwise it is used as a string, and if it does
1512 not end with a newline then it will be extended with some indication of
1513 the current location in the code, as described for L</mess_sv>.
1515 The error message or object will be used as an exception, by default
1516 returning control to the nearest enclosing C<eval>, but subject to
1517 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1518 function never returns normally.
1520 To die with a simple string message, the L</croak> function may be
1527 Perl_croak_sv(pTHX_ SV *baseex)
1529 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1530 PERL_ARGS_ASSERT_CROAK_SV;
1531 invoke_exception_hook(ex, FALSE);
1536 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1538 This is an XS interface to Perl's C<die> function.
1540 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1541 argument list. These are used to generate a string message. If the
1542 message does not end with a newline, then it will be extended with
1543 some indication of the current location in the code, as described for
1546 The error message will be used as an exception, by default
1547 returning control to the nearest enclosing C<eval>, but subject to
1548 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1549 function never returns normally.
1551 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1552 (C<$@>) will be used as an error message or object instead of building an
1553 error message from arguments. If you want to throw a non-string object,
1554 or build an error message in an SV yourself, it is preferable to use
1555 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1561 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1563 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1564 invoke_exception_hook(ex, FALSE);
1569 =for apidoc Am|void|croak|const char *pat|...
1571 This is an XS interface to Perl's C<die> function.
1573 Take a sprintf-style format pattern and argument list. These are used to
1574 generate a string message. If the message does not end with a newline,
1575 then it will be extended with some indication of the current location
1576 in the code, as described for L</mess_sv>.
1578 The error message will be used as an exception, by default
1579 returning control to the nearest enclosing C<eval>, but subject to
1580 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1581 function never returns normally.
1583 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1584 (C<$@>) will be used as an error message or object instead of building an
1585 error message from arguments. If you want to throw a non-string object,
1586 or build an error message in an SV yourself, it is preferable to use
1587 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1592 #if defined(PERL_IMPLICIT_CONTEXT)
1594 Perl_croak_nocontext(const char *pat, ...)
1598 va_start(args, pat);
1603 #endif /* PERL_IMPLICIT_CONTEXT */
1606 Perl_croak(pTHX_ const char *pat, ...)
1609 va_start(args, pat);
1616 =for apidoc Am|void|warn_sv|SV *baseex
1618 This is an XS interface to Perl's C<warn> function.
1620 C<baseex> is the error message or object. If it is a reference, it
1621 will be used as-is. Otherwise it is used as a string, and if it does
1622 not end with a newline then it will be extended with some indication of
1623 the current location in the code, as described for L</mess_sv>.
1625 The error message or object will by default be written to standard error,
1626 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1628 To warn with a simple string message, the L</warn> function may be
1635 Perl_warn_sv(pTHX_ SV *baseex)
1637 SV *ex = mess_sv(baseex, 0);
1638 PERL_ARGS_ASSERT_WARN_SV;
1639 if (!invoke_exception_hook(ex, TRUE))
1640 write_to_stderr(ex);
1644 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1646 This is an XS interface to Perl's C<warn> function.
1648 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1649 argument list. These are used to generate a string message. If the
1650 message does not end with a newline, then it will be extended with
1651 some indication of the current location in the code, as described for
1654 The error message or object will by default be written to standard error,
1655 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1657 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1663 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1665 SV *ex = vmess(pat, args);
1666 PERL_ARGS_ASSERT_VWARN;
1667 if (!invoke_exception_hook(ex, TRUE))
1668 write_to_stderr(ex);
1672 =for apidoc Am|void|warn|const char *pat|...
1674 This is an XS interface to Perl's C<warn> function.
1676 Take a sprintf-style format pattern and argument list. These are used to
1677 generate a string message. If the message does not end with a newline,
1678 then it will be extended with some indication of the current location
1679 in the code, as described for L</mess_sv>.
1681 The error message or object will by default be written to standard error,
1682 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1684 Unlike with L</croak>, C<pat> is not permitted to be null.
1689 #if defined(PERL_IMPLICIT_CONTEXT)
1691 Perl_warn_nocontext(const char *pat, ...)
1695 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1696 va_start(args, pat);
1700 #endif /* PERL_IMPLICIT_CONTEXT */
1703 Perl_warn(pTHX_ const char *pat, ...)
1706 PERL_ARGS_ASSERT_WARN;
1707 va_start(args, pat);
1712 #if defined(PERL_IMPLICIT_CONTEXT)
1714 Perl_warner_nocontext(U32 err, const char *pat, ...)
1718 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1719 va_start(args, pat);
1720 vwarner(err, pat, &args);
1723 #endif /* PERL_IMPLICIT_CONTEXT */
1726 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1728 PERL_ARGS_ASSERT_CK_WARNER_D;
1730 if (Perl_ckwarn_d(aTHX_ err)) {
1732 va_start(args, pat);
1733 vwarner(err, pat, &args);
1739 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1741 PERL_ARGS_ASSERT_CK_WARNER;
1743 if (Perl_ckwarn(aTHX_ err)) {
1745 va_start(args, pat);
1746 vwarner(err, pat, &args);
1752 Perl_warner(pTHX_ U32 err, const char* pat,...)
1755 PERL_ARGS_ASSERT_WARNER;
1756 va_start(args, pat);
1757 vwarner(err, pat, &args);
1762 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1765 PERL_ARGS_ASSERT_VWARNER;
1766 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1767 SV * const msv = vmess(pat, args);
1769 invoke_exception_hook(msv, FALSE);
1773 Perl_vwarn(aTHX_ pat, args);
1777 /* implements the ckWARN? macros */
1780 Perl_ckwarn(pTHX_ U32 w)
1783 /* If lexical warnings have not been set, use $^W. */
1785 return PL_dowarn & G_WARN_ON;
1787 return ckwarn_common(w);
1790 /* implements the ckWARN?_d macro */
1793 Perl_ckwarn_d(pTHX_ U32 w)
1796 /* If lexical warnings have not been set then default classes warn. */
1800 return ckwarn_common(w);
1804 S_ckwarn_common(pTHX_ U32 w)
1806 if (PL_curcop->cop_warnings == pWARN_ALL)
1809 if (PL_curcop->cop_warnings == pWARN_NONE)
1812 /* Check the assumption that at least the first slot is non-zero. */
1813 assert(unpackWARN1(w));
1815 /* Check the assumption that it is valid to stop as soon as a zero slot is
1817 if (!unpackWARN2(w)) {
1818 assert(!unpackWARN3(w));
1819 assert(!unpackWARN4(w));
1820 } else if (!unpackWARN3(w)) {
1821 assert(!unpackWARN4(w));
1824 /* Right, dealt with all the special cases, which are implemented as non-
1825 pointers, so there is a pointer to a real warnings mask. */
1827 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1829 } while (w >>= WARNshift);
1834 /* Set buffer=NULL to get a new one. */
1836 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1838 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
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);
1851 /* since we've already done strlen() for both nam and val
1852 * we can use that info to make things faster than
1853 * sprintf(s, "%s=%s", nam, val)
1855 #define my_setenv_format(s, nam, nlen, val, vlen) \
1856 Copy(nam, s, nlen, char); \
1858 Copy(val, s+(nlen+1), vlen, char); \
1859 *(s+(nlen+1+vlen)) = '\0'
1861 #ifdef USE_ENVIRON_ARRAY
1862 /* VMS' my_setenv() is in vms.c */
1863 #if !defined(WIN32) && !defined(NETWARE)
1865 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1869 /* only parent thread can modify process environment */
1870 if (PL_curinterp == aTHX)
1873 #ifndef PERL_USE_SAFE_PUTENV
1874 if (!PL_use_safe_putenv) {
1875 /* most putenv()s leak, so we manipulate environ directly */
1877 register const I32 len = strlen(nam);
1880 /* where does it go? */
1881 for (i = 0; environ[i]; i++) {
1882 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1886 if (environ == PL_origenviron) { /* need we copy environment? */
1892 while (environ[max])
1894 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1895 for (j=0; j<max; j++) { /* copy environment */
1896 const int len = strlen(environ[j]);
1897 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1898 Copy(environ[j], tmpenv[j], len+1, char);
1901 environ = tmpenv; /* tell exec where it is now */
1904 safesysfree(environ[i]);
1905 while (environ[i]) {
1906 environ[i] = environ[i+1];
1911 if (!environ[i]) { /* does not exist yet */
1912 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1913 environ[i+1] = NULL; /* make sure it's null terminated */
1916 safesysfree(environ[i]);
1920 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1921 /* all that work just for this */
1922 my_setenv_format(environ[i], nam, nlen, val, vlen);
1925 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1926 # if defined(HAS_UNSETENV)
1928 (void)unsetenv(nam);
1930 (void)setenv(nam, val, 1);
1932 # else /* ! HAS_UNSETENV */
1933 (void)setenv(nam, val, 1);
1934 # endif /* HAS_UNSETENV */
1936 # if defined(HAS_UNSETENV)
1938 (void)unsetenv(nam);
1940 const int nlen = strlen(nam);
1941 const int vlen = strlen(val);
1942 char * const new_env =
1943 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1944 my_setenv_format(new_env, nam, nlen, val, vlen);
1945 (void)putenv(new_env);
1947 # else /* ! HAS_UNSETENV */
1949 const int nlen = strlen(nam);
1955 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1956 /* all that work just for this */
1957 my_setenv_format(new_env, nam, nlen, val, vlen);
1958 (void)putenv(new_env);
1959 # endif /* HAS_UNSETENV */
1960 # endif /* __CYGWIN__ */
1961 #ifndef PERL_USE_SAFE_PUTENV
1967 #else /* WIN32 || NETWARE */
1970 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1973 register char *envstr;
1974 const int nlen = strlen(nam);
1981 Newx(envstr, nlen+vlen+2, char);
1982 my_setenv_format(envstr, nam, nlen, val, vlen);
1983 (void)PerlEnv_putenv(envstr);
1987 #endif /* WIN32 || NETWARE */
1989 #endif /* !VMS && !EPOC*/
1991 #ifdef UNLINK_ALL_VERSIONS
1993 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1997 PERL_ARGS_ASSERT_UNLNK;
1999 while (PerlLIO_unlink(f) >= 0)
2001 return retries ? 0 : -1;
2005 /* this is a drop-in replacement for bcopy() */
2006 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2008 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2010 char * const retval = to;
2012 PERL_ARGS_ASSERT_MY_BCOPY;
2014 if (from - to >= 0) {
2022 *(--to) = *(--from);
2028 /* this is a drop-in replacement for memset() */
2031 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2033 char * const retval = loc;
2035 PERL_ARGS_ASSERT_MY_MEMSET;
2043 /* this is a drop-in replacement for bzero() */
2044 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2046 Perl_my_bzero(register char *loc, register I32 len)
2048 char * const retval = loc;
2050 PERL_ARGS_ASSERT_MY_BZERO;
2058 /* this is a drop-in replacement for memcmp() */
2059 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2061 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2063 register const U8 *a = (const U8 *)s1;
2064 register const U8 *b = (const U8 *)s2;
2067 PERL_ARGS_ASSERT_MY_MEMCMP;
2070 if ((tmp = *a++ - *b++))
2075 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2078 /* This vsprintf replacement should generally never get used, since
2079 vsprintf was available in both System V and BSD 2.11. (There may
2080 be some cross-compilation or embedded set-ups where it is needed,
2083 If you encounter a problem in this function, it's probably a symptom
2084 that Configure failed to detect your system's vprintf() function.
2085 See the section on "item vsprintf" in the INSTALL file.
2087 This version may compile on systems with BSD-ish <stdio.h>,
2088 but probably won't on others.
2091 #ifdef USE_CHAR_VSPRINTF
2096 vsprintf(char *dest, const char *pat, void *args)
2100 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2101 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2102 FILE_cnt(&fakebuf) = 32767;
2104 /* These probably won't compile -- If you really need
2105 this, you'll have to figure out some other method. */
2106 fakebuf._ptr = dest;
2107 fakebuf._cnt = 32767;
2112 fakebuf._flag = _IOWRT|_IOSTRG;
2113 _doprnt(pat, args, &fakebuf); /* what a kludge */
2114 #if defined(STDIO_PTR_LVALUE)
2115 *(FILE_ptr(&fakebuf)++) = '\0';
2117 /* PerlIO has probably #defined away fputc, but we want it here. */
2119 # undef fputc /* XXX Should really restore it later */
2121 (void)fputc('\0', &fakebuf);
2123 #ifdef USE_CHAR_VSPRINTF
2126 return 0; /* perl doesn't use return value */
2130 #endif /* HAS_VPRINTF */
2133 #if BYTEORDER != 0x4321
2135 Perl_my_swap(pTHX_ short s)
2137 #if (BYTEORDER & 1) == 0
2140 result = ((s & 255) << 8) + ((s >> 8) & 255);
2148 Perl_my_htonl(pTHX_ long l)
2152 char c[sizeof(long)];
2155 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2156 #if BYTEORDER == 0x12345678
2159 u.c[0] = (l >> 24) & 255;
2160 u.c[1] = (l >> 16) & 255;
2161 u.c[2] = (l >> 8) & 255;
2165 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2166 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2171 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2172 u.c[o & 0xf] = (l >> s) & 255;
2180 Perl_my_ntohl(pTHX_ long l)
2184 char c[sizeof(long)];
2187 #if BYTEORDER == 0x1234
2188 u.c[0] = (l >> 24) & 255;
2189 u.c[1] = (l >> 16) & 255;
2190 u.c[2] = (l >> 8) & 255;
2194 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2195 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2202 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2203 l |= (u.c[o & 0xf] & 255) << s;
2210 #endif /* BYTEORDER != 0x4321 */
2214 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2215 * If these functions are defined,
2216 * the BYTEORDER is neither 0x1234 nor 0x4321.
2217 * However, this is not assumed.
2221 #define HTOLE(name,type) \
2223 name (register type n) \
2227 char c[sizeof(type)]; \
2230 register U32 s = 0; \
2231 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2232 u.c[i] = (n >> s) & 0xFF; \
2237 #define LETOH(name,type) \
2239 name (register type n) \
2243 char c[sizeof(type)]; \
2246 register U32 s = 0; \
2249 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2250 n |= ((type)(u.c[i] & 0xFF)) << s; \
2256 * Big-endian byte order functions.
2259 #define HTOBE(name,type) \
2261 name (register type n) \
2265 char c[sizeof(type)]; \
2268 register U32 s = 8*(sizeof(u.c)-1); \
2269 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2270 u.c[i] = (n >> s) & 0xFF; \
2275 #define BETOH(name,type) \
2277 name (register type n) \
2281 char c[sizeof(type)]; \
2284 register U32 s = 8*(sizeof(u.c)-1); \
2287 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2288 n |= ((type)(u.c[i] & 0xFF)) << s; \
2294 * If we just can't do it...
2297 #define NOT_AVAIL(name,type) \
2299 name (register type n) \
2301 Perl_croak_nocontext(#name "() not available"); \
2302 return n; /* not reached */ \
2306 #if defined(HAS_HTOVS) && !defined(htovs)
2309 #if defined(HAS_HTOVL) && !defined(htovl)
2312 #if defined(HAS_VTOHS) && !defined(vtohs)
2315 #if defined(HAS_VTOHL) && !defined(vtohl)
2319 #ifdef PERL_NEED_MY_HTOLE16
2321 HTOLE(Perl_my_htole16,U16)
2323 NOT_AVAIL(Perl_my_htole16,U16)
2326 #ifdef PERL_NEED_MY_LETOH16
2328 LETOH(Perl_my_letoh16,U16)
2330 NOT_AVAIL(Perl_my_letoh16,U16)
2333 #ifdef PERL_NEED_MY_HTOBE16
2335 HTOBE(Perl_my_htobe16,U16)
2337 NOT_AVAIL(Perl_my_htobe16,U16)
2340 #ifdef PERL_NEED_MY_BETOH16
2342 BETOH(Perl_my_betoh16,U16)
2344 NOT_AVAIL(Perl_my_betoh16,U16)
2348 #ifdef PERL_NEED_MY_HTOLE32
2350 HTOLE(Perl_my_htole32,U32)
2352 NOT_AVAIL(Perl_my_htole32,U32)
2355 #ifdef PERL_NEED_MY_LETOH32
2357 LETOH(Perl_my_letoh32,U32)
2359 NOT_AVAIL(Perl_my_letoh32,U32)
2362 #ifdef PERL_NEED_MY_HTOBE32
2364 HTOBE(Perl_my_htobe32,U32)
2366 NOT_AVAIL(Perl_my_htobe32,U32)
2369 #ifdef PERL_NEED_MY_BETOH32
2371 BETOH(Perl_my_betoh32,U32)
2373 NOT_AVAIL(Perl_my_betoh32,U32)
2377 #ifdef PERL_NEED_MY_HTOLE64
2379 HTOLE(Perl_my_htole64,U64)
2381 NOT_AVAIL(Perl_my_htole64,U64)
2384 #ifdef PERL_NEED_MY_LETOH64
2386 LETOH(Perl_my_letoh64,U64)
2388 NOT_AVAIL(Perl_my_letoh64,U64)
2391 #ifdef PERL_NEED_MY_HTOBE64
2393 HTOBE(Perl_my_htobe64,U64)
2395 NOT_AVAIL(Perl_my_htobe64,U64)
2398 #ifdef PERL_NEED_MY_BETOH64
2400 BETOH(Perl_my_betoh64,U64)
2402 NOT_AVAIL(Perl_my_betoh64,U64)
2406 #ifdef PERL_NEED_MY_HTOLES
2407 HTOLE(Perl_my_htoles,short)
2409 #ifdef PERL_NEED_MY_LETOHS
2410 LETOH(Perl_my_letohs,short)
2412 #ifdef PERL_NEED_MY_HTOBES
2413 HTOBE(Perl_my_htobes,short)
2415 #ifdef PERL_NEED_MY_BETOHS
2416 BETOH(Perl_my_betohs,short)
2419 #ifdef PERL_NEED_MY_HTOLEI
2420 HTOLE(Perl_my_htolei,int)
2422 #ifdef PERL_NEED_MY_LETOHI
2423 LETOH(Perl_my_letohi,int)
2425 #ifdef PERL_NEED_MY_HTOBEI
2426 HTOBE(Perl_my_htobei,int)
2428 #ifdef PERL_NEED_MY_BETOHI
2429 BETOH(Perl_my_betohi,int)
2432 #ifdef PERL_NEED_MY_HTOLEL
2433 HTOLE(Perl_my_htolel,long)
2435 #ifdef PERL_NEED_MY_LETOHL
2436 LETOH(Perl_my_letohl,long)
2438 #ifdef PERL_NEED_MY_HTOBEL
2439 HTOBE(Perl_my_htobel,long)
2441 #ifdef PERL_NEED_MY_BETOHL
2442 BETOH(Perl_my_betohl,long)
2446 Perl_my_swabn(void *ptr, int n)
2448 register char *s = (char *)ptr;
2449 register char *e = s + (n-1);
2452 PERL_ARGS_ASSERT_MY_SWABN;
2454 for (n /= 2; n > 0; s++, e--, n--) {
2462 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2464 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2467 register I32 This, that;
2473 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2475 PERL_FLUSHALL_FOR_CHILD;
2476 This = (*mode == 'w');
2480 taint_proper("Insecure %s%s", "EXEC");
2482 if (PerlProc_pipe(p) < 0)
2484 /* Try for another pipe pair for error return */
2485 if (PerlProc_pipe(pp) >= 0)
2487 while ((pid = PerlProc_fork()) < 0) {
2488 if (errno != EAGAIN) {
2489 PerlLIO_close(p[This]);
2490 PerlLIO_close(p[that]);
2492 PerlLIO_close(pp[0]);
2493 PerlLIO_close(pp[1]);
2497 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2506 /* Close parent's end of error status pipe (if any) */
2508 PerlLIO_close(pp[0]);
2509 #if defined(HAS_FCNTL) && defined(F_SETFD)
2510 /* Close error pipe automatically if exec works */
2511 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2514 /* Now dup our end of _the_ pipe to right position */
2515 if (p[THIS] != (*mode == 'r')) {
2516 PerlLIO_dup2(p[THIS], *mode == 'r');
2517 PerlLIO_close(p[THIS]);
2518 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2519 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2522 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2523 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2524 /* No automatic close - do it by hand */
2531 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2537 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2543 do_execfree(); /* free any memory malloced by child on fork */
2545 PerlLIO_close(pp[1]);
2546 /* Keep the lower of the two fd numbers */
2547 if (p[that] < p[This]) {
2548 PerlLIO_dup2(p[This], p[that]);
2549 PerlLIO_close(p[This]);
2553 PerlLIO_close(p[that]); /* close child's end of pipe */
2555 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2556 SvUPGRADE(sv,SVt_IV);
2558 PL_forkprocess = pid;
2559 /* If we managed to get status pipe check for exec fail */
2560 if (did_pipes && pid > 0) {
2565 while (n < sizeof(int)) {
2566 n1 = PerlLIO_read(pp[0],
2567 (void*)(((char*)&errkid)+n),
2573 PerlLIO_close(pp[0]);
2575 if (n) { /* Error */
2577 PerlLIO_close(p[This]);
2578 if (n != sizeof(int))
2579 Perl_croak(aTHX_ "panic: kid popen errno read");
2581 pid2 = wait4pid(pid, &status, 0);
2582 } while (pid2 == -1 && errno == EINTR);
2583 errno = errkid; /* Propagate errno from kid */
2588 PerlLIO_close(pp[0]);
2589 return PerlIO_fdopen(p[This], mode);
2591 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2592 return my_syspopen4(aTHX_ NULL, mode, n, args);
2594 Perl_croak(aTHX_ "List form of piped open not implemented");
2595 return (PerlIO *) NULL;
2600 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2601 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2603 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2607 register I32 This, that;
2610 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2614 PERL_ARGS_ASSERT_MY_POPEN;
2616 PERL_FLUSHALL_FOR_CHILD;
2619 return my_syspopen(aTHX_ cmd,mode);
2622 This = (*mode == 'w');
2624 if (doexec && PL_tainting) {
2626 taint_proper("Insecure %s%s", "EXEC");
2628 if (PerlProc_pipe(p) < 0)
2630 if (doexec && PerlProc_pipe(pp) >= 0)
2632 while ((pid = PerlProc_fork()) < 0) {
2633 if (errno != EAGAIN) {
2634 PerlLIO_close(p[This]);
2635 PerlLIO_close(p[that]);
2637 PerlLIO_close(pp[0]);
2638 PerlLIO_close(pp[1]);
2641 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2644 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2655 PerlLIO_close(pp[0]);
2656 #if defined(HAS_FCNTL) && defined(F_SETFD)
2657 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2660 if (p[THIS] != (*mode == 'r')) {
2661 PerlLIO_dup2(p[THIS], *mode == 'r');
2662 PerlLIO_close(p[THIS]);
2663 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2664 PerlLIO_close(p[THAT]);
2667 PerlLIO_close(p[THAT]);
2670 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2677 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2682 /* may or may not use the shell */
2683 do_exec3(cmd, pp[1], did_pipes);
2686 #endif /* defined OS2 */
2688 #ifdef PERLIO_USING_CRLF
2689 /* Since we circumvent IO layers when we manipulate low-level
2690 filedescriptors directly, need to manually switch to the
2691 default, binary, low-level mode; see PerlIOBuf_open(). */
2692 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2695 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2696 SvREADONLY_off(GvSV(tmpgv));
2697 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2698 SvREADONLY_on(GvSV(tmpgv));
2700 #ifdef THREADS_HAVE_PIDS
2701 PL_ppid = (IV)getppid();
2704 #ifdef PERL_USES_PL_PIDSTATUS
2705 hv_clear(PL_pidstatus); /* we have no children */
2711 do_execfree(); /* free any memory malloced by child on vfork */
2713 PerlLIO_close(pp[1]);
2714 if (p[that] < p[This]) {
2715 PerlLIO_dup2(p[This], p[that]);
2716 PerlLIO_close(p[This]);
2720 PerlLIO_close(p[that]);
2722 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2723 SvUPGRADE(sv,SVt_IV);
2725 PL_forkprocess = pid;
2726 if (did_pipes && pid > 0) {
2731 while (n < sizeof(int)) {
2732 n1 = PerlLIO_read(pp[0],
2733 (void*)(((char*)&errkid)+n),
2739 PerlLIO_close(pp[0]);
2741 if (n) { /* Error */
2743 PerlLIO_close(p[This]);
2744 if (n != sizeof(int))
2745 Perl_croak(aTHX_ "panic: kid popen errno read");
2747 pid2 = wait4pid(pid, &status, 0);
2748 } while (pid2 == -1 && errno == EINTR);
2749 errno = errkid; /* Propagate errno from kid */
2754 PerlLIO_close(pp[0]);
2755 return PerlIO_fdopen(p[This], mode);
2758 #if defined(atarist) || defined(EPOC)
2761 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2763 PERL_ARGS_ASSERT_MY_POPEN;
2764 PERL_FLUSHALL_FOR_CHILD;
2765 /* Call system's popen() to get a FILE *, then import it.
2766 used 0 for 2nd parameter to PerlIO_importFILE;
2769 return PerlIO_importFILE(popen(cmd, mode), 0);
2773 FILE *djgpp_popen();
2775 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2777 PERL_FLUSHALL_FOR_CHILD;
2778 /* Call system's popen() to get a FILE *, then import it.
2779 used 0 for 2nd parameter to PerlIO_importFILE;
2782 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2785 #if defined(__LIBCATAMOUNT__)
2787 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2795 #endif /* !DOSISH */
2797 /* this is called in parent before the fork() */
2799 Perl_atfork_lock(void)
2802 #if defined(USE_ITHREADS)
2803 /* locks must be held in locking order (if any) */
2805 MUTEX_LOCK(&PL_malloc_mutex);
2811 /* this is called in both parent and child after the fork() */
2813 Perl_atfork_unlock(void)
2816 #if defined(USE_ITHREADS)
2817 /* locks must be released in same order as in atfork_lock() */
2819 MUTEX_UNLOCK(&PL_malloc_mutex);
2828 #if defined(HAS_FORK)
2830 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2835 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2836 * handlers elsewhere in the code */
2841 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2842 Perl_croak_nocontext("fork() not available");
2844 #endif /* HAS_FORK */
2849 Perl_dump_fds(pTHX_ const char *const s)
2854 PERL_ARGS_ASSERT_DUMP_FDS;
2856 PerlIO_printf(Perl_debug_log,"%s", s);
2857 for (fd = 0; fd < 32; fd++) {
2858 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2859 PerlIO_printf(Perl_debug_log," %d",fd);
2861 PerlIO_printf(Perl_debug_log,"\n");
2864 #endif /* DUMP_FDS */
2868 dup2(int oldfd, int newfd)
2870 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2873 PerlLIO_close(newfd);
2874 return fcntl(oldfd, F_DUPFD, newfd);
2876 #define DUP2_MAX_FDS 256
2877 int fdtmp[DUP2_MAX_FDS];
2883 PerlLIO_close(newfd);
2884 /* good enough for low fd's... */
2885 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2886 if (fdx >= DUP2_MAX_FDS) {
2894 PerlLIO_close(fdtmp[--fdx]);
2901 #ifdef HAS_SIGACTION
2904 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2907 struct sigaction act, oact;
2910 /* only "parent" interpreter can diddle signals */
2911 if (PL_curinterp != aTHX)
2912 return (Sighandler_t) SIG_ERR;
2915 act.sa_handler = (void(*)(int))handler;
2916 sigemptyset(&act.sa_mask);
2919 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2920 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2922 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2923 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2924 act.sa_flags |= SA_NOCLDWAIT;
2926 if (sigaction(signo, &act, &oact) == -1)
2927 return (Sighandler_t) SIG_ERR;
2929 return (Sighandler_t) oact.sa_handler;
2933 Perl_rsignal_state(pTHX_ int signo)
2935 struct sigaction oact;
2936 PERL_UNUSED_CONTEXT;
2938 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2939 return (Sighandler_t) SIG_ERR;
2941 return (Sighandler_t) oact.sa_handler;
2945 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2948 struct sigaction act;
2950 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2953 /* only "parent" interpreter can diddle signals */
2954 if (PL_curinterp != aTHX)
2958 act.sa_handler = (void(*)(int))handler;
2959 sigemptyset(&act.sa_mask);
2962 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2963 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2965 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2966 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2967 act.sa_flags |= SA_NOCLDWAIT;
2969 return sigaction(signo, &act, save);
2973 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2977 /* only "parent" interpreter can diddle signals */
2978 if (PL_curinterp != aTHX)
2982 return sigaction(signo, save, (struct sigaction *)NULL);
2985 #else /* !HAS_SIGACTION */
2988 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2990 #if defined(USE_ITHREADS) && !defined(WIN32)
2991 /* only "parent" interpreter can diddle signals */
2992 if (PL_curinterp != aTHX)
2993 return (Sighandler_t) SIG_ERR;
2996 return PerlProc_signal(signo, handler);
3007 Perl_rsignal_state(pTHX_ int signo)
3010 Sighandler_t oldsig;
3012 #if defined(USE_ITHREADS) && !defined(WIN32)
3013 /* only "parent" interpreter can diddle signals */
3014 if (PL_curinterp != aTHX)
3015 return (Sighandler_t) SIG_ERR;
3019 oldsig = PerlProc_signal(signo, sig_trap);
3020 PerlProc_signal(signo, oldsig);
3022 PerlProc_kill(PerlProc_getpid(), signo);
3027 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3029 #if defined(USE_ITHREADS) && !defined(WIN32)
3030 /* only "parent" interpreter can diddle signals */
3031 if (PL_curinterp != aTHX)
3034 *save = PerlProc_signal(signo, handler);
3035 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3039 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3041 #if defined(USE_ITHREADS) && !defined(WIN32)
3042 /* only "parent" interpreter can diddle signals */
3043 if (PL_curinterp != aTHX)
3046 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3049 #endif /* !HAS_SIGACTION */
3050 #endif /* !PERL_MICRO */
3052 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3053 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3055 Perl_my_pclose(pTHX_ PerlIO *ptr)
3058 Sigsave_t hstat, istat, qstat;
3066 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
3067 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3069 *svp = &PL_sv_undef;
3071 if (pid == -1) { /* Opened by popen. */
3072 return my_syspclose(ptr);
3075 close_failed = (PerlIO_close(ptr) == EOF);
3078 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
3081 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3082 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3083 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3086 pid2 = wait4pid(pid, &status, 0);
3087 } while (pid2 == -1 && errno == EINTR);
3089 rsignal_restore(SIGHUP, &hstat);
3090 rsignal_restore(SIGINT, &istat);
3091 rsignal_restore(SIGQUIT, &qstat);
3097 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
3100 #if defined(__LIBCATAMOUNT__)
3102 Perl_my_pclose(pTHX_ PerlIO *ptr)
3107 #endif /* !DOSISH */
3109 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3111 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3115 PERL_ARGS_ASSERT_WAIT4PID;
3118 #ifdef PERL_USES_PL_PIDSTATUS
3121 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3122 pid, rather than a string form. */
3123 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3124 if (svp && *svp != &PL_sv_undef) {
3125 *statusp = SvIVX(*svp);
3126 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3134 hv_iterinit(PL_pidstatus);
3135 if ((entry = hv_iternext(PL_pidstatus))) {
3136 SV * const sv = hv_iterval(PL_pidstatus,entry);
3138 const char * const spid = hv_iterkey(entry,&len);
3140 assert (len == sizeof(Pid_t));
3141 memcpy((char *)&pid, spid, len);
3142 *statusp = SvIVX(sv);
3143 /* The hash iterator is currently on this entry, so simply
3144 calling hv_delete would trigger the lazy delete, which on
3145 aggregate does more work, beacuse next call to hv_iterinit()
3146 would spot the flag, and have to call the delete routine,
3147 while in the meantime any new entries can't re-use that
3149 hv_iterinit(PL_pidstatus);
3150 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3157 # ifdef HAS_WAITPID_RUNTIME
3158 if (!HAS_WAITPID_RUNTIME)
3161 result = PerlProc_waitpid(pid,statusp,flags);
3164 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3165 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3168 #ifdef PERL_USES_PL_PIDSTATUS
3169 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3174 Perl_croak(aTHX_ "Can't do waitpid with flags");
3176 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3177 pidgone(result,*statusp);
3183 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3186 if (result < 0 && errno == EINTR) {
3188 errno = EINTR; /* reset in case a signal handler changed $! */
3192 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3194 #ifdef PERL_USES_PL_PIDSTATUS
3196 S_pidgone(pTHX_ Pid_t pid, int status)
3200 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3201 SvUPGRADE(sv,SVt_IV);
3202 SvIV_set(sv, status);
3207 #if defined(atarist) || defined(OS2) || defined(EPOC)
3210 int /* Cannot prototype with I32
3212 my_syspclose(PerlIO *ptr)
3215 Perl_my_pclose(pTHX_ PerlIO *ptr)
3218 /* Needs work for PerlIO ! */
3219 FILE * const f = PerlIO_findFILE(ptr);
3220 const I32 result = pclose(f);
3221 PerlIO_releaseFILE(ptr,f);
3229 Perl_my_pclose(pTHX_ PerlIO *ptr)
3231 /* Needs work for PerlIO ! */
3232 FILE * const f = PerlIO_findFILE(ptr);
3233 I32 result = djgpp_pclose(f);
3234 result = (result << 8) & 0xff00;
3235 PerlIO_releaseFILE(ptr,f);
3240 #define PERL_REPEATCPY_LINEAR 4
3242 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3244 PERL_ARGS_ASSERT_REPEATCPY;
3247 memset(to, *from, count);
3249 register char *p = to;
3250 I32 items, linear, half;
3252 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3253 for (items = 0; items < linear; ++items) {
3254 register const char *q = from;
3256 for (todo = len; todo > 0; todo--)
3261 while (items <= half) {
3262 I32 size = items * len;
3263 memcpy(p, to, size);
3269 memcpy(p, to, (count - items) * len);
3275 Perl_same_dirent(pTHX_ const char *a, const char *b)
3277 char *fa = strrchr(a,'/');
3278 char *fb = strrchr(b,'/');
3281 SV * const tmpsv = sv_newmortal();
3283 PERL_ARGS_ASSERT_SAME_DIRENT;
3296 sv_setpvs(tmpsv, ".");
3298 sv_setpvn(tmpsv, a, fa - a);
3299 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3302 sv_setpvs(tmpsv, ".");
3304 sv_setpvn(tmpsv, b, fb - b);
3305 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3307 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3308 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3310 #endif /* !HAS_RENAME */
3313 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3314 const char *const *const search_ext, I32 flags)
3317 const char *xfound = NULL;
3318 char *xfailed = NULL;
3319 char tmpbuf[MAXPATHLEN];
3324 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3325 # define SEARCH_EXTS ".bat", ".cmd", NULL
3326 # define MAX_EXT_LEN 4
3329 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3330 # define MAX_EXT_LEN 4
3333 # define SEARCH_EXTS ".pl", ".com", NULL
3334 # define MAX_EXT_LEN 4
3336 /* additional extensions to try in each dir if scriptname not found */
3338 static const char *const exts[] = { SEARCH_EXTS };
3339 const char *const *const ext = search_ext ? search_ext : exts;
3340 int extidx = 0, i = 0;
3341 const char *curext = NULL;
3343 PERL_UNUSED_ARG(search_ext);
3344 # define MAX_EXT_LEN 0
3347 PERL_ARGS_ASSERT_FIND_SCRIPT;
3350 * If dosearch is true and if scriptname does not contain path
3351 * delimiters, search the PATH for scriptname.
3353 * If SEARCH_EXTS is also defined, will look for each
3354 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3355 * while searching the PATH.
3357 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3358 * proceeds as follows:
3359 * If DOSISH or VMSISH:
3360 * + look for ./scriptname{,.foo,.bar}
3361 * + search the PATH for scriptname{,.foo,.bar}
3364 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3365 * this will not look in '.' if it's not in the PATH)
3370 # ifdef ALWAYS_DEFTYPES
3371 len = strlen(scriptname);
3372 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3373 int idx = 0, deftypes = 1;
3376 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3379 int idx = 0, deftypes = 1;
3382 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3384 /* The first time through, just add SEARCH_EXTS to whatever we
3385 * already have, so we can check for default file types. */
3387 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3393 if ((strlen(tmpbuf) + strlen(scriptname)
3394 + MAX_EXT_LEN) >= sizeof tmpbuf)
3395 continue; /* don't search dir with too-long name */
3396 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3400 if (strEQ(scriptname, "-"))
3402 if (dosearch) { /* Look in '.' first. */
3403 const char *cur = scriptname;
3405 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3407 if (strEQ(ext[i++],curext)) {
3408 extidx = -1; /* already has an ext */
3413 DEBUG_p(PerlIO_printf(Perl_debug_log,
3414 "Looking for %s\n",cur));
3415 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3416 && !S_ISDIR(PL_statbuf.st_mode)) {
3424 if (cur == scriptname) {
3425 len = strlen(scriptname);
3426 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3428 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3431 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3432 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3437 if (dosearch && !strchr(scriptname, '/')
3439 && !strchr(scriptname, '\\')
3441 && (s = PerlEnv_getenv("PATH")))
3445 bufend = s + strlen(s);
3446 while (s < bufend) {
3447 #if defined(atarist) || defined(DOSISH)
3452 && *s != ';'; len++, s++) {
3453 if (len < sizeof tmpbuf)
3456 if (len < sizeof tmpbuf)
3458 #else /* ! (atarist || DOSISH) */
3459 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3462 #endif /* ! (atarist || DOSISH) */
3465 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3466 continue; /* don't search dir with too-long name */
3468 # if defined(atarist) || defined(DOSISH)
3469 && tmpbuf[len - 1] != '/'
3470 && tmpbuf[len - 1] != '\\'
3473 tmpbuf[len++] = '/';
3474 if (len == 2 && tmpbuf[0] == '.')
3476 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3480 len = strlen(tmpbuf);
3481 if (extidx > 0) /* reset after previous loop */
3485 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3486 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3487 if (S_ISDIR(PL_statbuf.st_mode)) {
3491 } while ( retval < 0 /* not there */
3492 && extidx>=0 && ext[extidx] /* try an extension? */
3493 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3498 if (S_ISREG(PL_statbuf.st_mode)
3499 && cando(S_IRUSR,TRUE,&PL_statbuf)
3500 #if !defined(DOSISH)
3501 && cando(S_IXUSR,TRUE,&PL_statbuf)
3505 xfound = tmpbuf; /* bingo! */
3509 xfailed = savepv(tmpbuf);
3512 if (!xfound && !seen_dot && !xfailed &&
3513 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3514 || S_ISDIR(PL_statbuf.st_mode)))
3516 seen_dot = 1; /* Disable message. */
3518 if (flags & 1) { /* do or die? */
3519 Perl_croak(aTHX_ "Can't %s %s%s%s",
3520 (xfailed ? "execute" : "find"),
3521 (xfailed ? xfailed : scriptname),
3522 (xfailed ? "" : " on PATH"),
3523 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3528 scriptname = xfound;
3530 return (scriptname ? savepv(scriptname) : NULL);
3533 #ifndef PERL_GET_CONTEXT_DEFINED
3536 Perl_get_context(void)
3539 #if defined(USE_ITHREADS)
3540 # ifdef OLD_PTHREADS_API
3542 if (pthread_getspecific(PL_thr_key, &t))
3543 Perl_croak_nocontext("panic: pthread_getspecific");
3546 # ifdef I_MACH_CTHREADS
3547 return (void*)cthread_data(cthread_self());
3549 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3558 Perl_set_context(void *t)
3561 PERL_ARGS_ASSERT_SET_CONTEXT;
3562 #if defined(USE_ITHREADS)
3563 # ifdef I_MACH_CTHREADS
3564 cthread_set_data(cthread_self(), t);
3566 if (pthread_setspecific(PL_thr_key, t))
3567 Perl_croak_nocontext("panic: pthread_setspecific");
3574 #endif /* !PERL_GET_CONTEXT_DEFINED */
3576 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3585 Perl_get_op_names(pTHX)
3587 PERL_UNUSED_CONTEXT;
3588 return (char **)PL_op_name;
3592 Perl_get_op_descs(pTHX)
3594 PERL_UNUSED_CONTEXT;
3595 return (char **)PL_op_desc;
3599 Perl_get_no_modify(pTHX)
3601 PERL_UNUSED_CONTEXT;
3602 return PL_no_modify;
3606 Perl_get_opargs(pTHX)
3608 PERL_UNUSED_CONTEXT;
3609 return (U32 *)PL_opargs;
3613 Perl_get_ppaddr(pTHX)
3616 PERL_UNUSED_CONTEXT;
3617 return (PPADDR_t*)PL_ppaddr;
3620 #ifndef HAS_GETENV_LEN
3622 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3624 char * const env_trans = PerlEnv_getenv(env_elem);
3625 PERL_UNUSED_CONTEXT;
3626 PERL_ARGS_ASSERT_GETENV_LEN;
3628 *len = strlen(env_trans);
3635 Perl_get_vtbl(pTHX_ int vtbl_id)
3637 const MGVTBL* result;
3638 PERL_UNUSED_CONTEXT;
3642 result = &PL_vtbl_sv;
3645 result = &PL_vtbl_env;
3647 case want_vtbl_envelem:
3648 result = &PL_vtbl_envelem;
3651 result = &PL_vtbl_sig;
3653 case want_vtbl_sigelem:
3654 result = &PL_vtbl_sigelem;
3656 case want_vtbl_pack:
3657 result = &PL_vtbl_pack;
3659 case want_vtbl_packelem:
3660 result = &PL_vtbl_packelem;
3662 case want_vtbl_dbline:
3663 result = &PL_vtbl_dbline;
3666 result = &PL_vtbl_isa;
3668 case want_vtbl_isaelem:
3669 result = &PL_vtbl_isaelem;
3671 case want_vtbl_arylen:
3672 result = &PL_vtbl_arylen;
3674 case want_vtbl_mglob:
3675 result = &PL_vtbl_mglob;
3677 case want_vtbl_nkeys:
3678 result = &PL_vtbl_nkeys;
3680 case want_vtbl_taint:
3681 result = &PL_vtbl_taint;
3683 case want_vtbl_substr:
3684 result = &PL_vtbl_substr;
3687 result = &PL_vtbl_vec;
3690 result = &PL_vtbl_pos;
3693 result = &PL_vtbl_bm;
3696 result = &PL_vtbl_fm;
3698 case want_vtbl_uvar:
3699 result = &PL_vtbl_uvar;
3701 case want_vtbl_defelem:
3702 result = &PL_vtbl_defelem;
3704 case want_vtbl_regexp:
3705 result = &PL_vtbl_regexp;
3707 case want_vtbl_regdata:
3708 result = &PL_vtbl_regdata;
3710 case want_vtbl_regdatum:
3711 result = &PL_vtbl_regdatum;
3713 #ifdef USE_LOCALE_COLLATE
3714 case want_vtbl_collxfrm:
3715 result = &PL_vtbl_collxfrm;
3718 case want_vtbl_amagic:
3719 result = &PL_vtbl_amagic;
3721 case want_vtbl_amagicelem:
3722 result = &PL_vtbl_amagicelem;
3724 case want_vtbl_backref:
3725 result = &PL_vtbl_backref;
3727 case want_vtbl_utf8:
3728 result = &PL_vtbl_utf8;
3734 return (MGVTBL*)result;
3738 Perl_my_fflush_all(pTHX)
3740 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3741 return PerlIO_flush(NULL);
3743 # if defined(HAS__FWALK)
3744 extern int fflush(FILE *);
3745 /* undocumented, unprototyped, but very useful BSDism */
3746 extern void _fwalk(int (*)(FILE *));
3750 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3752 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3753 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3755 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3756 open_max = sysconf(_SC_OPEN_MAX);
3759 open_max = FOPEN_MAX;
3762 open_max = OPEN_MAX;
3773 for (i = 0; i < open_max; i++)
3774 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3775 STDIO_STREAM_ARRAY[i]._file < open_max &&
3776 STDIO_STREAM_ARRAY[i]._flag)
3777 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3781 SETERRNO(EBADF,RMS_IFI);
3788 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3790 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3792 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3793 if (ckWARN(WARN_IO)) {
3794 const char * const direction =
3795 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3797 Perl_warner(aTHX_ packWARN(WARN_IO),
3798 "Filehandle %s opened only for %sput",
3801 Perl_warner(aTHX_ packWARN(WARN_IO),
3802 "Filehandle opened only for %sput", direction);
3809 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3811 warn_type = WARN_CLOSED;
3815 warn_type = WARN_UNOPENED;
3818 if (ckWARN(warn_type)) {
3819 const char * const pars =
3820 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3821 const char * const func =
3823 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3824 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3825 op < 0 ? "" : /* handle phoney cases */
3827 const char * const type =
3829 (OP_IS_SOCKET(op) ||
3830 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3831 "socket" : "filehandle");
3832 if (name && *name) {
3833 Perl_warner(aTHX_ packWARN(warn_type),
3834 "%s%s on %s %s %s", func, pars, vile, type, name);
3835 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3837 aTHX_ packWARN(warn_type),
3838 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3843 Perl_warner(aTHX_ packWARN(warn_type),
3844 "%s%s on %s %s", func, pars, vile, type);
3845 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3847 aTHX_ packWARN(warn_type),
3848 "\t(Are you trying to call %s%s on dirhandle?)\n",
3856 /* XXX Add documentation after final interface and behavior is decided */
3857 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
3858 U8 source = *current;
3860 May want to add eg, WARN_REGEX
3864 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
3869 if (! isASCII(source)) {
3870 Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
3873 result = toCTRL(source);
3874 if (! isCNTRL(result)) {
3875 if (source == '{') {
3876 Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
3878 else if (output_warning) {
3881 if (! isALNUM(result)) {
3882 clearer[i++] = '\\';
3884 clearer[i++] = result;
3885 clearer[i++] = '\0';
3887 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
3888 "\"\\c%c\" more clearly written simply as \"%s\"",
3897 /* To workaround core dumps from the uninitialised tm_zone we get the
3898 * system to give us a reasonable struct to copy. This fix means that
3899 * strftime uses the tm_zone and tm_gmtoff values returned by
3900 * localtime(time()). That should give the desired result most of the
3901 * time. But probably not always!
3903 * This does not address tzname aspects of NETaa14816.
3908 # ifndef STRUCT_TM_HASZONE
3909 # define STRUCT_TM_HASZONE
3913 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3914 # ifndef HAS_TM_TM_ZONE
3915 # define HAS_TM_TM_ZONE
3920 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3922 #ifdef HAS_TM_TM_ZONE
3924 const struct tm* my_tm;
3925 PERL_ARGS_ASSERT_INIT_TM;
3927 my_tm = localtime(&now);
3929 Copy(my_tm, ptm, 1, struct tm);
3931 PERL_ARGS_ASSERT_INIT_TM;
3932 PERL_UNUSED_ARG(ptm);
3937 * mini_mktime - normalise struct tm values without the localtime()
3938 * semantics (and overhead) of mktime().
3941 Perl_mini_mktime(pTHX_ struct tm *ptm)
3945 int month, mday, year, jday;
3946 int odd_cent, odd_year;
3947 PERL_UNUSED_CONTEXT;
3949 PERL_ARGS_ASSERT_MINI_MKTIME;
3951 #define DAYS_PER_YEAR 365
3952 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3953 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3954 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3955 #define SECS_PER_HOUR (60*60)
3956 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3957 /* parentheses deliberately absent on these two, otherwise they don't work */
3958 #define MONTH_TO_DAYS 153/5
3959 #define DAYS_TO_MONTH 5/153
3960 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3961 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3962 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3963 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3966 * Year/day algorithm notes:
3968 * With a suitable offset for numeric value of the month, one can find
3969 * an offset into the year by considering months to have 30.6 (153/5) days,
3970 * using integer arithmetic (i.e., with truncation). To avoid too much
3971 * messing about with leap days, we consider January and February to be
3972 * the 13th and 14th month of the previous year. After that transformation,
3973 * we need the month index we use to be high by 1 from 'normal human' usage,
3974 * so the month index values we use run from 4 through 15.
3976 * Given that, and the rules for the Gregorian calendar (leap years are those
3977 * divisible by 4 unless also divisible by 100, when they must be divisible
3978 * by 400 instead), we can simply calculate the number of days since some
3979 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3980 * the days we derive from our month index, and adding in the day of the
3981 * month. The value used here is not adjusted for the actual origin which
3982 * it normally would use (1 January A.D. 1), since we're not exposing it.
3983 * We're only building the value so we can turn around and get the
3984 * normalised values for the year, month, day-of-month, and day-of-year.
3986 * For going backward, we need to bias the value we're using so that we find
3987 * the right year value. (Basically, we don't want the contribution of
3988 * March 1st to the number to apply while deriving the year). Having done
3989 * that, we 'count up' the contribution to the year number by accounting for
3990 * full quadracenturies (400-year periods) with their extra leap days, plus
3991 * the contribution from full centuries (to avoid counting in the lost leap
3992 * days), plus the contribution from full quad-years (to count in the normal
3993 * leap days), plus the leftover contribution from any non-leap years.
3994 * At this point, if we were working with an actual leap day, we'll have 0
3995 * days left over. This is also true for March 1st, however. So, we have
3996 * to special-case that result, and (earlier) keep track of the 'odd'
3997 * century and year contributions. If we got 4 extra centuries in a qcent,
3998 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3999 * Otherwise, we add back in the earlier bias we removed (the 123 from
4000 * figuring in March 1st), find the month index (integer division by 30.6),
4001 * and the remainder is the day-of-month. We then have to convert back to
4002 * 'real' months (including fixing January and February from being 14/15 in
4003 * the previous year to being in the proper year). After that, to get
4004 * tm_yday, we work with the normalised year and get a new yearday value for
4005 * January 1st, which we subtract from the yearday value we had earlier,
4006 * representing the date we've re-built. This is done from January 1
4007 * because tm_yday is 0-origin.
4009 * Since POSIX time routines are only guaranteed to work for times since the
4010 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4011 * applies Gregorian calendar rules even to dates before the 16th century
4012 * doesn't bother me. Besides, you'd need cultural context for a given
4013 * date to know whether it was Julian or Gregorian calendar, and that's
4014 * outside the scope for this routine. Since we convert back based on the
4015 * same rules we used to build the yearday, you'll only get strange results
4016 * for input which needed normalising, or for the 'odd' century years which
4017 * were leap years in the Julian calander but not in the Gregorian one.
4018 * I can live with that.
4020 * This algorithm also fails to handle years before A.D. 1 gracefully, but
4021 * that's still outside the scope for POSIX time manipulation, so I don't
4025 year = 1900 + ptm->tm_year;
4026 month = ptm->tm_mon;
4027 mday = ptm->tm_mday;
4028 /* allow given yday with no month & mday to dominate the result */
4029 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4032 jday = 1 + ptm->tm_yday;
4041 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4042 yearday += month*MONTH_TO_DAYS + mday + jday;
4044 * Note that we don't know when leap-seconds were or will be,
4045 * so we have to trust the user if we get something which looks
4046 * like a sensible leap-second. Wild values for seconds will
4047 * be rationalised, however.
4049 if ((unsigned) ptm->tm_sec <= 60) {
4056 secs += 60 * ptm->tm_min;
4057 secs += SECS_PER_HOUR * ptm->tm_hour;
4059 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4060 /* got negative remainder, but need positive time */
4061 /* back off an extra day to compensate */
4062 yearday += (secs/SECS_PER_DAY)-1;
4063 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4066 yearday += (secs/SECS_PER_DAY);
4067 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4070 else if (secs >= SECS_PER_DAY) {
4071 yearday += (secs/SECS_PER_DAY);
4072 secs %= SECS_PER_DAY;
4074 ptm->tm_hour = secs/SECS_PER_HOUR;
4075 secs %= SECS_PER_HOUR;
4076 ptm->tm_min = secs/60;
4078 ptm->tm_sec += secs;
4079 /* done with time of day effects */
4081 * The algorithm for yearday has (so far) left it high by 428.
4082 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4083 * bias it by 123 while trying to figure out what year it
4084 * really represents. Even with this tweak, the reverse
4085 * translation fails for years before A.D. 0001.
4086 * It would still fail for Feb 29, but we catch that one below.
4088 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
4089 yearday -= YEAR_ADJUST;
4090 year = (yearday / DAYS_PER_QCENT) * 400;
4091 yearday %= DAYS_PER_QCENT;
4092 odd_cent = yearday / DAYS_PER_CENT;
4093 year += odd_cent * 100;
4094 yearday %= DAYS_PER_CENT;
4095 year += (yearday / DAYS_PER_QYEAR) * 4;
4096 yearday %= DAYS_PER_QYEAR;
4097 odd_year = yearday / DAYS_PER_YEAR;
4099 yearday %= DAYS_PER_YEAR;
4100 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4105 yearday += YEAR_ADJUST; /* recover March 1st crock */
4106 month = yearday*DAYS_TO_MONTH;
4107 yearday -= month*MONTH_TO_DAYS;
4108 /* recover other leap-year adjustment */
4117 ptm->tm_year = year - 1900;
4119 ptm->tm_mday = yearday;
4120 ptm->tm_mon = month;
4124 ptm->tm_mon = month - 1;
4126 /* re-build yearday based on Jan 1 to get tm_yday */
4128 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4129 yearday += 14*MONTH_TO_DAYS + 1;
4130 ptm->tm_yday = jday - yearday;
4131 /* fix tm_wday if not overridden by caller */
4132 if ((unsigned)ptm->tm_wday > 6)
4133 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4137 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)
4145 PERL_ARGS_ASSERT_MY_STRFTIME;
4147 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4150 mytm.tm_hour = hour;
4151 mytm.tm_mday = mday;
4153 mytm.tm_year = year;
4154 mytm.tm_wday = wday;
4155 mytm.tm_yday = yday;
4156 mytm.tm_isdst = isdst;
4158 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4159 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4164 #ifdef HAS_TM_TM_GMTOFF
4165 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4167 #ifdef HAS_TM_TM_ZONE
4168 mytm.tm_zone = mytm2.tm_zone;
4173 Newx(buf, buflen, char);
4174 len = strftime(buf, buflen, fmt, &mytm);
4176 ** The following is needed to handle to the situation where
4177 ** tmpbuf overflows. Basically we want to allocate a buffer
4178 ** and try repeatedly. The reason why it is so complicated
4179 ** is that getting a return value of 0 from strftime can indicate
4180 ** one of the following:
4181 ** 1. buffer overflowed,
4182 ** 2. illegal conversion specifier, or
4183 ** 3. the format string specifies nothing to be returned(not
4184 ** an error). This could be because format is an empty string
4185 ** or it specifies %p that yields an empty string in some locale.
4186 ** If there is a better way to make it portable, go ahead by
4189 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4192 /* Possibly buf overflowed - try again with a bigger buf */
4193 const int fmtlen = strlen(fmt);
4194 int bufsize = fmtlen + buflen;
4196 Newx(buf, bufsize, char);
4198 buflen = strftime(buf, bufsize, fmt, &mytm);
4199 if (buflen > 0 && buflen < bufsize)
4201 /* heuristic to prevent out-of-memory errors */
4202 if (bufsize > 100*fmtlen) {
4208 Renew(buf, bufsize, char);
4213 Perl_croak(aTHX_ "panic: no strftime");
4219 #define SV_CWD_RETURN_UNDEF \
4220 sv_setsv(sv, &PL_sv_undef); \
4223 #define SV_CWD_ISDOT(dp) \
4224 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4225 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4228 =head1 Miscellaneous Functions
4230 =for apidoc getcwd_sv
4232 Fill the sv with current working directory
4237 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4238 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4239 * getcwd(3) if available
4240 * Comments from the orignal:
4241 * This is a faster version of getcwd. It's also more dangerous
4242 * because you might chdir out of a directory that you can't chdir
4246 Perl_getcwd_sv(pTHX_ register SV *sv)
4250 #ifndef INCOMPLETE_TAINTS
4254 PERL_ARGS_ASSERT_GETCWD_SV;
4258 char buf[MAXPATHLEN];
4260 /* Some getcwd()s automatically allocate a buffer of the given
4261 * size from the heap if they are given a NULL buffer pointer.
4262 * The problem is that this behaviour is not portable. */
4263 if (getcwd(buf, sizeof(buf) - 1)) {
4268 sv_setsv(sv, &PL_sv_undef);
4276 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4280 SvUPGRADE(sv, SVt_PV);
4282 if (PerlLIO_lstat(".", &statbuf) < 0) {
4283 SV_CWD_RETURN_UNDEF;
4286 orig_cdev = statbuf.st_dev;
4287 orig_cino = statbuf.st_ino;
4297 if (PerlDir_chdir("..") < 0) {
4298 SV_CWD_RETURN_UNDEF;
4300 if (PerlLIO_stat(".", &statbuf) < 0) {
4301 SV_CWD_RETURN_UNDEF;
4304 cdev = statbuf.st_dev;
4305 cino = statbuf.st_ino;
4307 if (odev == cdev && oino == cino) {
4310 if (!(dir = PerlDir_open("."))) {
4311 SV_CWD_RETURN_UNDEF;
4314 while ((dp = PerlDir_read(dir)) != NULL) {
4316 namelen = dp->d_namlen;
4318 namelen = strlen(dp->d_name);
4321 if (SV_CWD_ISDOT(dp)) {
4325 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4326 SV_CWD_RETURN_UNDEF;
4329 tdev = statbuf.st_dev;
4330 tino = statbuf.st_ino;
4331 if (tino == oino && tdev == odev) {
4337 SV_CWD_RETURN_UNDEF;
4340 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4341 SV_CWD_RETURN_UNDEF;
4344 SvGROW(sv, pathlen + namelen + 1);
4348 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4351 /* prepend current directory to the front */
4353 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4354 pathlen += (namelen + 1);
4356 #ifdef VOID_CLOSEDIR
4359 if (PerlDir_close(dir) < 0) {
4360 SV_CWD_RETURN_UNDEF;
4366 SvCUR_set(sv, pathlen);
4370 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4371 SV_CWD_RETURN_UNDEF;
4374 if (PerlLIO_stat(".", &statbuf) < 0) {
4375 SV_CWD_RETURN_UNDEF;
4378 cdev = statbuf.st_dev;
4379 cino = statbuf.st_ino;
4381 if (cdev != orig_cdev || cino != orig_cino) {
4382 Perl_croak(aTHX_ "Unstable directory path, "
4383 "current directory changed unexpectedly");
4394 #define VERSION_MAX 0x7FFFFFFF
4397 =for apidoc prescan_version
4402 Perl_prescan_version(pTHX_ const char *s, bool strict,
4403 const char **errstr,
4404 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4405 bool qv = (sqv ? *sqv : FALSE);
4407 int saw_decimal = 0;
4411 PERL_ARGS_ASSERT_PRESCAN_VERSION;
4413 if (qv && isDIGIT(*d))
4414 goto dotted_decimal_version;
4416 if (*d == 'v') { /* explicit v-string */
4421 else { /* degenerate v-string */
4422 /* requires v1.2.3 */
4423 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4426 dotted_decimal_version:
4427 if (strict && d[0] == '0' && isDIGIT(d[1])) {
4428 /* no leading zeros allowed */
4429 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4432 while (isDIGIT(*d)) /* integer part */
4438 d++; /* decimal point */
4443 /* require v1.2.3 */
4444 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4447 goto version_prescan_finish;
4454 while (isDIGIT(*d)) { /* just keep reading */
4456 while (isDIGIT(*d)) {
4458 /* maximum 3 digits between decimal */
4459 if (strict && j > 3) {
4460 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4465 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4468 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4473 else if (*d == '.') {
4475 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4480 else if (!isDIGIT(*d)) {
4486 if (strict && i < 2) {
4487 /* requires v1.2.3 */
4488 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4491 } /* end if dotted-decimal */
4493 { /* decimal versions */
4494 /* special strict case for leading '.' or '0' */
4497 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4499 if (*d == '0' && isDIGIT(d[1])) {
4500 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4504 /* consume all of the integer part */
4508 /* look for a fractional part */
4510 /* we found it, so consume it */
4514 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4517 BADVERSION(s,errstr,"Invalid version format (version required)");
4519 /* found just an integer */
4520 goto version_prescan_finish;
4522 else if ( d == s ) {
4523 /* didn't find either integer or period */
4524 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4526 else if (*d == '_') {
4527 /* underscore can't come after integer part */
4529 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4531 else if (isDIGIT(d[1])) {
4532 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4535 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4539 /* anything else after integer part is just invalid data */
4540 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4543 /* scan the fractional part after the decimal point*/
4545 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4546 /* strict or lax-but-not-the-end */
4547 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4550 while (isDIGIT(*d)) {
4552 if (*d == '.' && isDIGIT(d[-1])) {
4554 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4557 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4559 d = (char *)s; /* start all over again */
4561 goto dotted_decimal_version;
4565 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4568 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4570 if ( ! isDIGIT(d[1]) ) {
4571 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4579 version_prescan_finish:
4583 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4584 /* trailing non-numeric data */
4585 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4593 *ssaw_decimal = saw_decimal;
4600 =for apidoc scan_version
4602 Returns a pointer to the next character after the parsed
4603 version string, as well as upgrading the passed in SV to
4606 Function must be called with an already existing SV like
4609 s = scan_version(s, SV *sv, bool qv);
4611 Performs some preprocessing to the string to ensure that
4612 it has the correct characteristics of a version. Flags the
4613 object if it contains an underscore (which denotes this
4614 is an alpha version). The boolean qv denotes that the version
4615 should be interpreted as if it had multiple decimals, even if
4622 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4627 const char *errstr = NULL;
4628 int saw_decimal = 0;
4632 AV * const av = newAV();
4633 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4635 PERL_ARGS_ASSERT_SCAN_VERSION;
4637 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4639 #ifndef NODEFAULT_SHAREKEYS
4640 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4643 while (isSPACE(*s)) /* leading whitespace is OK */
4646 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4648 /* "undef" is a special case and not an error */
4649 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4650 Perl_croak(aTHX_ "%s", errstr);
4660 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4662 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4663 if ( !qv && width < 3 )
4664 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4666 while (isDIGIT(*pos))
4668 if (!isALPHA(*pos)) {
4674 /* this is atoi() that delimits on underscores */
4675 const char *end = pos;
4679 /* the following if() will only be true after the decimal
4680 * point of a version originally created with a bare
4681 * floating point number, i.e. not quoted in any way
4683 if ( !qv && s > start && saw_decimal == 1 ) {
4687 rev += (*s - '0') * mult;
4689 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4690 || (PERL_ABS(rev) > VERSION_MAX )) {
4691 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4692 "Integer overflow in version %d",VERSION_MAX);
4703 while (--end >= s) {
4705 rev += (*end - '0') * mult;
4707 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4708 || (PERL_ABS(rev) > VERSION_MAX )) {
4709 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4710 "Integer overflow in version");
4719 /* Append revision */
4720 av_push(av, newSViv(rev));
4725 else if ( *pos == '.' )
4727 else if ( *pos == '_' && isDIGIT(pos[1]) )
4729 else if ( *pos == ',' && isDIGIT(pos[1]) )
4731 else if ( isDIGIT(*pos) )
4738 while ( isDIGIT(*pos) )
4743 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4751 if ( qv ) { /* quoted versions always get at least three terms*/
4752 I32 len = av_len(av);
4753 /* This for loop appears to trigger a compiler bug on OS X, as it
4754 loops infinitely. Yes, len is negative. No, it makes no sense.
4755 Compiler in question is:
4756 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4757 for ( len = 2 - len; len > 0; len-- )
4758 av_push(MUTABLE_AV(sv), newSViv(0));
4762 av_push(av, newSViv(0));
4765 /* need to save off the current version string for later */
4767 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4768 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4769 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4771 else if ( s > start ) {
4772 SV * orig = newSVpvn(start,s-start);
4773 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4774 /* need to insert a v to be consistent */
4775 sv_insert(orig, 0, 0, "v", 1);
4777 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4780 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4781 av_push(av, newSViv(0));
4784 /* And finally, store the AV in the hash */
4785 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4787 /* fix RT#19517 - special case 'undef' as string */
4788 if ( *s == 'u' && strEQ(s,"undef") ) {
4796 =for apidoc new_version
4798 Returns a new version object based on the passed in SV:
4800 SV *sv = new_version(SV *ver);
4802 Does not alter the passed in ver SV. See "upg_version" if you
4803 want to upgrade the SV.
4809 Perl_new_version(pTHX_ SV *ver)
4812 SV * const rv = newSV(0);
4813 PERL_ARGS_ASSERT_NEW_VERSION;
4814 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4817 AV * const av = newAV();
4819 /* This will get reblessed later if a derived class*/
4820 SV * const hv = newSVrv(rv, "version");
4821 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4822 #ifndef NODEFAULT_SHAREKEYS
4823 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4829 /* Begin copying all of the elements */
4830 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4831 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4833 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4834 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4836 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4838 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4839 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4842 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4844 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4845 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4848 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4849 /* This will get reblessed later if a derived class*/
4850 for ( key = 0; key <= av_len(sav); key++ )
4852 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4853 av_push(av, newSViv(rev));
4856 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4861 const MAGIC* const mg = SvVSTRING_mg(ver);
4862 if ( mg ) { /* already a v-string */
4863 const STRLEN len = mg->mg_len;
4864 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4865 sv_setpvn(rv,version,len);
4866 /* this is for consistency with the pure Perl class */
4867 if ( isDIGIT(*version) )
4868 sv_insert(rv, 0, 0, "v", 1);
4873 sv_setsv(rv,ver); /* make a duplicate */
4878 return upg_version(rv, FALSE);
4882 =for apidoc upg_version
4884 In-place upgrade of the supplied SV to a version object.
4886 SV *sv = upg_version(SV *sv, bool qv);
4888 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4889 to force this SV to be interpreted as an "extended" version.
4895 Perl_upg_version(pTHX_ SV *ver, bool qv)
4897 const char *version, *s;
4902 PERL_ARGS_ASSERT_UPG_VERSION;
4904 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4906 /* may get too much accuracy */
4908 #ifdef USE_LOCALE_NUMERIC
4909 char *loc = setlocale(LC_NUMERIC, "C");
4911 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4912 #ifdef USE_LOCALE_NUMERIC
4913 setlocale(LC_NUMERIC, loc);
4915 while (tbuf[len-1] == '0' && len > 0) len--;
4916 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4917 version = savepvn(tbuf, len);
4920 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4921 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4925 else /* must be a string or something like a string */
4928 version = savepv(SvPV(ver,len));
4930 # if PERL_VERSION > 5
4931 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4932 if ( len >= 3 && !instr(version,".") && !instr(version,"_")
4933 && !(*version == 'u' && strEQ(version, "undef"))
4934 && (*version < '0' || *version > '9') ) {
4935 /* may be a v-string */
4936 SV * const nsv = sv_newmortal();
4939 int saw_decimal = 0;
4940 sv_setpvf(nsv,"v%vd",ver);
4941 pos = nver = savepv(SvPV_nolen(nsv));
4943 /* scan the resulting formatted string */
4944 pos++; /* skip the leading 'v' */
4945 while ( *pos == '.' || isDIGIT(*pos) ) {
4951 /* is definitely a v-string */
4952 if ( saw_decimal >= 2 ) {
4961 s = scan_version(version, ver, qv);
4963 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4964 "Version string '%s' contains invalid data; "
4965 "ignoring: '%s'", version, s);
4973 Validates that the SV contains a valid version object.
4975 bool vverify(SV *vobj);
4977 Note that it only confirms the bare minimum structure (so as not to get
4978 confused by derived classes which may contain additional hash entries):
4982 =item * The SV contains a [reference to a] hash
4984 =item * The hash contains a "version" key
4986 =item * The "version" key has [a reference to] an AV as its value
4994 Perl_vverify(pTHX_ SV *vs)
4998 PERL_ARGS_ASSERT_VVERIFY;
5003 /* see if the appropriate elements exist */
5004 if ( SvTYPE(vs) == SVt_PVHV
5005 && hv_exists(MUTABLE_HV(vs), "version", 7)
5006 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
5007 && SvTYPE(sv) == SVt_PVAV )
5016 Accepts a version object and returns the normalized floating
5017 point representation. Call like:
5021 NOTE: you can pass either the object directly or the SV
5022 contained within the RV.
5028 Perl_vnumify(pTHX_ SV *vs)
5036 PERL_ARGS_ASSERT_VNUMIFY;
5042 Perl_croak(aTHX_ "Invalid version object");
5044 /* see if various flags exist */
5045 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5047 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5048 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5053 /* attempt to retrieve the version array */
5054 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5055 return newSVpvs("0");
5061 return newSVpvs("0");
5064 digit = SvIV(*av_fetch(av, 0, 0));
5065 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5066 for ( i = 1 ; i < len ; i++ )
5068 digit = SvIV(*av_fetch(av, i, 0));
5070 const int denom = (width == 2 ? 10 : 100);
5071 const div_t term = div((int)PERL_ABS(digit),denom);
5072 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5075 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5081 digit = SvIV(*av_fetch(av, len, 0));
5082 if ( alpha && width == 3 ) /* alpha version */
5084 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5088 sv_catpvs(sv, "000");
5096 Accepts a version object and returns the normalized string
5097 representation. Call like:
5101 NOTE: you can pass either the object directly or the SV
5102 contained within the RV.
5108 Perl_vnormal(pTHX_ SV *vs)
5115 PERL_ARGS_ASSERT_VNORMAL;
5121 Perl_croak(aTHX_ "Invalid version object");
5123 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5125 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5130 return newSVpvs("");
5132 digit = SvIV(*av_fetch(av, 0, 0));
5133 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5134 for ( i = 1 ; i < len ; i++ ) {
5135 digit = SvIV(*av_fetch(av, i, 0));
5136 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5141 /* handle last digit specially */
5142 digit = SvIV(*av_fetch(av, len, 0));
5144 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5146 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5149 if ( len <= 2 ) { /* short version, must be at least three */
5150 for ( len = 2 - len; len != 0; len-- )
5157 =for apidoc vstringify
5159 In order to maintain maximum compatibility with earlier versions
5160 of Perl, this function will return either the floating point
5161 notation or the multiple dotted notation, depending on whether
5162 the original version contained 1 or more dots, respectively
5168 Perl_vstringify(pTHX_ SV *vs)
5170 PERL_ARGS_ASSERT_VSTRINGIFY;
5176 Perl_croak(aTHX_ "Invalid version object");
5178 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
5180 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5184 return &PL_sv_undef;
5187 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5197 Version object aware cmp. Both operands must already have been
5198 converted into version objects.
5204 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5207 bool lalpha = FALSE;
5208 bool ralpha = FALSE;
5213 PERL_ARGS_ASSERT_VCMP;
5220 if ( !vverify(lhv) )
5221 Perl_croak(aTHX_ "Invalid version object");
5223 if ( !vverify(rhv) )
5224 Perl_croak(aTHX_ "Invalid version object");
5226 /* get the left hand term */
5227 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5228 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5231 /* and the right hand term */
5232 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5233 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5241 while ( i <= m && retval == 0 )
5243 left = SvIV(*av_fetch(lav,i,0));
5244 right = SvIV(*av_fetch(rav,i,0));
5252 /* tiebreaker for alpha with identical terms */
5253 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5255 if ( lalpha && !ralpha )
5259 else if ( ralpha && !lalpha)
5265 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5269 while ( i <= r && retval == 0 )
5271 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5272 retval = -1; /* not a match after all */
5278 while ( i <= l && retval == 0 )
5280 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5281 retval = +1; /* not a match after all */
5289 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5290 # define EMULATE_SOCKETPAIR_UDP
5293 #ifdef EMULATE_SOCKETPAIR_UDP
5295 S_socketpair_udp (int fd[2]) {
5297 /* Fake a datagram socketpair using UDP to localhost. */
5298 int sockets[2] = {-1, -1};
5299 struct sockaddr_in addresses[2];
5301 Sock_size_t size = sizeof(struct sockaddr_in);
5302 unsigned short port;
5305 memset(&addresses, 0, sizeof(addresses));
5308 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5309 if (sockets[i] == -1)
5310 goto tidy_up_and_fail;
5312 addresses[i].sin_family = AF_INET;
5313 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5314 addresses[i].sin_port = 0; /* kernel choses port. */
5315 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5316 sizeof(struct sockaddr_in)) == -1)
5317 goto tidy_up_and_fail;
5320 /* Now have 2 UDP sockets. Find out which port each is connected to, and
5321 for each connect the other socket to it. */
5324 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5326 goto tidy_up_and_fail;
5327 if (size != sizeof(struct sockaddr_in))
5328 goto abort_tidy_up_and_fail;
5329 /* !1 is 0, !0 is 1 */
5330 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5331 sizeof(struct sockaddr_in)) == -1)
5332 goto tidy_up_and_fail;
5335 /* Now we have 2 sockets connected to each other. I don't trust some other
5336 process not to have already sent a packet to us (by random) so send
5337 a packet from each to the other. */
5340 /* I'm going to send my own port number. As a short.
5341 (Who knows if someone somewhere has sin_port as a bitfield and needs
5342 this routine. (I'm assuming crays have socketpair)) */
5343 port = addresses[i].sin_port;
5344 got = PerlLIO_write(sockets[i], &port, sizeof(port));
5345 if (got != sizeof(port)) {
5347 goto tidy_up_and_fail;
5348 goto abort_tidy_up_and_fail;
5352 /* Packets sent. I don't trust them to have arrived though.
5353 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5354 connect to localhost will use a second kernel thread. In 2.6 the
5355 first thread running the connect() returns before the second completes,
5356 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5357 returns 0. Poor programs have tripped up. One poor program's authors'
5358 had a 50-1 reverse stock split. Not sure how connected these were.)
5359 So I don't trust someone not to have an unpredictable UDP stack.
5363 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5364 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5368 FD_SET((unsigned int)sockets[0], &rset);
5369 FD_SET((unsigned int)sockets[1], &rset);
5371 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5372 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5373 || !FD_ISSET(sockets[1], &rset)) {
5374 /* I hope this is portable and appropriate. */
5376 goto tidy_up_and_fail;
5377 goto abort_tidy_up_and_fail;
5381 /* And the paranoia department even now doesn't trust it to have arrive
5382 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5384 struct sockaddr_in readfrom;
5385 unsigned short buffer[2];
5390 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5391 sizeof(buffer), MSG_DONTWAIT,
5392 (struct sockaddr *) &readfrom, &size);
5394 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5396 (struct sockaddr *) &readfrom, &size);
5400 goto tidy_up_and_fail;
5401 if (got != sizeof(port)
5402 || size != sizeof(struct sockaddr_in)
5403 /* Check other socket sent us its port. */
5404 || buffer[0] != (unsigned short) addresses[!i].sin_port
5405 /* Check kernel says we got the datagram from that socket */
5406 || readfrom.sin_family != addresses[!i].sin_family
5407 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5408 || readfrom.sin_port != addresses[!i].sin_port)
5409 goto abort_tidy_up_and_fail;
5412 /* My caller (my_socketpair) has validated that this is non-NULL */
5415 /* I hereby declare this connection open. May God bless all who cross
5419 abort_tidy_up_and_fail:
5420 errno = ECONNABORTED;
5424 if (sockets[0] != -1)
5425 PerlLIO_close(sockets[0]);
5426 if (sockets[1] != -1)
5427 PerlLIO_close(sockets[1]);
5432 #endif /* EMULATE_SOCKETPAIR_UDP */
5434 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5436 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5437 /* Stevens says that family must be AF_LOCAL, protocol 0.
5438 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5443 struct sockaddr_in listen_addr;
5444 struct sockaddr_in connect_addr;
5449 || family != AF_UNIX
5452 errno = EAFNOSUPPORT;
5460 #ifdef EMULATE_SOCKETPAIR_UDP
5461 if (type == SOCK_DGRAM)
5462 return S_socketpair_udp(fd);
5465 listener = PerlSock_socket(AF_INET, type, 0);
5468 memset(&listen_addr, 0, sizeof(listen_addr));
5469 listen_addr.sin_family = AF_INET;
5470 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5471 listen_addr.sin_port = 0; /* kernel choses port. */
5472 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5473 sizeof(listen_addr)) == -1)
5474 goto tidy_up_and_fail;
5475 if (PerlSock_listen(listener, 1) == -1)
5476 goto tidy_up_and_fail;
5478 connector = PerlSock_socket(AF_INET, type, 0);
5479 if (connector == -1)
5480 goto tidy_up_and_fail;
5481 /* We want to find out the port number to connect to. */
5482 size = sizeof(connect_addr);
5483 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5485 goto tidy_up_and_fail;
5486 if (size != sizeof(connect_addr))
5487 goto abort_tidy_up_and_fail;
5488 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5489 sizeof(connect_addr)) == -1)
5490 goto tidy_up_and_fail;
5492 size = sizeof(listen_addr);
5493 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5496 goto tidy_up_and_fail;
5497 if (size != sizeof(listen_addr))
5498 goto abort_tidy_up_and_fail;
5499 PerlLIO_close(listener);
5500 /* Now check we are talking to ourself by matching port and host on the
5502 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5504 goto tidy_up_and_fail;
5505 if (size != sizeof(connect_addr)
5506 || listen_addr.sin_family != connect_addr.sin_family
5507 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5508 || listen_addr.sin_port != connect_addr.sin_port) {
5509 goto abort_tidy_up_and_fail;
5515 abort_tidy_up_and_fail:
5517 errno = ECONNABORTED; /* This would be the standard thing to do. */
5519 # ifdef ECONNREFUSED
5520 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5522 errno = ETIMEDOUT; /* Desperation time. */
5529 PerlLIO_close(listener);
5530 if (connector != -1)
5531 PerlLIO_close(connector);
5533 PerlLIO_close(acceptor);
5539 /* In any case have a stub so that there's code corresponding
5540 * to the my_socketpair in global.sym. */
5542 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5543 #ifdef HAS_SOCKETPAIR
5544 return socketpair(family, type, protocol, fd);
5553 =for apidoc sv_nosharing
5555 Dummy routine which "shares" an SV when there is no sharing module present.
5556 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5557 Exists to avoid test for a NULL function pointer and because it could
5558 potentially warn under some level of strict-ness.
5564 Perl_sv_nosharing(pTHX_ SV *sv)
5566 PERL_UNUSED_CONTEXT;
5567 PERL_UNUSED_ARG(sv);
5572 =for apidoc sv_destroyable
5574 Dummy routine which reports that object can be destroyed when there is no
5575 sharing module present. It ignores its single SV argument, and returns
5576 'true'. Exists to avoid test for a NULL function pointer and because it
5577 could potentially warn under some level of strict-ness.
5583 Perl_sv_destroyable(pTHX_ SV *sv)
5585 PERL_UNUSED_CONTEXT;
5586 PERL_UNUSED_ARG(sv);
5591 Perl_parse_unicode_opts(pTHX_ const char **popt)
5593 const char *p = *popt;
5596 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5600 opt = (U32) atoi(p);
5603 if (*p && *p != '\n' && *p != '\r')
5604 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5609 case PERL_UNICODE_STDIN:
5610 opt |= PERL_UNICODE_STDIN_FLAG; break;
5611 case PERL_UNICODE_STDOUT:
5612 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5613 case PERL_UNICODE_STDERR:
5614 opt |= PERL_UNICODE_STDERR_FLAG; break;
5615 case PERL_UNICODE_STD:
5616 opt |= PERL_UNICODE_STD_FLAG; break;
5617 case PERL_UNICODE_IN:
5618 opt |= PERL_UNICODE_IN_FLAG; break;
5619 case PERL_UNICODE_OUT:
5620 opt |= PERL_UNICODE_OUT_FLAG; break;
5621 case PERL_UNICODE_INOUT:
5622 opt |= PERL_UNICODE_INOUT_FLAG; break;
5623 case PERL_UNICODE_LOCALE:
5624 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5625 case PERL_UNICODE_ARGV:
5626 opt |= PERL_UNICODE_ARGV_FLAG; break;
5627 case PERL_UNICODE_UTF8CACHEASSERT:
5628 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5630 if (*p != '\n' && *p != '\r')
5632 "Unknown Unicode option letter '%c'", *p);
5638 opt = PERL_UNICODE_DEFAULT_FLAGS;
5640 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5641 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5642 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5654 * This is really just a quick hack which grabs various garbage
5655 * values. It really should be a real hash algorithm which
5656 * spreads the effect of every input bit onto every output bit,
5657 * if someone who knows about such things would bother to write it.
5658 * Might be a good idea to add that function to CORE as well.
5659 * No numbers below come from careful analysis or anything here,
5660 * except they are primes and SEED_C1 > 1E6 to get a full-width
5661 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5662 * probably be bigger too.
5665 # define SEED_C1 1000003
5666 #define SEED_C4 73819
5668 # define SEED_C1 25747
5669 #define SEED_C4 20639
5673 #define SEED_C5 26107
5675 #ifndef PERL_NO_DEV_RANDOM
5680 # include <starlet.h>
5681 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5682 * in 100-ns units, typically incremented ever 10 ms. */
5683 unsigned int when[2];
5685 # ifdef HAS_GETTIMEOFDAY
5686 struct timeval when;
5692 /* This test is an escape hatch, this symbol isn't set by Configure. */
5693 #ifndef PERL_NO_DEV_RANDOM
5694 #ifndef PERL_RANDOM_DEVICE
5695 /* /dev/random isn't used by default because reads from it will block
5696 * if there isn't enough entropy available. You can compile with
5697 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5698 * is enough real entropy to fill the seed. */
5699 # define PERL_RANDOM_DEVICE "/dev/urandom"
5701 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5703 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5712 _ckvmssts(sys$gettim(when));
5713 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5715 # ifdef HAS_GETTIMEOFDAY
5716 PerlProc_gettimeofday(&when,NULL);
5717 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5720 u = (U32)SEED_C1 * when;
5723 u += SEED_C3 * (U32)PerlProc_getpid();
5724 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5725 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5726 u += SEED_C5 * (U32)PTR2UV(&when);
5732 Perl_get_hash_seed(pTHX)
5735 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5741 if (s && isDIGIT(*s))
5742 myseed = (UV)Atoul(s);
5744 #ifdef USE_HASH_SEED_EXPLICIT
5748 /* Compute a random seed */
5749 (void)seedDrand01((Rand_seed_t)seed());
5750 myseed = (UV)(Drand01() * (NV)UV_MAX);
5751 #if RANDBITS < (UVSIZE * 8)
5752 /* Since there are not enough randbits to to reach all
5753 * the bits of a UV, the low bits might need extra
5754 * help. Sum in another random number that will
5755 * fill in the low bits. */
5757 (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5758 #endif /* RANDBITS < (UVSIZE * 8) */
5759 if (myseed == 0) { /* Superparanoia. */
5760 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5762 Perl_croak(aTHX_ "Your random numbers are not that random");
5765 PL_rehash_seed_set = TRUE;
5772 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5774 const char * const stashpv = CopSTASHPV(c);
5775 const char * const name = HvNAME_get(hv);
5776 PERL_UNUSED_CONTEXT;
5777 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5779 if (stashpv == name)
5781 if (stashpv && name)
5782 if (strEQ(stashpv, name))
5789 #ifdef PERL_GLOBAL_STRUCT
5791 #define PERL_GLOBAL_STRUCT_INIT
5792 #include "opcode.h" /* the ppaddr and check */
5795 Perl_init_global_struct(pTHX)
5797 struct perl_vars *plvarsp = NULL;
5798 # ifdef PERL_GLOBAL_STRUCT
5799 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5800 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5801 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5802 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5803 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5807 plvarsp = PL_VarsPtr;
5808 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5814 # define PERLVAR(var,type) /**/
5815 # define PERLVARA(var,n,type) /**/
5816 # define PERLVARI(var,type,init) plvarsp->var = init;
5817 # define PERLVARIC(var,type,init) plvarsp->var = init;
5818 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5819 # include "perlvars.h"
5825 # ifdef PERL_GLOBAL_STRUCT
5828 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5829 if (!plvarsp->Gppaddr)
5833 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5834 if (!plvarsp->Gcheck)
5836 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5837 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5839 # ifdef PERL_SET_VARS
5840 PERL_SET_VARS(plvarsp);
5842 # undef PERL_GLOBAL_STRUCT_INIT
5847 #endif /* PERL_GLOBAL_STRUCT */
5849 #ifdef PERL_GLOBAL_STRUCT
5852 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5854 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5855 # ifdef PERL_GLOBAL_STRUCT
5856 # ifdef PERL_UNSET_VARS
5857 PERL_UNSET_VARS(plvarsp);
5859 free(plvarsp->Gppaddr);
5860 free(plvarsp->Gcheck);
5861 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5867 #endif /* PERL_GLOBAL_STRUCT */
5871 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5872 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5873 * given, and you supply your own implementation.
5875 * The default implementation reads a single env var, PERL_MEM_LOG,
5876 * expecting one or more of the following:
5878 * \d+ - fd fd to write to : must be 1st (atoi)
5879 * 'm' - memlog was PERL_MEM_LOG=1
5880 * 's' - svlog was PERL_SV_LOG=1
5881 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5883 * This makes the logger controllable enough that it can reasonably be
5884 * added to the system perl.
5887 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5888 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5890 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5892 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5893 * writes to. In the default logger, this is settable at runtime.
5895 #ifndef PERL_MEM_LOG_FD
5896 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5899 #ifndef PERL_MEM_LOG_NOIMPL
5901 # ifdef DEBUG_LEAKING_SCALARS
5902 # define SV_LOG_SERIAL_FMT " [%lu]"
5903 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5905 # define SV_LOG_SERIAL_FMT
5906 # define _SV_LOG_SERIAL_ARG(sv)
5910 S_mem_log_common(enum mem_log_type mlt, const UV n,
5911 const UV typesize, const char *type_name, const SV *sv,
5912 Malloc_t oldalloc, Malloc_t newalloc,
5913 const char *filename, const int linenumber,
5914 const char *funcname)
5918 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5920 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5923 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5925 /* We can't use SVs or PerlIO for obvious reasons,
5926 * so we'll use stdio and low-level IO instead. */
5927 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5929 # ifdef HAS_GETTIMEOFDAY
5930 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5931 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5933 gettimeofday(&tv, 0);
5935 # define MEM_LOG_TIME_FMT "%10d: "
5936 # define MEM_LOG_TIME_ARG (int)when
5940 /* If there are other OS specific ways of hires time than
5941 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5942 * probably that they would be used to fill in the struct
5946 int fd = atoi(pmlenv);
5948 fd = PERL_MEM_LOG_FD;
5950 if (strchr(pmlenv, 't')) {
5951 len = my_snprintf(buf, sizeof(buf),
5952 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5953 PerlLIO_write(fd, buf, len);
5957 len = my_snprintf(buf, sizeof(buf),
5958 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5959 " %s = %"IVdf": %"UVxf"\n",
5960 filename, linenumber, funcname, n, typesize,
5961 type_name, n * typesize, PTR2UV(newalloc));
5964 len = my_snprintf(buf, sizeof(buf),
5965 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5966 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5967 filename, linenumber, funcname, n, typesize,
5968 type_name, n * typesize, PTR2UV(oldalloc),
5972 len = my_snprintf(buf, sizeof(buf),
5973 "free: %s:%d:%s: %"UVxf"\n",
5974 filename, linenumber, funcname,
5979 len = my_snprintf(buf, sizeof(buf),
5980 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5981 mlt == MLT_NEW_SV ? "new" : "del",
5982 filename, linenumber, funcname,
5983 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5988 PerlLIO_write(fd, buf, len);
5992 #endif /* !PERL_MEM_LOG_NOIMPL */
5994 #ifndef PERL_MEM_LOG_NOIMPL
5996 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5997 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5999 /* this is suboptimal, but bug compatible. User is providing their
6000 own implemenation, but is getting these functions anyway, and they
6001 do nothing. But _NOIMPL users should be able to cope or fix */
6003 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
6004 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
6008 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
6010 const char *filename, const int linenumber,
6011 const char *funcname)
6013 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6014 NULL, NULL, newalloc,
6015 filename, linenumber, funcname);
6020 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6021 Malloc_t oldalloc, Malloc_t newalloc,
6022 const char *filename, const int linenumber,
6023 const char *funcname)
6025 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6026 NULL, oldalloc, newalloc,
6027 filename, linenumber, funcname);
6032 Perl_mem_log_free(Malloc_t oldalloc,
6033 const char *filename, const int linenumber,
6034 const char *funcname)
6036 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6037 filename, linenumber, funcname);
6042 Perl_mem_log_new_sv(const SV *sv,
6043 const char *filename, const int linenumber,
6044 const char *funcname)
6046 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6047 filename, linenumber, funcname);
6051 Perl_mem_log_del_sv(const SV *sv,
6052 const char *filename, const int linenumber,
6053 const char *funcname)
6055 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6056 filename, linenumber, funcname);
6059 #endif /* PERL_MEM_LOG */
6062 =for apidoc my_sprintf
6064 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6065 the length of the string written to the buffer. Only rare pre-ANSI systems
6066 need the wrapper function - usually this is a direct call to C<sprintf>.
6070 #ifndef SPRINTF_RETURNS_STRLEN
6072 Perl_my_sprintf(char *buffer, const char* pat, ...)
6075 PERL_ARGS_ASSERT_MY_SPRINTF;
6076 va_start(args, pat);
6077 vsprintf(buffer, pat, args);
6079 return strlen(buffer);
6084 =for apidoc my_snprintf
6086 The C library C<snprintf> functionality, if available and
6087 standards-compliant (uses C<vsnprintf>, actually). However, if the
6088 C<vsnprintf> is not available, will unfortunately use the unsafe
6089 C<vsprintf> which can overrun the buffer (there is an overrun check,
6090 but that may be too late). Consider using C<sv_vcatpvf> instead, or
6091 getting C<vsnprintf>.
6096 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6101 PERL_ARGS_ASSERT_MY_SNPRINTF;
6102 va_start(ap, format);
6103 #ifdef HAS_VSNPRINTF
6104 retval = vsnprintf(buffer, len, format, ap);
6106 retval = vsprintf(buffer, format, ap);
6109 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6110 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6111 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6116 =for apidoc my_vsnprintf
6118 The C library C<vsnprintf> if available and standards-compliant.
6119 However, if if the C<vsnprintf> is not available, will unfortunately
6120 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6121 overrun check, but that may be too late). Consider using
6122 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6127 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6134 PERL_ARGS_ASSERT_MY_VSNPRINTF;
6136 Perl_va_copy(ap, apc);
6137 # ifdef HAS_VSNPRINTF
6138 retval = vsnprintf(buffer, len, format, apc);
6140 retval = vsprintf(buffer, format, apc);
6143 # ifdef HAS_VSNPRINTF
6144 retval = vsnprintf(buffer, len, format, ap);
6146 retval = vsprintf(buffer, format, ap);
6148 #endif /* #ifdef NEED_VA_COPY */
6149 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6150 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6151 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6156 Perl_my_clearenv(pTHX)
6159 #if ! defined(PERL_MICRO)
6160 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6162 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6163 # if defined(USE_ENVIRON_ARRAY)
6164 # if defined(USE_ITHREADS)
6165 /* only the parent thread can clobber the process environment */
6166 if (PL_curinterp == aTHX)
6167 # endif /* USE_ITHREADS */
6169 # if ! defined(PERL_USE_SAFE_PUTENV)
6170 if ( !PL_use_safe_putenv) {
6172 if (environ == PL_origenviron)
6173 environ = (char**)safesysmalloc(sizeof(char*));
6175 for (i = 0; environ[i]; i++)
6176 (void)safesysfree(environ[i]);
6179 # else /* PERL_USE_SAFE_PUTENV */
6180 # if defined(HAS_CLEARENV)
6182 # elif defined(HAS_UNSETENV)
6183 int bsiz = 80; /* Most envvar names will be shorter than this. */
6184 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6185 char *buf = (char*)safesysmalloc(bufsiz);
6186 while (*environ != NULL) {
6187 char *e = strchr(*environ, '=');
6188 int l = e ? e - *environ : (int)strlen(*environ);
6190 (void)safesysfree(buf);
6191 bsiz = l + 1; /* + 1 for the \0. */
6192 buf = (char*)safesysmalloc(bufsiz);
6194 memcpy(buf, *environ, l);
6196 (void)unsetenv(buf);
6198 (void)safesysfree(buf);
6199 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6200 /* Just null environ and accept the leakage. */
6202 # endif /* HAS_CLEARENV || HAS_UNSETENV */
6203 # endif /* ! PERL_USE_SAFE_PUTENV */
6205 # endif /* USE_ENVIRON_ARRAY */
6206 # endif /* PERL_IMPLICIT_SYS || WIN32 */
6207 #endif /* PERL_MICRO */
6210 #ifdef PERL_IMPLICIT_CONTEXT
6212 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6213 the global PL_my_cxt_index is incremented, and that value is assigned to
6214 that module's static my_cxt_index (who's address is passed as an arg).
6215 Then, for each interpreter this function is called for, it makes sure a
6216 void* slot is available to hang the static data off, by allocating or
6217 extending the interpreter's PL_my_cxt_list array */
6219 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6221 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6225 PERL_ARGS_ASSERT_MY_CXT_INIT;
6227 /* this module hasn't been allocated an index yet */
6228 #if defined(USE_ITHREADS)
6229 MUTEX_LOCK(&PL_my_ctx_mutex);
6231 *index = PL_my_cxt_index++;
6232 #if defined(USE_ITHREADS)
6233 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6237 /* make sure the array is big enough */
6238 if (PL_my_cxt_size <= *index) {
6239 if (PL_my_cxt_size) {
6240 while (PL_my_cxt_size <= *index)
6241 PL_my_cxt_size *= 2;
6242 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6245 PL_my_cxt_size = 16;
6246 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6249 /* newSV() allocates one more than needed */
6250 p = (void*)SvPVX(newSV(size-1));
6251 PL_my_cxt_list[*index] = p;
6252 Zero(p, size, char);
6256 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6259 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6264 PERL_ARGS_ASSERT_MY_CXT_INDEX;
6266 for (index = 0; index < PL_my_cxt_index; index++) {
6267 const char *key = PL_my_cxt_keys[index];
6268 /* try direct pointer compare first - there are chances to success,
6269 * and it's much faster.
6271 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6278 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6284 PERL_ARGS_ASSERT_MY_CXT_INIT;
6286 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6288 /* this module hasn't been allocated an index yet */
6289 #if defined(USE_ITHREADS)
6290 MUTEX_LOCK(&PL_my_ctx_mutex);
6292 index = PL_my_cxt_index++;
6293 #if defined(USE_ITHREADS)
6294 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6298 /* make sure the array is big enough */
6299 if (PL_my_cxt_size <= index) {
6300 int old_size = PL_my_cxt_size;
6302 if (PL_my_cxt_size) {
6303 while (PL_my_cxt_size <= index)
6304 PL_my_cxt_size *= 2;
6305 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6306 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6309 PL_my_cxt_size = 16;
6310 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6311 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6313 for (i = old_size; i < PL_my_cxt_size; i++) {
6314 PL_my_cxt_keys[i] = 0;
6315 PL_my_cxt_list[i] = 0;
6318 PL_my_cxt_keys[index] = my_cxt_key;
6319 /* newSV() allocates one more than needed */
6320 p = (void*)SvPVX(newSV(size-1));
6321 PL_my_cxt_list[index] = p;
6322 Zero(p, size, char);
6325 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6326 #endif /* PERL_IMPLICIT_CONTEXT */
6330 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6332 Size_t used, length, copy;
6335 length = strlen(src);
6336 if (size > 0 && used < size - 1) {
6337 copy = (length >= size - used) ? size - used - 1 : length;
6338 memcpy(dst + used, src, copy);
6339 dst[used + copy] = '\0';
6341 return used + length;
6347 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6349 Size_t length, copy;
6351 length = strlen(src);
6353 copy = (length >= size) ? size - 1 : length;
6354 memcpy(dst, src, copy);
6361 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6362 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6363 long _ftol( double ); /* Defined by VC6 C libs. */
6364 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6368 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6371 SV * const dbsv = GvSVn(PL_DBsub);
6372 /* We do not care about using sv to call CV;
6373 * it's for informational purposes only.
6376 PERL_ARGS_ASSERT_GET_DB_SUB;
6379 if (!PERLDB_SUB_NN) {
6380 GV * const gv = CvGV(cv);
6382 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6383 || strEQ(GvNAME(gv), "END")
6384 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6385 !( (SvTYPE(*svp) == SVt_PVGV)
6386 && (GvCV((const GV *)*svp) == cv) )))) {
6387 /* Use GV from the stack as a fallback. */
6388 /* GV is potentially non-unique, or contain different CV. */
6389 SV * const tmp = newRV(MUTABLE_SV(cv));
6390 sv_setsv(dbsv, tmp);
6394 gv_efullname3(dbsv, gv, NULL);
6398 const int type = SvTYPE(dbsv);
6399 if (type < SVt_PVIV && type != SVt_IV)
6400 sv_upgrade(dbsv, SVt_PVIV);
6401 (void)SvIOK_on(dbsv);
6402 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6407 Perl_my_dirfd(pTHX_ DIR * dir) {
6409 /* Most dirfd implementations have problems when passed NULL. */
6414 #elif defined(HAS_DIR_DD_FD)
6417 Perl_die(aTHX_ PL_no_func, "dirfd");
6424 Perl_get_re_arg(pTHX_ SV *sv) {
6430 sv = MUTABLE_SV(SvRV(sv));
6431 if (SvTYPE(sv) == SVt_REGEXP)
6432 return (REGEXP*) sv;
6440 * c-indentation-style: bsd
6442 * indent-tabs-mode: t
6445 * ex: set ts=8 sts=4 sw=4 noet: