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
29 #include "perliol.h" /* For PerlIOUnix_refcnt */
35 # define SIG_ERR ((Sighandler_t) -1)
40 /* Missing protos on LynxOS */
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 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
74 # define ALWAYS_NEED_THX
77 /* paranoid version of system's malloc() */
80 Perl_safesysmalloc(MEM_SIZE size)
82 #ifdef ALWAYS_NEED_THX
88 PerlIO_printf(Perl_error_log,
89 "Allocation too large: %lx\n", size) FLUSH;
92 #endif /* HAS_64K_LIMIT */
93 #ifdef PERL_TRACK_MEMPOOL
97 if ((SSize_t)size < 0)
98 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
100 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
101 PERL_ALLOC_CHECK(ptr);
103 #ifdef PERL_TRACK_MEMPOOL
104 struct perl_memory_debug_header *const header
105 = (struct perl_memory_debug_header *)ptr;
109 PoisonNew(((char *)ptr), size, char);
112 #ifdef PERL_TRACK_MEMPOOL
113 header->interpreter = aTHX;
114 /* Link us into the list. */
115 header->prev = &PL_memory_debug_header;
116 header->next = PL_memory_debug_header.next;
117 PL_memory_debug_header.next = header;
118 header->next->prev = header;
122 ptr = (Malloc_t)((char*)ptr+sTHX);
124 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
128 #ifndef ALWAYS_NEED_THX
134 return write_no_mem();
140 /* paranoid version of system's realloc() */
143 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
145 #ifdef ALWAYS_NEED_THX
149 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
150 Malloc_t PerlMem_realloc();
151 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
155 PerlIO_printf(Perl_error_log,
156 "Reallocation too large: %lx\n", size) FLUSH;
159 #endif /* HAS_64K_LIMIT */
166 return safesysmalloc(size);
167 #ifdef PERL_TRACK_MEMPOOL
168 where = (Malloc_t)((char*)where-sTHX);
171 struct perl_memory_debug_header *const header
172 = (struct perl_memory_debug_header *)where;
174 if (header->interpreter != aTHX) {
175 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
176 header->interpreter, aTHX);
178 assert(header->next->prev == header);
179 assert(header->prev->next == header);
181 if (header->size > size) {
182 const MEM_SIZE freed_up = header->size - size;
183 char *start_of_freed = ((char *)where) + size;
184 PoisonFree(start_of_freed, freed_up, char);
191 if ((SSize_t)size < 0)
192 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
194 ptr = (Malloc_t)PerlMem_realloc(where,size);
195 PERL_ALLOC_CHECK(ptr);
197 /* MUST do this fixup first, before doing ANYTHING else, as anything else
198 might allocate memory/free/move memory, and until we do the fixup, it
199 may well be chasing (and writing to) free memory. */
200 #ifdef PERL_TRACK_MEMPOOL
202 struct perl_memory_debug_header *const header
203 = (struct perl_memory_debug_header *)ptr;
206 if (header->size < size) {
207 const MEM_SIZE fresh = size - header->size;
208 char *start_of_fresh = ((char *)ptr) + size;
209 PoisonNew(start_of_fresh, fresh, char);
213 header->next->prev = header;
214 header->prev->next = header;
216 ptr = (Malloc_t)((char*)ptr+sTHX);
220 /* In particular, must do that fixup above before logging anything via
221 *printf(), as it can reallocate memory, which can cause SEGVs. */
223 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
224 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
231 #ifndef ALWAYS_NEED_THX
237 return write_no_mem();
243 /* safe version of system's free() */
246 Perl_safesysfree(Malloc_t where)
248 #ifdef ALWAYS_NEED_THX
253 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
255 #ifdef PERL_TRACK_MEMPOOL
256 where = (Malloc_t)((char*)where-sTHX);
258 struct perl_memory_debug_header *const header
259 = (struct perl_memory_debug_header *)where;
261 if (header->interpreter != aTHX) {
262 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
263 header->interpreter, aTHX);
266 Perl_croak_nocontext("panic: duplicate free");
269 Perl_croak_nocontext("panic: bad free, header->next==NULL");
270 if (header->next->prev != header || header->prev->next != header) {
271 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
272 "header=%p, ->prev->next=%p",
273 header->next->prev, header,
276 /* Unlink us from the chain. */
277 header->next->prev = header->prev;
278 header->prev->next = header->next;
280 PoisonNew(where, header->size, char);
282 /* Trigger the duplicate free warning. */
290 /* safe version of system's calloc() */
293 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
295 #ifdef ALWAYS_NEED_THX
299 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
300 MEM_SIZE total_size = 0;
303 /* Even though calloc() for zero bytes is strange, be robust. */
304 if (size && (count <= MEM_SIZE_MAX / size)) {
305 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
306 total_size = size * count;
311 #ifdef PERL_TRACK_MEMPOOL
312 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
318 if (total_size > 0xffff) {
319 PerlIO_printf(Perl_error_log,
320 "Allocation too large: %lx\n", total_size) FLUSH;
323 #endif /* HAS_64K_LIMIT */
325 if ((SSize_t)size < 0 || (SSize_t)count < 0)
326 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
327 (UV)size, (UV)count);
329 #ifdef PERL_TRACK_MEMPOOL
330 /* Have to use malloc() because we've added some space for our tracking
332 /* malloc(0) is non-portable. */
333 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
335 /* Use calloc() because it might save a memset() if the memory is fresh
336 and clean from the OS. */
338 ptr = (Malloc_t)PerlMem_calloc(count, size);
339 else /* calloc(0) is non-portable. */
340 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
342 PERL_ALLOC_CHECK(ptr);
343 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));
345 #ifdef PERL_TRACK_MEMPOOL
347 struct perl_memory_debug_header *const header
348 = (struct perl_memory_debug_header *)ptr;
350 memset((void*)ptr, 0, total_size);
351 header->interpreter = aTHX;
352 /* Link us into the list. */
353 header->prev = &PL_memory_debug_header;
354 header->next = PL_memory_debug_header.next;
355 PL_memory_debug_header.next = header;
356 header->next->prev = header;
358 header->size = total_size;
360 ptr = (Malloc_t)((char*)ptr+sTHX);
366 #ifndef ALWAYS_NEED_THX
371 return write_no_mem();
375 /* These must be defined when not using Perl's malloc for binary
380 Malloc_t Perl_malloc (MEM_SIZE nbytes)
383 return (Malloc_t)PerlMem_malloc(nbytes);
386 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
389 return (Malloc_t)PerlMem_calloc(elements, size);
392 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
395 return (Malloc_t)PerlMem_realloc(where, nbytes);
398 Free_t Perl_mfree (Malloc_t where)
406 /* copy a string up to some (non-backslashed) delimiter, if any */
409 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
413 PERL_ARGS_ASSERT_DELIMCPY;
415 for (tolen = 0; from < fromend; from++, tolen++) {
417 if (from[1] != delim) {
424 else if (*from == delim)
435 /* return ptr to little string in big string, NULL if not found */
436 /* This routine was donated by Corey Satten. */
439 Perl_instr(register const char *big, register const char *little)
443 PERL_ARGS_ASSERT_INSTR;
454 for (x=big,s=little; *s; /**/ ) {
465 return (char*)(big-1);
470 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond
471 * the final character desired to be checked */
474 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
476 PERL_ARGS_ASSERT_NINSTR;
480 const char first = *little;
482 bigend -= lend - little++;
484 while (big <= bigend) {
485 if (*big++ == first) {
486 for (x=big,s=little; s < lend; x++,s++) {
490 return (char*)(big-1);
497 /* reverse of the above--find last substring */
500 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
503 const I32 first = *little;
504 const char * const littleend = lend;
506 PERL_ARGS_ASSERT_RNINSTR;
508 if (little >= littleend)
509 return (char*)bigend;
511 big = bigend - (littleend - little++);
512 while (big >= bigbeg) {
516 for (x=big+2,s=little; s < littleend; /**/ ) {
525 return (char*)(big+1);
530 /* As a space optimization, we do not compile tables for strings of length
531 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
532 special-cased in fbm_instr().
534 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
537 =head1 Miscellaneous Functions
539 =for apidoc fbm_compile
541 Analyses the string in order to make fast searches on it using fbm_instr()
542 -- the Boyer-Moore algorithm.
548 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
558 PERL_ARGS_ASSERT_FBM_COMPILE;
560 if (isGV_with_GP(sv))
566 if (flags & FBMcf_TAIL) {
567 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
568 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
569 if (mg && mg->mg_len >= 0)
572 s = (U8*)SvPV_force_mutable(sv, len);
573 if (len == 0) /* TAIL might be on a zero-length string. */
575 SvUPGRADE(sv, SVt_PVMG);
580 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
581 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
582 to call SvVALID_off() if the scalar was assigned to.
584 The comment itself (and "deeper magic" below) date back to
585 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
587 where the magic (presumably) was that the scalar had a BM table hidden
590 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
591 the table instead of the previous (somewhat hacky) approach of co-opting
592 the string buffer and storing it after the string. */
594 assert(!mg_find(sv, PERL_MAGIC_bm));
595 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
599 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
601 const U8 mlen = (len>255) ? 255 : (U8)len;
602 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
605 Newx(table, 256, U8);
606 memset((void*)table, mlen, 256);
607 mg->mg_ptr = (char *)table;
610 s += len - 1; /* last char */
613 if (table[*s] == mlen)
619 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
620 for (i = 0; i < len; i++) {
621 if (PL_freq[s[i]] < frequency) {
623 frequency = PL_freq[s[i]];
626 BmRARE(sv) = s[rarest];
627 BmPREVIOUS(sv) = rarest;
628 BmUSEFUL(sv) = 100; /* Initial value */
629 if (flags & FBMcf_TAIL)
631 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
632 BmRARE(sv), BmPREVIOUS(sv)));
635 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
636 /* If SvTAIL is actually due to \Z or \z, this gives false positives
640 =for apidoc fbm_instr
642 Returns the location of the SV in the string delimited by C<big> and
643 C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
644 does not have to be fbm_compiled, but the search will not be as fast
651 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
655 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
656 STRLEN littlelen = l;
657 const I32 multiline = flags & FBMrf_MULTILINE;
659 PERL_ARGS_ASSERT_FBM_INSTR;
661 if ((STRLEN)(bigend - big) < littlelen) {
662 if ( SvTAIL(littlestr)
663 && ((STRLEN)(bigend - big) == littlelen - 1)
665 || (*big == *little &&
666 memEQ((char *)big, (char *)little, littlelen - 1))))
671 switch (littlelen) { /* Special cases for 0, 1 and 2 */
673 return (char*)big; /* Cannot be SvTAIL! */
675 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
676 /* Know that bigend != big. */
677 if (bigend[-1] == '\n')
678 return (char *)(bigend - 1);
679 return (char *) bigend;
687 if (SvTAIL(littlestr))
688 return (char *) bigend;
691 if (SvTAIL(littlestr) && !multiline) {
692 if (bigend[-1] == '\n' && bigend[-2] == *little)
693 return (char*)bigend - 2;
694 if (bigend[-1] == *little)
695 return (char*)bigend - 1;
699 /* This should be better than FBM if c1 == c2, and almost
700 as good otherwise: maybe better since we do less indirection.
701 And we save a lot of memory by caching no table. */
702 const unsigned char c1 = little[0];
703 const unsigned char c2 = little[1];
708 while (s <= bigend) {
718 goto check_1char_anchor;
729 goto check_1char_anchor;
732 while (s <= bigend) {
737 goto check_1char_anchor;
746 check_1char_anchor: /* One char and anchor! */
747 if (SvTAIL(littlestr) && (*bigend == *little))
748 return (char *)bigend; /* bigend is already decremented. */
751 break; /* Only lengths 0 1 and 2 have special-case code. */
754 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
755 s = bigend - littlelen;
756 if (s >= big && bigend[-1] == '\n' && *s == *little
757 /* Automatically of length > 2 */
758 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
760 return (char*)s; /* how sweet it is */
763 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
765 return (char*)s + 1; /* how sweet it is */
769 if (!SvVALID(littlestr)) {
770 char * const b = ninstr((char*)big,(char*)bigend,
771 (char*)little, (char*)little + littlelen);
773 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
774 /* Chop \n from littlestr: */
775 s = bigend - littlelen + 1;
777 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
787 if (littlelen > (STRLEN)(bigend - big))
791 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
792 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
793 const unsigned char *oldlittle;
795 --littlelen; /* Last char found by table lookup */
798 little += littlelen; /* last char */
804 if ((tmp = table[*s])) {
805 if ((s += tmp) < bigend)
809 else { /* less expensive than calling strncmp() */
810 unsigned char * const olds = s;
815 if (*--s == *--little)
817 s = olds + 1; /* here we pay the price for failure */
819 if (s < bigend) /* fake up continue to outer loop */
829 && memEQ((char *)(bigend - littlelen),
830 (char *)(oldlittle - littlelen), littlelen) )
831 return (char*)bigend - littlelen;
837 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
840 PERL_ARGS_ASSERT_SCREAMINSTR;
841 PERL_UNUSED_ARG(bigstr);
842 PERL_UNUSED_ARG(littlestr);
843 PERL_UNUSED_ARG(start_shift);
844 PERL_UNUSED_ARG(end_shift);
845 PERL_UNUSED_ARG(old_posp);
846 PERL_UNUSED_ARG(last);
848 /* This function must only ever be called on a scalar with study magic,
849 but those do not happen any more. */
850 Perl_croak(aTHX_ "panic: screaminstr");
857 Returns true if the leading len bytes of the strings s1 and s2 are the same
858 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
859 match themselves and their opposite case counterparts. Non-cased and non-ASCII
860 range bytes match only themselves.
867 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
869 const U8 *a = (const U8 *)s1;
870 const U8 *b = (const U8 *)s2;
872 PERL_ARGS_ASSERT_FOLDEQ;
877 if (*a != *b && *a != PL_fold[*b])
884 Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
886 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
887 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
888 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
889 * does it check that the strings each have at least 'len' characters */
891 const U8 *a = (const U8 *)s1;
892 const U8 *b = (const U8 *)s2;
894 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
899 if (*a != *b && *a != PL_fold_latin1[*b]) {
908 =for apidoc foldEQ_locale
910 Returns true if the leading len bytes of the strings s1 and s2 are the same
911 case-insensitively in the current locale; false otherwise.
917 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
920 const U8 *a = (const U8 *)s1;
921 const U8 *b = (const U8 *)s2;
923 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)
985 Newx(newaddr,len+1,char);
986 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
988 /* might not be null terminated */
990 return (char *) CopyD(pv,newaddr,len,char);
993 return (char *) ZeroD(newaddr,len+1,char);
998 =for apidoc savesharedpv
1000 A version of C<savepv()> which allocates the duplicate string in memory
1001 which is shared between threads.
1006 Perl_savesharedpv(pTHX_ const char *pv)
1013 pvlen = strlen(pv)+1;
1014 newaddr = (char*)PerlMemShared_malloc(pvlen);
1016 return write_no_mem();
1018 return (char*)memcpy(newaddr, pv, pvlen);
1022 =for apidoc savesharedpvn
1024 A version of C<savepvn()> which allocates the duplicate string in memory
1025 which is shared between threads. (With the specific difference that a NULL
1026 pointer is not acceptable)
1031 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1033 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1035 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1038 return write_no_mem();
1040 newaddr[len] = '\0';
1041 return (char*)memcpy(newaddr, pv, len);
1045 =for apidoc savesvpv
1047 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1048 the passed in SV using C<SvPV()>
1054 Perl_savesvpv(pTHX_ SV *sv)
1057 const char * const pv = SvPV_const(sv, len);
1060 PERL_ARGS_ASSERT_SAVESVPV;
1063 Newx(newaddr,len,char);
1064 return (char *) CopyD(pv,newaddr,len,char);
1068 =for apidoc savesharedsvpv
1070 A version of C<savesharedpv()> which allocates the duplicate string in
1071 memory which is shared between threads.
1077 Perl_savesharedsvpv(pTHX_ SV *sv)
1080 const char * const pv = SvPV_const(sv, len);
1082 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1084 return savesharedpvn(pv, len);
1087 /* the SV for Perl_form() and mess() is not kept in an arena */
1096 if (PL_phase != PERL_PHASE_DESTRUCT)
1097 return newSVpvs_flags("", SVs_TEMP);
1102 /* Create as PVMG now, to avoid any upgrading later */
1104 Newxz(any, 1, XPVMG);
1105 SvFLAGS(sv) = SVt_PVMG;
1106 SvANY(sv) = (void*)any;
1108 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1113 #if defined(PERL_IMPLICIT_CONTEXT)
1115 Perl_form_nocontext(const char* pat, ...)
1120 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1121 va_start(args, pat);
1122 retval = vform(pat, &args);
1126 #endif /* PERL_IMPLICIT_CONTEXT */
1129 =head1 Miscellaneous Functions
1132 Takes a sprintf-style format pattern and conventional
1133 (non-SV) arguments and returns the formatted string.
1135 (char *) Perl_form(pTHX_ const char* pat, ...)
1137 can be used any place a string (char *) is required:
1139 char * s = Perl_form("%d.%d",major,minor);
1141 Uses a single private buffer so if you want to format several strings you
1142 must explicitly copy the earlier strings away (and free the copies when you
1149 Perl_form(pTHX_ const char* pat, ...)
1153 PERL_ARGS_ASSERT_FORM;
1154 va_start(args, pat);
1155 retval = vform(pat, &args);
1161 Perl_vform(pTHX_ const char *pat, va_list *args)
1163 SV * const sv = mess_alloc();
1164 PERL_ARGS_ASSERT_VFORM;
1165 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1170 =for apidoc Am|SV *|mess|const char *pat|...
1172 Take a sprintf-style format pattern and argument list. These are used to
1173 generate a string message. If the message does not end with a newline,
1174 then it will be extended with some indication of the current location
1175 in the code, as described for L</mess_sv>.
1177 Normally, the resulting message is returned in a new mortal SV.
1178 During global destruction a single SV may be shared between uses of
1184 #if defined(PERL_IMPLICIT_CONTEXT)
1186 Perl_mess_nocontext(const char *pat, ...)
1191 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1192 va_start(args, pat);
1193 retval = vmess(pat, &args);
1197 #endif /* PERL_IMPLICIT_CONTEXT */
1200 Perl_mess(pTHX_ const char *pat, ...)
1204 PERL_ARGS_ASSERT_MESS;
1205 va_start(args, pat);
1206 retval = vmess(pat, &args);
1212 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1215 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1217 PERL_ARGS_ASSERT_CLOSEST_COP;
1219 if (!o || o == PL_op)
1222 if (o->op_flags & OPf_KIDS) {
1224 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1227 /* If the OP_NEXTSTATE has been optimised away we can still use it
1228 * the get the file and line number. */
1230 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1231 cop = (const COP *)kid;
1233 /* Keep searching, and return when we've found something. */
1235 new_cop = closest_cop(cop, kid);
1241 /* Nothing found. */
1247 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1249 Expands a message, intended for the user, to include an indication of
1250 the current location in the code, if the message does not already appear
1253 C<basemsg> is the initial message or object. If it is a reference, it
1254 will be used as-is and will be the result of this function. Otherwise it
1255 is used as a string, and if it already ends with a newline, it is taken
1256 to be complete, and the result of this function will be the same string.
1257 If the message does not end with a newline, then a segment such as C<at
1258 foo.pl line 37> will be appended, and possibly other clauses indicating
1259 the current state of execution. The resulting message will end with a
1262 Normally, the resulting message is returned in a new mortal SV.
1263 During global destruction a single SV may be shared between uses of this
1264 function. If C<consume> is true, then the function is permitted (but not
1265 required) to modify and return C<basemsg> instead of allocating a new SV.
1271 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1276 PERL_ARGS_ASSERT_MESS_SV;
1278 if (SvROK(basemsg)) {
1284 sv_setsv(sv, basemsg);
1289 if (SvPOK(basemsg) && consume) {
1294 sv_copypv(sv, basemsg);
1297 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1299 * Try and find the file and line for PL_op. This will usually be
1300 * PL_curcop, but it might be a cop that has been optimised away. We
1301 * can try to find such a cop by searching through the optree starting
1302 * from the sibling of PL_curcop.
1305 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1310 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1311 OutCopFILE(cop), (IV)CopLINE(cop));
1312 /* Seems that GvIO() can be untrustworthy during global destruction. */
1313 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1314 && IoLINES(GvIOp(PL_last_in_gv)))
1317 const bool line_mode = (RsSIMPLE(PL_rs) &&
1318 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1319 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1320 SVfARG(PL_last_in_gv == PL_argvgv
1322 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1323 line_mode ? "line" : "chunk",
1324 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1326 if (PL_phase == PERL_PHASE_DESTRUCT)
1327 sv_catpvs(sv, " during global destruction");
1328 sv_catpvs(sv, ".\n");
1334 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1336 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1337 argument list. These are used to generate a string message. If the
1338 message does not end with a newline, then it will be extended with
1339 some indication of the current location in the code, as described for
1342 Normally, the resulting message is returned in a new mortal SV.
1343 During global destruction a single SV may be shared between uses of
1350 Perl_vmess(pTHX_ const char *pat, va_list *args)
1353 SV * const sv = mess_alloc();
1355 PERL_ARGS_ASSERT_VMESS;
1357 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1358 return mess_sv(sv, 1);
1362 Perl_write_to_stderr(pTHX_ SV* msv)
1368 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1370 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1371 && (io = GvIO(PL_stderrgv))
1372 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1373 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
1374 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1377 /* SFIO can really mess with your errno */
1380 PerlIO * const serr = Perl_error_log;
1382 do_print(msv, serr);
1383 (void)PerlIO_flush(serr);
1391 =head1 Warning and Dieing
1394 /* Common code used in dieing and warning */
1397 S_with_queued_errors(pTHX_ SV *ex)
1399 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1400 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1401 sv_catsv(PL_errors, ex);
1402 ex = sv_mortalcopy(PL_errors);
1403 SvCUR_set(PL_errors, 0);
1409 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1415 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1416 /* sv_2cv might call Perl_croak() or Perl_warner() */
1417 SV * const oldhook = *hook;
1425 cv = sv_2cv(oldhook, &stash, &gv, 0);
1427 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1437 exarg = newSVsv(ex);
1438 SvREADONLY_on(exarg);
1441 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1445 call_sv(MUTABLE_SV(cv), G_DISCARD);
1454 =for apidoc Am|OP *|die_sv|SV *baseex
1456 Behaves the same as L</croak_sv>, except for the return type.
1457 It should be used only where the C<OP *> return type is required.
1458 The function never actually returns.
1464 Perl_die_sv(pTHX_ SV *baseex)
1466 PERL_ARGS_ASSERT_DIE_SV;
1468 assert(0); /* NOTREACHED */
1473 =for apidoc Am|OP *|die|const char *pat|...
1475 Behaves the same as L</croak>, except for the return type.
1476 It should be used only where the C<OP *> return type is required.
1477 The function never actually returns.
1482 #if defined(PERL_IMPLICIT_CONTEXT)
1484 Perl_die_nocontext(const char* pat, ...)
1488 va_start(args, pat);
1490 assert(0); /* NOTREACHED */
1494 #endif /* PERL_IMPLICIT_CONTEXT */
1497 Perl_die(pTHX_ const char* pat, ...)
1500 va_start(args, pat);
1502 assert(0); /* NOTREACHED */
1508 =for apidoc Am|void|croak_sv|SV *baseex
1510 This is an XS interface to Perl's C<die> function.
1512 C<baseex> is the error message or object. If it is a reference, it
1513 will be used as-is. Otherwise it is used as a string, and if it does
1514 not end with a newline then it will be extended with some indication of
1515 the current location in the code, as described for L</mess_sv>.
1517 The error message or object will be used as an exception, by default
1518 returning control to the nearest enclosing C<eval>, but subject to
1519 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1520 function never returns normally.
1522 To die with a simple string message, the L</croak> function may be
1529 Perl_croak_sv(pTHX_ SV *baseex)
1531 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1532 PERL_ARGS_ASSERT_CROAK_SV;
1533 invoke_exception_hook(ex, FALSE);
1538 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1540 This is an XS interface to Perl's C<die> function.
1542 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1543 argument list. These are used to generate a string message. If the
1544 message does not end with a newline, then it will be extended with
1545 some indication of the current location in the code, as described for
1548 The error message will be used as an exception, by default
1549 returning control to the nearest enclosing C<eval>, but subject to
1550 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1551 function never returns normally.
1553 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1554 (C<$@>) will be used as an error message or object instead of building an
1555 error message from arguments. If you want to throw a non-string object,
1556 or build an error message in an SV yourself, it is preferable to use
1557 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1563 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1565 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1566 invoke_exception_hook(ex, FALSE);
1571 =for apidoc Am|void|croak|const char *pat|...
1573 This is an XS interface to Perl's C<die> function.
1575 Take a sprintf-style format pattern and argument list. These are used to
1576 generate a string message. If the message does not end with a newline,
1577 then it will be extended with some indication of the current location
1578 in the code, as described for L</mess_sv>.
1580 The error message will be used as an exception, by default
1581 returning control to the nearest enclosing C<eval>, but subject to
1582 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1583 function never returns normally.
1585 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1586 (C<$@>) will be used as an error message or object instead of building an
1587 error message from arguments. If you want to throw a non-string object,
1588 or build an error message in an SV yourself, it is preferable to use
1589 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1594 #if defined(PERL_IMPLICIT_CONTEXT)
1596 Perl_croak_nocontext(const char *pat, ...)
1600 va_start(args, pat);
1602 assert(0); /* NOTREACHED */
1605 #endif /* PERL_IMPLICIT_CONTEXT */
1608 Perl_croak(pTHX_ const char *pat, ...)
1611 va_start(args, pat);
1613 assert(0); /* NOTREACHED */
1618 =for apidoc Am|void|croak_no_modify
1620 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1621 terser object code than using C<Perl_croak>. Less code used on exception code
1622 paths reduces CPU cache pressure.
1628 Perl_croak_no_modify()
1630 Perl_croak_nocontext( "%s", PL_no_modify);
1634 =for apidoc Am|void|warn_sv|SV *baseex
1636 This is an XS interface to Perl's C<warn> function.
1638 C<baseex> is the error message or object. If it is a reference, it
1639 will be used as-is. Otherwise it is used as a string, and if it does
1640 not end with a newline then it will be extended with some indication of
1641 the current location in the code, as described for L</mess_sv>.
1643 The error message or object will by default be written to standard error,
1644 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1646 To warn with a simple string message, the L</warn> function may be
1653 Perl_warn_sv(pTHX_ SV *baseex)
1655 SV *ex = mess_sv(baseex, 0);
1656 PERL_ARGS_ASSERT_WARN_SV;
1657 if (!invoke_exception_hook(ex, TRUE))
1658 write_to_stderr(ex);
1662 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1664 This is an XS interface to Perl's C<warn> function.
1666 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1667 argument list. These are used to generate a string message. If the
1668 message does not end with a newline, then it will be extended with
1669 some indication of the current location in the code, as described for
1672 The error message or object will by default be written to standard error,
1673 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1675 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1681 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1683 SV *ex = vmess(pat, args);
1684 PERL_ARGS_ASSERT_VWARN;
1685 if (!invoke_exception_hook(ex, TRUE))
1686 write_to_stderr(ex);
1690 =for apidoc Am|void|warn|const char *pat|...
1692 This is an XS interface to Perl's C<warn> function.
1694 Take a sprintf-style format pattern and argument list. These are used to
1695 generate a string message. If the message does not end with a newline,
1696 then it will be extended with some indication of the current location
1697 in the code, as described for L</mess_sv>.
1699 The error message or object will by default be written to standard error,
1700 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1702 Unlike with L</croak>, C<pat> is not permitted to be null.
1707 #if defined(PERL_IMPLICIT_CONTEXT)
1709 Perl_warn_nocontext(const char *pat, ...)
1713 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1714 va_start(args, pat);
1718 #endif /* PERL_IMPLICIT_CONTEXT */
1721 Perl_warn(pTHX_ const char *pat, ...)
1724 PERL_ARGS_ASSERT_WARN;
1725 va_start(args, pat);
1730 #if defined(PERL_IMPLICIT_CONTEXT)
1732 Perl_warner_nocontext(U32 err, const char *pat, ...)
1736 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1737 va_start(args, pat);
1738 vwarner(err, pat, &args);
1741 #endif /* PERL_IMPLICIT_CONTEXT */
1744 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1746 PERL_ARGS_ASSERT_CK_WARNER_D;
1748 if (Perl_ckwarn_d(aTHX_ err)) {
1750 va_start(args, pat);
1751 vwarner(err, pat, &args);
1757 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1759 PERL_ARGS_ASSERT_CK_WARNER;
1761 if (Perl_ckwarn(aTHX_ err)) {
1763 va_start(args, pat);
1764 vwarner(err, pat, &args);
1770 Perl_warner(pTHX_ U32 err, const char* pat,...)
1773 PERL_ARGS_ASSERT_WARNER;
1774 va_start(args, pat);
1775 vwarner(err, pat, &args);
1780 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1783 PERL_ARGS_ASSERT_VWARNER;
1784 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1785 SV * const msv = vmess(pat, args);
1787 invoke_exception_hook(msv, FALSE);
1791 Perl_vwarn(aTHX_ pat, args);
1795 /* implements the ckWARN? macros */
1798 Perl_ckwarn(pTHX_ U32 w)
1801 /* If lexical warnings have not been set, use $^W. */
1803 return PL_dowarn & G_WARN_ON;
1805 return ckwarn_common(w);
1808 /* implements the ckWARN?_d macro */
1811 Perl_ckwarn_d(pTHX_ U32 w)
1814 /* If lexical warnings have not been set then default classes warn. */
1818 return ckwarn_common(w);
1822 S_ckwarn_common(pTHX_ U32 w)
1824 if (PL_curcop->cop_warnings == pWARN_ALL)
1827 if (PL_curcop->cop_warnings == pWARN_NONE)
1830 /* Check the assumption that at least the first slot is non-zero. */
1831 assert(unpackWARN1(w));
1833 /* Check the assumption that it is valid to stop as soon as a zero slot is
1835 if (!unpackWARN2(w)) {
1836 assert(!unpackWARN3(w));
1837 assert(!unpackWARN4(w));
1838 } else if (!unpackWARN3(w)) {
1839 assert(!unpackWARN4(w));
1842 /* Right, dealt with all the special cases, which are implemented as non-
1843 pointers, so there is a pointer to a real warnings mask. */
1845 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1847 } while (w >>= WARNshift);
1852 /* Set buffer=NULL to get a new one. */
1854 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1856 const MEM_SIZE len_wanted =
1857 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1858 PERL_UNUSED_CONTEXT;
1859 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1862 (specialWARN(buffer) ?
1863 PerlMemShared_malloc(len_wanted) :
1864 PerlMemShared_realloc(buffer, len_wanted));
1866 Copy(bits, (buffer + 1), size, char);
1867 if (size < WARNsize)
1868 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1872 /* since we've already done strlen() for both nam and val
1873 * we can use that info to make things faster than
1874 * sprintf(s, "%s=%s", nam, val)
1876 #define my_setenv_format(s, nam, nlen, val, vlen) \
1877 Copy(nam, s, nlen, char); \
1879 Copy(val, s+(nlen+1), vlen, char); \
1880 *(s+(nlen+1+vlen)) = '\0'
1882 #ifdef USE_ENVIRON_ARRAY
1883 /* VMS' my_setenv() is in vms.c */
1884 #if !defined(WIN32) && !defined(NETWARE)
1886 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1890 /* only parent thread can modify process environment */
1891 if (PL_curinterp == aTHX)
1894 #ifndef PERL_USE_SAFE_PUTENV
1895 if (!PL_use_safe_putenv) {
1896 /* most putenv()s leak, so we manipulate environ directly */
1898 const I32 len = strlen(nam);
1901 /* where does it go? */
1902 for (i = 0; environ[i]; i++) {
1903 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1907 if (environ == PL_origenviron) { /* need we copy environment? */
1913 while (environ[max])
1915 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1916 for (j=0; j<max; j++) { /* copy environment */
1917 const int len = strlen(environ[j]);
1918 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1919 Copy(environ[j], tmpenv[j], len+1, char);
1922 environ = tmpenv; /* tell exec where it is now */
1925 safesysfree(environ[i]);
1926 while (environ[i]) {
1927 environ[i] = environ[i+1];
1932 if (!environ[i]) { /* does not exist yet */
1933 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1934 environ[i+1] = NULL; /* make sure it's null terminated */
1937 safesysfree(environ[i]);
1941 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1942 /* all that work just for this */
1943 my_setenv_format(environ[i], nam, nlen, val, vlen);
1946 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1947 # if defined(HAS_UNSETENV)
1949 (void)unsetenv(nam);
1951 (void)setenv(nam, val, 1);
1953 # else /* ! HAS_UNSETENV */
1954 (void)setenv(nam, val, 1);
1955 # endif /* HAS_UNSETENV */
1957 # if defined(HAS_UNSETENV)
1959 (void)unsetenv(nam);
1961 const int nlen = strlen(nam);
1962 const int vlen = strlen(val);
1963 char * const new_env =
1964 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1965 my_setenv_format(new_env, nam, nlen, val, vlen);
1966 (void)putenv(new_env);
1968 # else /* ! HAS_UNSETENV */
1970 const int nlen = strlen(nam);
1976 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1977 /* all that work just for this */
1978 my_setenv_format(new_env, nam, nlen, val, vlen);
1979 (void)putenv(new_env);
1980 # endif /* HAS_UNSETENV */
1981 # endif /* __CYGWIN__ */
1982 #ifndef PERL_USE_SAFE_PUTENV
1988 #else /* WIN32 || NETWARE */
1991 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1995 const int nlen = strlen(nam);
2002 Newx(envstr, nlen+vlen+2, char);
2003 my_setenv_format(envstr, nam, nlen, val, vlen);
2004 (void)PerlEnv_putenv(envstr);
2008 #endif /* WIN32 || NETWARE */
2010 #endif /* !VMS && !EPOC*/
2012 #ifdef UNLINK_ALL_VERSIONS
2014 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2018 PERL_ARGS_ASSERT_UNLNK;
2020 while (PerlLIO_unlink(f) >= 0)
2022 return retries ? 0 : -1;
2026 /* this is a drop-in replacement for bcopy() */
2027 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2029 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2031 char * const retval = to;
2033 PERL_ARGS_ASSERT_MY_BCOPY;
2037 if (from - to >= 0) {
2045 *(--to) = *(--from);
2051 /* this is a drop-in replacement for memset() */
2054 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2056 char * const retval = loc;
2058 PERL_ARGS_ASSERT_MY_MEMSET;
2068 /* this is a drop-in replacement for bzero() */
2069 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2071 Perl_my_bzero(register char *loc, register I32 len)
2073 char * const retval = loc;
2075 PERL_ARGS_ASSERT_MY_BZERO;
2085 /* this is a drop-in replacement for memcmp() */
2086 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2088 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2090 const U8 *a = (const U8 *)s1;
2091 const U8 *b = (const U8 *)s2;
2094 PERL_ARGS_ASSERT_MY_MEMCMP;
2099 if ((tmp = *a++ - *b++))
2104 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2107 /* This vsprintf replacement should generally never get used, since
2108 vsprintf was available in both System V and BSD 2.11. (There may
2109 be some cross-compilation or embedded set-ups where it is needed,
2112 If you encounter a problem in this function, it's probably a symptom
2113 that Configure failed to detect your system's vprintf() function.
2114 See the section on "item vsprintf" in the INSTALL file.
2116 This version may compile on systems with BSD-ish <stdio.h>,
2117 but probably won't on others.
2120 #ifdef USE_CHAR_VSPRINTF
2125 vsprintf(char *dest, const char *pat, void *args)
2129 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2130 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2131 FILE_cnt(&fakebuf) = 32767;
2133 /* These probably won't compile -- If you really need
2134 this, you'll have to figure out some other method. */
2135 fakebuf._ptr = dest;
2136 fakebuf._cnt = 32767;
2141 fakebuf._flag = _IOWRT|_IOSTRG;
2142 _doprnt(pat, args, &fakebuf); /* what a kludge */
2143 #if defined(STDIO_PTR_LVALUE)
2144 *(FILE_ptr(&fakebuf)++) = '\0';
2146 /* PerlIO has probably #defined away fputc, but we want it here. */
2148 # undef fputc /* XXX Should really restore it later */
2150 (void)fputc('\0', &fakebuf);
2152 #ifdef USE_CHAR_VSPRINTF
2155 return 0; /* perl doesn't use return value */
2159 #endif /* HAS_VPRINTF */
2162 #if BYTEORDER != 0x4321
2164 Perl_my_swap(pTHX_ short s)
2166 #if (BYTEORDER & 1) == 0
2169 result = ((s & 255) << 8) + ((s >> 8) & 255);
2177 Perl_my_htonl(pTHX_ long l)
2181 char c[sizeof(long)];
2184 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2185 #if BYTEORDER == 0x12345678
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");
2200 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2201 u.c[o & 0xf] = (l >> s) & 255;
2209 Perl_my_ntohl(pTHX_ long l)
2213 char c[sizeof(long)];
2216 #if BYTEORDER == 0x1234
2217 u.c[0] = (l >> 24) & 255;
2218 u.c[1] = (l >> 16) & 255;
2219 u.c[2] = (l >> 8) & 255;
2223 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2224 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2231 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2232 l |= (u.c[o & 0xf] & 255) << s;
2239 #endif /* BYTEORDER != 0x4321 */
2243 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2244 * If these functions are defined,
2245 * the BYTEORDER is neither 0x1234 nor 0x4321.
2246 * However, this is not assumed.
2250 #define HTOLE(name,type) \
2252 name (register type n) \
2256 char c[sizeof(type)]; \
2260 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2261 u.c[i] = (n >> s) & 0xFF; \
2266 #define LETOH(name,type) \
2268 name (register type n) \
2272 char c[sizeof(type)]; \
2278 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2279 n |= ((type)(u.c[i] & 0xFF)) << s; \
2285 * Big-endian byte order functions.
2288 #define HTOBE(name,type) \
2290 name (register type n) \
2294 char c[sizeof(type)]; \
2297 U32 s = 8*(sizeof(u.c)-1); \
2298 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2299 u.c[i] = (n >> s) & 0xFF; \
2304 #define BETOH(name,type) \
2306 name (register type n) \
2310 char c[sizeof(type)]; \
2313 U32 s = 8*(sizeof(u.c)-1); \
2316 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2317 n |= ((type)(u.c[i] & 0xFF)) << s; \
2323 * If we just can't do it...
2326 #define NOT_AVAIL(name,type) \
2328 name (register type n) \
2330 Perl_croak_nocontext(#name "() not available"); \
2331 return n; /* not reached */ \
2335 #if defined(HAS_HTOVS) && !defined(htovs)
2338 #if defined(HAS_HTOVL) && !defined(htovl)
2341 #if defined(HAS_VTOHS) && !defined(vtohs)
2344 #if defined(HAS_VTOHL) && !defined(vtohl)
2348 #ifdef PERL_NEED_MY_HTOLE16
2350 HTOLE(Perl_my_htole16,U16)
2352 NOT_AVAIL(Perl_my_htole16,U16)
2355 #ifdef PERL_NEED_MY_LETOH16
2357 LETOH(Perl_my_letoh16,U16)
2359 NOT_AVAIL(Perl_my_letoh16,U16)
2362 #ifdef PERL_NEED_MY_HTOBE16
2364 HTOBE(Perl_my_htobe16,U16)
2366 NOT_AVAIL(Perl_my_htobe16,U16)
2369 #ifdef PERL_NEED_MY_BETOH16
2371 BETOH(Perl_my_betoh16,U16)
2373 NOT_AVAIL(Perl_my_betoh16,U16)
2377 #ifdef PERL_NEED_MY_HTOLE32
2379 HTOLE(Perl_my_htole32,U32)
2381 NOT_AVAIL(Perl_my_htole32,U32)
2384 #ifdef PERL_NEED_MY_LETOH32
2386 LETOH(Perl_my_letoh32,U32)
2388 NOT_AVAIL(Perl_my_letoh32,U32)
2391 #ifdef PERL_NEED_MY_HTOBE32
2393 HTOBE(Perl_my_htobe32,U32)
2395 NOT_AVAIL(Perl_my_htobe32,U32)
2398 #ifdef PERL_NEED_MY_BETOH32
2400 BETOH(Perl_my_betoh32,U32)
2402 NOT_AVAIL(Perl_my_betoh32,U32)
2406 #ifdef PERL_NEED_MY_HTOLE64
2408 HTOLE(Perl_my_htole64,U64)
2410 NOT_AVAIL(Perl_my_htole64,U64)
2413 #ifdef PERL_NEED_MY_LETOH64
2415 LETOH(Perl_my_letoh64,U64)
2417 NOT_AVAIL(Perl_my_letoh64,U64)
2420 #ifdef PERL_NEED_MY_HTOBE64
2422 HTOBE(Perl_my_htobe64,U64)
2424 NOT_AVAIL(Perl_my_htobe64,U64)
2427 #ifdef PERL_NEED_MY_BETOH64
2429 BETOH(Perl_my_betoh64,U64)
2431 NOT_AVAIL(Perl_my_betoh64,U64)
2435 #ifdef PERL_NEED_MY_HTOLES
2436 HTOLE(Perl_my_htoles,short)
2438 #ifdef PERL_NEED_MY_LETOHS
2439 LETOH(Perl_my_letohs,short)
2441 #ifdef PERL_NEED_MY_HTOBES
2442 HTOBE(Perl_my_htobes,short)
2444 #ifdef PERL_NEED_MY_BETOHS
2445 BETOH(Perl_my_betohs,short)
2448 #ifdef PERL_NEED_MY_HTOLEI
2449 HTOLE(Perl_my_htolei,int)
2451 #ifdef PERL_NEED_MY_LETOHI
2452 LETOH(Perl_my_letohi,int)
2454 #ifdef PERL_NEED_MY_HTOBEI
2455 HTOBE(Perl_my_htobei,int)
2457 #ifdef PERL_NEED_MY_BETOHI
2458 BETOH(Perl_my_betohi,int)
2461 #ifdef PERL_NEED_MY_HTOLEL
2462 HTOLE(Perl_my_htolel,long)
2464 #ifdef PERL_NEED_MY_LETOHL
2465 LETOH(Perl_my_letohl,long)
2467 #ifdef PERL_NEED_MY_HTOBEL
2468 HTOBE(Perl_my_htobel,long)
2470 #ifdef PERL_NEED_MY_BETOHL
2471 BETOH(Perl_my_betohl,long)
2475 Perl_my_swabn(void *ptr, int n)
2477 char *s = (char *)ptr;
2478 char *e = s + (n-1);
2481 PERL_ARGS_ASSERT_MY_SWABN;
2483 for (n /= 2; n > 0; s++, e--, n--) {
2491 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2493 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2502 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2504 PERL_FLUSHALL_FOR_CHILD;
2505 This = (*mode == 'w');
2509 taint_proper("Insecure %s%s", "EXEC");
2511 if (PerlProc_pipe(p) < 0)
2513 /* Try for another pipe pair for error return */
2514 if (PerlProc_pipe(pp) >= 0)
2516 while ((pid = PerlProc_fork()) < 0) {
2517 if (errno != EAGAIN) {
2518 PerlLIO_close(p[This]);
2519 PerlLIO_close(p[that]);
2521 PerlLIO_close(pp[0]);
2522 PerlLIO_close(pp[1]);
2526 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2535 /* Close parent's end of error status pipe (if any) */
2537 PerlLIO_close(pp[0]);
2538 #if defined(HAS_FCNTL) && defined(F_SETFD)
2539 /* Close error pipe automatically if exec works */
2540 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2543 /* Now dup our end of _the_ pipe to right position */
2544 if (p[THIS] != (*mode == 'r')) {
2545 PerlLIO_dup2(p[THIS], *mode == 'r');
2546 PerlLIO_close(p[THIS]);
2547 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2548 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2551 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2552 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2553 /* No automatic close - do it by hand */
2560 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2566 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2572 do_execfree(); /* free any memory malloced by child on fork */
2574 PerlLIO_close(pp[1]);
2575 /* Keep the lower of the two fd numbers */
2576 if (p[that] < p[This]) {
2577 PerlLIO_dup2(p[This], p[that]);
2578 PerlLIO_close(p[This]);
2582 PerlLIO_close(p[that]); /* close child's end of pipe */
2584 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2585 SvUPGRADE(sv,SVt_IV);
2587 PL_forkprocess = pid;
2588 /* If we managed to get status pipe check for exec fail */
2589 if (did_pipes && pid > 0) {
2594 while (n < sizeof(int)) {
2595 n1 = PerlLIO_read(pp[0],
2596 (void*)(((char*)&errkid)+n),
2602 PerlLIO_close(pp[0]);
2604 if (n) { /* Error */
2606 PerlLIO_close(p[This]);
2607 if (n != sizeof(int))
2608 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2610 pid2 = wait4pid(pid, &status, 0);
2611 } while (pid2 == -1 && errno == EINTR);
2612 errno = errkid; /* Propagate errno from kid */
2617 PerlLIO_close(pp[0]);
2618 return PerlIO_fdopen(p[This], mode);
2620 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2621 return my_syspopen4(aTHX_ NULL, mode, n, args);
2623 Perl_croak(aTHX_ "List form of piped open not implemented");
2624 return (PerlIO *) NULL;
2629 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2630 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2632 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2639 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2643 PERL_ARGS_ASSERT_MY_POPEN;
2645 PERL_FLUSHALL_FOR_CHILD;
2648 return my_syspopen(aTHX_ cmd,mode);
2651 This = (*mode == 'w');
2653 if (doexec && TAINTING_get) {
2655 taint_proper("Insecure %s%s", "EXEC");
2657 if (PerlProc_pipe(p) < 0)
2659 if (doexec && PerlProc_pipe(pp) >= 0)
2661 while ((pid = PerlProc_fork()) < 0) {
2662 if (errno != EAGAIN) {
2663 PerlLIO_close(p[This]);
2664 PerlLIO_close(p[that]);
2666 PerlLIO_close(pp[0]);
2667 PerlLIO_close(pp[1]);
2670 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2673 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2683 PerlLIO_close(pp[0]);
2684 #if defined(HAS_FCNTL) && defined(F_SETFD)
2685 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2688 if (p[THIS] != (*mode == 'r')) {
2689 PerlLIO_dup2(p[THIS], *mode == 'r');
2690 PerlLIO_close(p[THIS]);
2691 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2692 PerlLIO_close(p[THAT]);
2695 PerlLIO_close(p[THAT]);
2698 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2705 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2710 /* may or may not use the shell */
2711 do_exec3(cmd, pp[1], did_pipes);
2714 #endif /* defined OS2 */
2716 #ifdef PERLIO_USING_CRLF
2717 /* Since we circumvent IO layers when we manipulate low-level
2718 filedescriptors directly, need to manually switch to the
2719 default, binary, low-level mode; see PerlIOBuf_open(). */
2720 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2723 #ifdef PERL_USES_PL_PIDSTATUS
2724 hv_clear(PL_pidstatus); /* we have no children */
2730 do_execfree(); /* free any memory malloced by child on vfork */
2732 PerlLIO_close(pp[1]);
2733 if (p[that] < p[This]) {
2734 PerlLIO_dup2(p[This], p[that]);
2735 PerlLIO_close(p[This]);
2739 PerlLIO_close(p[that]);
2741 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2742 SvUPGRADE(sv,SVt_IV);
2744 PL_forkprocess = pid;
2745 if (did_pipes && pid > 0) {
2750 while (n < sizeof(int)) {
2751 n1 = PerlLIO_read(pp[0],
2752 (void*)(((char*)&errkid)+n),
2758 PerlLIO_close(pp[0]);
2760 if (n) { /* Error */
2762 PerlLIO_close(p[This]);
2763 if (n != sizeof(int))
2764 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2766 pid2 = wait4pid(pid, &status, 0);
2767 } while (pid2 == -1 && errno == EINTR);
2768 errno = errkid; /* Propagate errno from kid */
2773 PerlLIO_close(pp[0]);
2774 return PerlIO_fdopen(p[This], mode);
2780 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2782 PERL_ARGS_ASSERT_MY_POPEN;
2783 PERL_FLUSHALL_FOR_CHILD;
2784 /* Call system's popen() to get a FILE *, then import it.
2785 used 0 for 2nd parameter to PerlIO_importFILE;
2788 return PerlIO_importFILE(popen(cmd, mode), 0);
2792 FILE *djgpp_popen();
2794 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2796 PERL_FLUSHALL_FOR_CHILD;
2797 /* Call system's popen() to get a FILE *, then import it.
2798 used 0 for 2nd parameter to PerlIO_importFILE;
2801 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2804 #if defined(__LIBCATAMOUNT__)
2806 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2814 #endif /* !DOSISH */
2816 /* this is called in parent before the fork() */
2818 Perl_atfork_lock(void)
2821 #if defined(USE_ITHREADS)
2822 /* locks must be held in locking order (if any) */
2824 MUTEX_LOCK(&PL_malloc_mutex);
2830 /* this is called in both parent and child after the fork() */
2832 Perl_atfork_unlock(void)
2835 #if defined(USE_ITHREADS)
2836 /* locks must be released in same order as in atfork_lock() */
2838 MUTEX_UNLOCK(&PL_malloc_mutex);
2847 #if defined(HAS_FORK)
2849 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2854 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2855 * handlers elsewhere in the code */
2860 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2861 Perl_croak_nocontext("fork() not available");
2863 #endif /* HAS_FORK */
2868 Perl_dump_fds(pTHX_ const char *const s)
2873 PERL_ARGS_ASSERT_DUMP_FDS;
2875 PerlIO_printf(Perl_debug_log,"%s", s);
2876 for (fd = 0; fd < 32; fd++) {
2877 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2878 PerlIO_printf(Perl_debug_log," %d",fd);
2880 PerlIO_printf(Perl_debug_log,"\n");
2883 #endif /* DUMP_FDS */
2887 dup2(int oldfd, int newfd)
2889 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2892 PerlLIO_close(newfd);
2893 return fcntl(oldfd, F_DUPFD, newfd);
2895 #define DUP2_MAX_FDS 256
2896 int fdtmp[DUP2_MAX_FDS];
2902 PerlLIO_close(newfd);
2903 /* good enough for low fd's... */
2904 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2905 if (fdx >= DUP2_MAX_FDS) {
2913 PerlLIO_close(fdtmp[--fdx]);
2920 #ifdef HAS_SIGACTION
2923 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2926 struct sigaction act, oact;
2929 /* only "parent" interpreter can diddle signals */
2930 if (PL_curinterp != aTHX)
2931 return (Sighandler_t) SIG_ERR;
2934 act.sa_handler = (void(*)(int))handler;
2935 sigemptyset(&act.sa_mask);
2938 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2939 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2941 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2942 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2943 act.sa_flags |= SA_NOCLDWAIT;
2945 if (sigaction(signo, &act, &oact) == -1)
2946 return (Sighandler_t) SIG_ERR;
2948 return (Sighandler_t) oact.sa_handler;
2952 Perl_rsignal_state(pTHX_ int signo)
2954 struct sigaction oact;
2955 PERL_UNUSED_CONTEXT;
2957 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2958 return (Sighandler_t) SIG_ERR;
2960 return (Sighandler_t) oact.sa_handler;
2964 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2967 struct sigaction act;
2969 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2972 /* only "parent" interpreter can diddle signals */
2973 if (PL_curinterp != aTHX)
2977 act.sa_handler = (void(*)(int))handler;
2978 sigemptyset(&act.sa_mask);
2981 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2982 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2984 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2985 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2986 act.sa_flags |= SA_NOCLDWAIT;
2988 return sigaction(signo, &act, save);
2992 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2996 /* only "parent" interpreter can diddle signals */
2997 if (PL_curinterp != aTHX)
3001 return sigaction(signo, save, (struct sigaction *)NULL);
3004 #else /* !HAS_SIGACTION */
3007 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3009 #if defined(USE_ITHREADS) && !defined(WIN32)
3010 /* only "parent" interpreter can diddle signals */
3011 if (PL_curinterp != aTHX)
3012 return (Sighandler_t) SIG_ERR;
3015 return PerlProc_signal(signo, handler);
3026 Perl_rsignal_state(pTHX_ int signo)
3029 Sighandler_t oldsig;
3031 #if defined(USE_ITHREADS) && !defined(WIN32)
3032 /* only "parent" interpreter can diddle signals */
3033 if (PL_curinterp != aTHX)
3034 return (Sighandler_t) SIG_ERR;
3038 oldsig = PerlProc_signal(signo, sig_trap);
3039 PerlProc_signal(signo, oldsig);
3041 PerlProc_kill(PerlProc_getpid(), signo);
3046 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3048 #if defined(USE_ITHREADS) && !defined(WIN32)
3049 /* only "parent" interpreter can diddle signals */
3050 if (PL_curinterp != aTHX)
3053 *save = PerlProc_signal(signo, handler);
3054 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3058 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3060 #if defined(USE_ITHREADS) && !defined(WIN32)
3061 /* only "parent" interpreter can diddle signals */
3062 if (PL_curinterp != aTHX)
3065 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3068 #endif /* !HAS_SIGACTION */
3069 #endif /* !PERL_MICRO */
3071 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3072 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3074 Perl_my_pclose(pTHX_ PerlIO *ptr)
3077 Sigsave_t hstat, istat, qstat;
3084 const int fd = PerlIO_fileno(ptr);
3087 /* Find out whether the refcount is low enough for us to wait for the
3088 child proc without blocking. */
3089 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3091 const bool should_wait = 1;
3094 svp = av_fetch(PL_fdpid,fd,TRUE);
3095 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3097 *svp = &PL_sv_undef;
3099 if (pid == -1) { /* Opened by popen. */
3100 return my_syspclose(ptr);
3103 close_failed = (PerlIO_close(ptr) == EOF);
3106 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3107 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3108 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3110 if (should_wait) do {
3111 pid2 = wait4pid(pid, &status, 0);
3112 } while (pid2 == -1 && errno == EINTR);
3114 rsignal_restore(SIGHUP, &hstat);
3115 rsignal_restore(SIGINT, &istat);
3116 rsignal_restore(SIGQUIT, &qstat);
3124 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3129 #if defined(__LIBCATAMOUNT__)
3131 Perl_my_pclose(pTHX_ PerlIO *ptr)
3136 #endif /* !DOSISH */
3138 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3140 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3144 PERL_ARGS_ASSERT_WAIT4PID;
3147 #ifdef PERL_USES_PL_PIDSTATUS
3150 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3151 pid, rather than a string form. */
3152 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3153 if (svp && *svp != &PL_sv_undef) {
3154 *statusp = SvIVX(*svp);
3155 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3163 hv_iterinit(PL_pidstatus);
3164 if ((entry = hv_iternext(PL_pidstatus))) {
3165 SV * const sv = hv_iterval(PL_pidstatus,entry);
3167 const char * const spid = hv_iterkey(entry,&len);
3169 assert (len == sizeof(Pid_t));
3170 memcpy((char *)&pid, spid, len);
3171 *statusp = SvIVX(sv);
3172 /* The hash iterator is currently on this entry, so simply
3173 calling hv_delete would trigger the lazy delete, which on
3174 aggregate does more work, beacuse next call to hv_iterinit()
3175 would spot the flag, and have to call the delete routine,
3176 while in the meantime any new entries can't re-use that
3178 hv_iterinit(PL_pidstatus);
3179 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3186 # ifdef HAS_WAITPID_RUNTIME
3187 if (!HAS_WAITPID_RUNTIME)
3190 result = PerlProc_waitpid(pid,statusp,flags);
3193 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3194 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3197 #ifdef PERL_USES_PL_PIDSTATUS
3198 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3203 Perl_croak(aTHX_ "Can't do waitpid with flags");
3205 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3206 pidgone(result,*statusp);
3212 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3215 if (result < 0 && errno == EINTR) {
3217 errno = EINTR; /* reset in case a signal handler changed $! */
3221 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3223 #ifdef PERL_USES_PL_PIDSTATUS
3225 S_pidgone(pTHX_ Pid_t pid, int status)
3229 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3230 SvUPGRADE(sv,SVt_IV);
3231 SvIV_set(sv, status);
3236 #if defined(OS2) || defined(EPOC)
3239 int /* Cannot prototype with I32
3241 my_syspclose(PerlIO *ptr)
3244 Perl_my_pclose(pTHX_ PerlIO *ptr)
3247 /* Needs work for PerlIO ! */
3248 FILE * const f = PerlIO_findFILE(ptr);
3249 const I32 result = pclose(f);
3250 PerlIO_releaseFILE(ptr,f);
3258 Perl_my_pclose(pTHX_ PerlIO *ptr)
3260 /* Needs work for PerlIO ! */
3261 FILE * const f = PerlIO_findFILE(ptr);
3262 I32 result = djgpp_pclose(f);
3263 result = (result << 8) & 0xff00;
3264 PerlIO_releaseFILE(ptr,f);
3269 #define PERL_REPEATCPY_LINEAR 4
3271 Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count)
3273 PERL_ARGS_ASSERT_REPEATCPY;
3278 croak_memory_wrap();
3281 memset(to, *from, count);
3284 IV items, linear, half;
3286 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3287 for (items = 0; items < linear; ++items) {
3288 const char *q = from;
3290 for (todo = len; todo > 0; todo--)
3295 while (items <= half) {
3296 IV size = items * len;
3297 memcpy(p, to, size);
3303 memcpy(p, to, (count - items) * len);
3309 Perl_same_dirent(pTHX_ const char *a, const char *b)
3311 char *fa = strrchr(a,'/');
3312 char *fb = strrchr(b,'/');
3315 SV * const tmpsv = sv_newmortal();
3317 PERL_ARGS_ASSERT_SAME_DIRENT;
3330 sv_setpvs(tmpsv, ".");
3332 sv_setpvn(tmpsv, a, fa - a);
3333 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3336 sv_setpvs(tmpsv, ".");
3338 sv_setpvn(tmpsv, b, fb - b);
3339 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3341 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3342 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3344 #endif /* !HAS_RENAME */
3347 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3348 const char *const *const search_ext, I32 flags)
3351 const char *xfound = NULL;
3352 char *xfailed = NULL;
3353 char tmpbuf[MAXPATHLEN];
3358 #if defined(DOSISH) && !defined(OS2)
3359 # define SEARCH_EXTS ".bat", ".cmd", NULL
3360 # define MAX_EXT_LEN 4
3363 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3364 # define MAX_EXT_LEN 4
3367 # define SEARCH_EXTS ".pl", ".com", NULL
3368 # define MAX_EXT_LEN 4
3370 /* additional extensions to try in each dir if scriptname not found */
3372 static const char *const exts[] = { SEARCH_EXTS };
3373 const char *const *const ext = search_ext ? search_ext : exts;
3374 int extidx = 0, i = 0;
3375 const char *curext = NULL;
3377 PERL_UNUSED_ARG(search_ext);
3378 # define MAX_EXT_LEN 0
3381 PERL_ARGS_ASSERT_FIND_SCRIPT;
3384 * If dosearch is true and if scriptname does not contain path
3385 * delimiters, search the PATH for scriptname.
3387 * If SEARCH_EXTS is also defined, will look for each
3388 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3389 * while searching the PATH.
3391 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3392 * proceeds as follows:
3393 * If DOSISH or VMSISH:
3394 * + look for ./scriptname{,.foo,.bar}
3395 * + search the PATH for scriptname{,.foo,.bar}
3398 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3399 * this will not look in '.' if it's not in the PATH)
3404 # ifdef ALWAYS_DEFTYPES
3405 len = strlen(scriptname);
3406 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3407 int idx = 0, deftypes = 1;
3410 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3413 int idx = 0, deftypes = 1;
3416 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3418 /* The first time through, just add SEARCH_EXTS to whatever we
3419 * already have, so we can check for default file types. */
3421 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3427 if ((strlen(tmpbuf) + strlen(scriptname)
3428 + MAX_EXT_LEN) >= sizeof tmpbuf)
3429 continue; /* don't search dir with too-long name */
3430 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3434 if (strEQ(scriptname, "-"))
3436 if (dosearch) { /* Look in '.' first. */
3437 const char *cur = scriptname;
3439 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3441 if (strEQ(ext[i++],curext)) {
3442 extidx = -1; /* already has an ext */
3447 DEBUG_p(PerlIO_printf(Perl_debug_log,
3448 "Looking for %s\n",cur));
3449 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3450 && !S_ISDIR(PL_statbuf.st_mode)) {
3458 if (cur == scriptname) {
3459 len = strlen(scriptname);
3460 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3462 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3465 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3466 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3471 if (dosearch && !strchr(scriptname, '/')
3473 && !strchr(scriptname, '\\')
3475 && (s = PerlEnv_getenv("PATH")))
3479 bufend = s + strlen(s);
3480 while (s < bufend) {
3483 && *s != ';'; len++, s++) {
3484 if (len < sizeof tmpbuf)
3487 if (len < sizeof tmpbuf)
3490 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3496 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3497 continue; /* don't search dir with too-long name */
3500 && tmpbuf[len - 1] != '/'
3501 && tmpbuf[len - 1] != '\\'
3504 tmpbuf[len++] = '/';
3505 if (len == 2 && tmpbuf[0] == '.')
3507 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3511 len = strlen(tmpbuf);
3512 if (extidx > 0) /* reset after previous loop */
3516 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3517 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3518 if (S_ISDIR(PL_statbuf.st_mode)) {
3522 } while ( retval < 0 /* not there */
3523 && extidx>=0 && ext[extidx] /* try an extension? */
3524 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3529 if (S_ISREG(PL_statbuf.st_mode)
3530 && cando(S_IRUSR,TRUE,&PL_statbuf)
3531 #if !defined(DOSISH)
3532 && cando(S_IXUSR,TRUE,&PL_statbuf)
3536 xfound = tmpbuf; /* bingo! */
3540 xfailed = savepv(tmpbuf);
3543 if (!xfound && !seen_dot && !xfailed &&
3544 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3545 || S_ISDIR(PL_statbuf.st_mode)))
3547 seen_dot = 1; /* Disable message. */
3549 if (flags & 1) { /* do or die? */
3550 /* diag_listed_as: Can't execute %s */
3551 Perl_croak(aTHX_ "Can't %s %s%s%s",
3552 (xfailed ? "execute" : "find"),
3553 (xfailed ? xfailed : scriptname),
3554 (xfailed ? "" : " on PATH"),
3555 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3560 scriptname = xfound;
3562 return (scriptname ? savepv(scriptname) : NULL);
3565 #ifndef PERL_GET_CONTEXT_DEFINED
3568 Perl_get_context(void)
3571 #if defined(USE_ITHREADS)
3572 # ifdef OLD_PTHREADS_API
3574 int error = pthread_getspecific(PL_thr_key, &t)
3576 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3579 # ifdef I_MACH_CTHREADS
3580 return (void*)cthread_data(cthread_self());
3582 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3591 Perl_set_context(void *t)
3594 PERL_ARGS_ASSERT_SET_CONTEXT;
3595 #if defined(USE_ITHREADS)
3596 # ifdef I_MACH_CTHREADS
3597 cthread_set_data(cthread_self(), t);
3600 const int error = pthread_setspecific(PL_thr_key, t);
3602 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3610 #endif /* !PERL_GET_CONTEXT_DEFINED */
3612 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3621 Perl_get_op_names(pTHX)
3623 PERL_UNUSED_CONTEXT;
3624 return (char **)PL_op_name;
3628 Perl_get_op_descs(pTHX)
3630 PERL_UNUSED_CONTEXT;
3631 return (char **)PL_op_desc;
3635 Perl_get_no_modify(pTHX)
3637 PERL_UNUSED_CONTEXT;
3638 return PL_no_modify;
3642 Perl_get_opargs(pTHX)
3644 PERL_UNUSED_CONTEXT;
3645 return (U32 *)PL_opargs;
3649 Perl_get_ppaddr(pTHX)
3652 PERL_UNUSED_CONTEXT;
3653 return (PPADDR_t*)PL_ppaddr;
3656 #ifndef HAS_GETENV_LEN
3658 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3660 char * const env_trans = PerlEnv_getenv(env_elem);
3661 PERL_UNUSED_CONTEXT;
3662 PERL_ARGS_ASSERT_GETENV_LEN;
3664 *len = strlen(env_trans);
3671 Perl_get_vtbl(pTHX_ int vtbl_id)
3673 PERL_UNUSED_CONTEXT;
3675 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3676 ? NULL : PL_magic_vtables + vtbl_id;
3680 Perl_my_fflush_all(pTHX)
3682 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3683 return PerlIO_flush(NULL);
3685 # if defined(HAS__FWALK)
3686 extern int fflush(FILE *);
3687 /* undocumented, unprototyped, but very useful BSDism */
3688 extern void _fwalk(int (*)(FILE *));
3692 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3694 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3695 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3697 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3698 open_max = sysconf(_SC_OPEN_MAX);
3701 open_max = FOPEN_MAX;
3704 open_max = OPEN_MAX;
3715 for (i = 0; i < open_max; i++)
3716 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3717 STDIO_STREAM_ARRAY[i]._file < open_max &&
3718 STDIO_STREAM_ARRAY[i]._flag)
3719 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3723 SETERRNO(EBADF,RMS_IFI);
3730 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3732 if (ckWARN(WARN_IO)) {
3734 = gv && (isGV_with_GP(gv))
3737 const char * const direction = have == '>' ? "out" : "in";
3739 if (name && HEK_LEN(name))
3740 Perl_warner(aTHX_ packWARN(WARN_IO),
3741 "Filehandle %"HEKf" opened only for %sput",
3744 Perl_warner(aTHX_ packWARN(WARN_IO),
3745 "Filehandle opened only for %sput", direction);
3750 Perl_report_evil_fh(pTHX_ const GV *gv)
3752 const IO *io = gv ? GvIO(gv) : NULL;
3753 const PERL_BITFIELD16 op = PL_op->op_type;
3757 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3759 warn_type = WARN_CLOSED;
3763 warn_type = WARN_UNOPENED;
3766 if (ckWARN(warn_type)) {
3768 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3769 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3770 const char * const pars =
3771 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3772 const char * const func =
3774 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3775 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3777 const char * const type =
3779 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3780 ? "socket" : "filehandle");
3781 const bool have_name = name && SvCUR(name);
3782 Perl_warner(aTHX_ packWARN(warn_type),
3783 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3784 have_name ? " " : "",
3785 SVfARG(have_name ? name : &PL_sv_no));
3786 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3788 aTHX_ packWARN(warn_type),
3789 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3790 func, pars, have_name ? " " : "",
3791 SVfARG(have_name ? name : &PL_sv_no)
3796 /* To workaround core dumps from the uninitialised tm_zone we get the
3797 * system to give us a reasonable struct to copy. This fix means that
3798 * strftime uses the tm_zone and tm_gmtoff values returned by
3799 * localtime(time()). That should give the desired result most of the
3800 * time. But probably not always!
3802 * This does not address tzname aspects of NETaa14816.
3807 # ifndef STRUCT_TM_HASZONE
3808 # define STRUCT_TM_HASZONE
3812 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3813 # ifndef HAS_TM_TM_ZONE
3814 # define HAS_TM_TM_ZONE
3819 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3821 #ifdef HAS_TM_TM_ZONE
3823 const struct tm* my_tm;
3824 PERL_ARGS_ASSERT_INIT_TM;
3826 my_tm = localtime(&now);
3828 Copy(my_tm, ptm, 1, struct tm);
3830 PERL_ARGS_ASSERT_INIT_TM;
3831 PERL_UNUSED_ARG(ptm);
3836 * mini_mktime - normalise struct tm values without the localtime()
3837 * semantics (and overhead) of mktime().
3840 Perl_mini_mktime(pTHX_ struct tm *ptm)
3844 int month, mday, year, jday;
3845 int odd_cent, odd_year;
3846 PERL_UNUSED_CONTEXT;
3848 PERL_ARGS_ASSERT_MINI_MKTIME;
3850 #define DAYS_PER_YEAR 365
3851 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3852 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3853 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3854 #define SECS_PER_HOUR (60*60)
3855 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3856 /* parentheses deliberately absent on these two, otherwise they don't work */
3857 #define MONTH_TO_DAYS 153/5
3858 #define DAYS_TO_MONTH 5/153
3859 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3860 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3861 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3862 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3865 * Year/day algorithm notes:
3867 * With a suitable offset for numeric value of the month, one can find
3868 * an offset into the year by considering months to have 30.6 (153/5) days,
3869 * using integer arithmetic (i.e., with truncation). To avoid too much
3870 * messing about with leap days, we consider January and February to be
3871 * the 13th and 14th month of the previous year. After that transformation,
3872 * we need the month index we use to be high by 1 from 'normal human' usage,
3873 * so the month index values we use run from 4 through 15.
3875 * Given that, and the rules for the Gregorian calendar (leap years are those
3876 * divisible by 4 unless also divisible by 100, when they must be divisible
3877 * by 400 instead), we can simply calculate the number of days since some
3878 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3879 * the days we derive from our month index, and adding in the day of the
3880 * month. The value used here is not adjusted for the actual origin which
3881 * it normally would use (1 January A.D. 1), since we're not exposing it.
3882 * We're only building the value so we can turn around and get the
3883 * normalised values for the year, month, day-of-month, and day-of-year.
3885 * For going backward, we need to bias the value we're using so that we find
3886 * the right year value. (Basically, we don't want the contribution of
3887 * March 1st to the number to apply while deriving the year). Having done
3888 * that, we 'count up' the contribution to the year number by accounting for
3889 * full quadracenturies (400-year periods) with their extra leap days, plus
3890 * the contribution from full centuries (to avoid counting in the lost leap
3891 * days), plus the contribution from full quad-years (to count in the normal
3892 * leap days), plus the leftover contribution from any non-leap years.
3893 * At this point, if we were working with an actual leap day, we'll have 0
3894 * days left over. This is also true for March 1st, however. So, we have
3895 * to special-case that result, and (earlier) keep track of the 'odd'
3896 * century and year contributions. If we got 4 extra centuries in a qcent,
3897 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3898 * Otherwise, we add back in the earlier bias we removed (the 123 from
3899 * figuring in March 1st), find the month index (integer division by 30.6),
3900 * and the remainder is the day-of-month. We then have to convert back to
3901 * 'real' months (including fixing January and February from being 14/15 in
3902 * the previous year to being in the proper year). After that, to get
3903 * tm_yday, we work with the normalised year and get a new yearday value for
3904 * January 1st, which we subtract from the yearday value we had earlier,
3905 * representing the date we've re-built. This is done from January 1
3906 * because tm_yday is 0-origin.
3908 * Since POSIX time routines are only guaranteed to work for times since the
3909 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3910 * applies Gregorian calendar rules even to dates before the 16th century
3911 * doesn't bother me. Besides, you'd need cultural context for a given
3912 * date to know whether it was Julian or Gregorian calendar, and that's
3913 * outside the scope for this routine. Since we convert back based on the
3914 * same rules we used to build the yearday, you'll only get strange results
3915 * for input which needed normalising, or for the 'odd' century years which
3916 * were leap years in the Julian calendar but not in the Gregorian one.
3917 * I can live with that.
3919 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3920 * that's still outside the scope for POSIX time manipulation, so I don't
3924 year = 1900 + ptm->tm_year;
3925 month = ptm->tm_mon;
3926 mday = ptm->tm_mday;
3932 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3933 yearday += month*MONTH_TO_DAYS + mday + jday;
3935 * Note that we don't know when leap-seconds were or will be,
3936 * so we have to trust the user if we get something which looks
3937 * like a sensible leap-second. Wild values for seconds will
3938 * be rationalised, however.
3940 if ((unsigned) ptm->tm_sec <= 60) {
3947 secs += 60 * ptm->tm_min;
3948 secs += SECS_PER_HOUR * ptm->tm_hour;
3950 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3951 /* got negative remainder, but need positive time */
3952 /* back off an extra day to compensate */
3953 yearday += (secs/SECS_PER_DAY)-1;
3954 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3957 yearday += (secs/SECS_PER_DAY);
3958 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3961 else if (secs >= SECS_PER_DAY) {
3962 yearday += (secs/SECS_PER_DAY);
3963 secs %= SECS_PER_DAY;
3965 ptm->tm_hour = secs/SECS_PER_HOUR;
3966 secs %= SECS_PER_HOUR;
3967 ptm->tm_min = secs/60;
3969 ptm->tm_sec += secs;
3970 /* done with time of day effects */
3972 * The algorithm for yearday has (so far) left it high by 428.
3973 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3974 * bias it by 123 while trying to figure out what year it
3975 * really represents. Even with this tweak, the reverse
3976 * translation fails for years before A.D. 0001.
3977 * It would still fail for Feb 29, but we catch that one below.
3979 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3980 yearday -= YEAR_ADJUST;
3981 year = (yearday / DAYS_PER_QCENT) * 400;
3982 yearday %= DAYS_PER_QCENT;
3983 odd_cent = yearday / DAYS_PER_CENT;
3984 year += odd_cent * 100;
3985 yearday %= DAYS_PER_CENT;
3986 year += (yearday / DAYS_PER_QYEAR) * 4;
3987 yearday %= DAYS_PER_QYEAR;
3988 odd_year = yearday / DAYS_PER_YEAR;
3990 yearday %= DAYS_PER_YEAR;
3991 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3996 yearday += YEAR_ADJUST; /* recover March 1st crock */
3997 month = yearday*DAYS_TO_MONTH;
3998 yearday -= month*MONTH_TO_DAYS;
3999 /* recover other leap-year adjustment */
4008 ptm->tm_year = year - 1900;
4010 ptm->tm_mday = yearday;
4011 ptm->tm_mon = month;
4015 ptm->tm_mon = month - 1;
4017 /* re-build yearday based on Jan 1 to get tm_yday */
4019 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4020 yearday += 14*MONTH_TO_DAYS + 1;
4021 ptm->tm_yday = jday - yearday;
4022 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4026 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)
4034 PERL_ARGS_ASSERT_MY_STRFTIME;
4036 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4039 mytm.tm_hour = hour;
4040 mytm.tm_mday = mday;
4042 mytm.tm_year = year;
4043 mytm.tm_wday = wday;
4044 mytm.tm_yday = yday;
4045 mytm.tm_isdst = isdst;
4047 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4048 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4053 #ifdef HAS_TM_TM_GMTOFF
4054 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4056 #ifdef HAS_TM_TM_ZONE
4057 mytm.tm_zone = mytm2.tm_zone;
4062 Newx(buf, buflen, char);
4063 len = strftime(buf, buflen, fmt, &mytm);
4065 ** The following is needed to handle to the situation where
4066 ** tmpbuf overflows. Basically we want to allocate a buffer
4067 ** and try repeatedly. The reason why it is so complicated
4068 ** is that getting a return value of 0 from strftime can indicate
4069 ** one of the following:
4070 ** 1. buffer overflowed,
4071 ** 2. illegal conversion specifier, or
4072 ** 3. the format string specifies nothing to be returned(not
4073 ** an error). This could be because format is an empty string
4074 ** or it specifies %p that yields an empty string in some locale.
4075 ** If there is a better way to make it portable, go ahead by
4078 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4081 /* Possibly buf overflowed - try again with a bigger buf */
4082 const int fmtlen = strlen(fmt);
4083 int bufsize = fmtlen + buflen;
4085 Renew(buf, bufsize, char);
4087 buflen = strftime(buf, bufsize, fmt, &mytm);
4088 if (buflen > 0 && buflen < bufsize)
4090 /* heuristic to prevent out-of-memory errors */
4091 if (bufsize > 100*fmtlen) {
4097 Renew(buf, bufsize, char);
4102 Perl_croak(aTHX_ "panic: no strftime");
4108 #define SV_CWD_RETURN_UNDEF \
4109 sv_setsv(sv, &PL_sv_undef); \
4112 #define SV_CWD_ISDOT(dp) \
4113 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4114 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4117 =head1 Miscellaneous Functions
4119 =for apidoc getcwd_sv
4121 Fill the sv with current working directory
4126 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4127 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4128 * getcwd(3) if available
4129 * Comments from the orignal:
4130 * This is a faster version of getcwd. It's also more dangerous
4131 * because you might chdir out of a directory that you can't chdir
4135 Perl_getcwd_sv(pTHX_ register SV *sv)
4139 #ifndef INCOMPLETE_TAINTS
4143 PERL_ARGS_ASSERT_GETCWD_SV;
4147 char buf[MAXPATHLEN];
4149 /* Some getcwd()s automatically allocate a buffer of the given
4150 * size from the heap if they are given a NULL buffer pointer.
4151 * The problem is that this behaviour is not portable. */
4152 if (getcwd(buf, sizeof(buf) - 1)) {
4157 sv_setsv(sv, &PL_sv_undef);
4165 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4169 SvUPGRADE(sv, SVt_PV);
4171 if (PerlLIO_lstat(".", &statbuf) < 0) {
4172 SV_CWD_RETURN_UNDEF;
4175 orig_cdev = statbuf.st_dev;
4176 orig_cino = statbuf.st_ino;
4186 if (PerlDir_chdir("..") < 0) {
4187 SV_CWD_RETURN_UNDEF;
4189 if (PerlLIO_stat(".", &statbuf) < 0) {
4190 SV_CWD_RETURN_UNDEF;
4193 cdev = statbuf.st_dev;
4194 cino = statbuf.st_ino;
4196 if (odev == cdev && oino == cino) {
4199 if (!(dir = PerlDir_open("."))) {
4200 SV_CWD_RETURN_UNDEF;
4203 while ((dp = PerlDir_read(dir)) != NULL) {
4205 namelen = dp->d_namlen;
4207 namelen = strlen(dp->d_name);
4210 if (SV_CWD_ISDOT(dp)) {
4214 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4215 SV_CWD_RETURN_UNDEF;
4218 tdev = statbuf.st_dev;
4219 tino = statbuf.st_ino;
4220 if (tino == oino && tdev == odev) {
4226 SV_CWD_RETURN_UNDEF;
4229 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4230 SV_CWD_RETURN_UNDEF;
4233 SvGROW(sv, pathlen + namelen + 1);
4237 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4240 /* prepend current directory to the front */
4242 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4243 pathlen += (namelen + 1);
4245 #ifdef VOID_CLOSEDIR
4248 if (PerlDir_close(dir) < 0) {
4249 SV_CWD_RETURN_UNDEF;
4255 SvCUR_set(sv, pathlen);
4259 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4260 SV_CWD_RETURN_UNDEF;
4263 if (PerlLIO_stat(".", &statbuf) < 0) {
4264 SV_CWD_RETURN_UNDEF;
4267 cdev = statbuf.st_dev;
4268 cino = statbuf.st_ino;
4270 if (cdev != orig_cdev || cino != orig_cino) {
4271 Perl_croak(aTHX_ "Unstable directory path, "
4272 "current directory changed unexpectedly");
4283 #define VERSION_MAX 0x7FFFFFFF
4286 =for apidoc prescan_version
4288 Validate that a given string can be parsed as a version object, but doesn't
4289 actually perform the parsing. Can use either strict or lax validation rules.
4290 Can optionally set a number of hint variables to save the parsing code
4291 some time when tokenizing.
4296 Perl_prescan_version(pTHX_ const char *s, bool strict,
4297 const char **errstr,
4298 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4299 bool qv = (sqv ? *sqv : FALSE);
4301 int saw_decimal = 0;
4305 PERL_ARGS_ASSERT_PRESCAN_VERSION;
4307 if (qv && isDIGIT(*d))
4308 goto dotted_decimal_version;
4310 if (*d == 'v') { /* explicit v-string */
4315 else { /* degenerate v-string */
4316 /* requires v1.2.3 */
4317 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4320 dotted_decimal_version:
4321 if (strict && d[0] == '0' && isDIGIT(d[1])) {
4322 /* no leading zeros allowed */
4323 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4326 while (isDIGIT(*d)) /* integer part */
4332 d++; /* decimal point */
4337 /* require v1.2.3 */
4338 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4341 goto version_prescan_finish;
4348 while (isDIGIT(*d)) { /* just keep reading */
4350 while (isDIGIT(*d)) {
4352 /* maximum 3 digits between decimal */
4353 if (strict && j > 3) {
4354 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4359 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4362 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4367 else if (*d == '.') {
4369 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4374 else if (!isDIGIT(*d)) {
4380 if (strict && i < 2) {
4381 /* requires v1.2.3 */
4382 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4385 } /* end if dotted-decimal */
4387 { /* decimal versions */
4388 int j = 0; /* may need this later */
4389 /* special strict case for leading '.' or '0' */
4392 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4394 if (*d == '0' && isDIGIT(d[1])) {
4395 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4399 /* and we never support negative versions */
4401 BADVERSION(s,errstr,"Invalid version format (negative version number)");
4404 /* consume all of the integer part */
4408 /* look for a fractional part */
4410 /* we found it, so consume it */
4414 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4417 BADVERSION(s,errstr,"Invalid version format (version required)");
4419 /* found just an integer */
4420 goto version_prescan_finish;
4422 else if ( d == s ) {
4423 /* didn't find either integer or period */
4424 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4426 else if (*d == '_') {
4427 /* underscore can't come after integer part */
4429 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4431 else if (isDIGIT(d[1])) {
4432 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4435 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4439 /* anything else after integer part is just invalid data */
4440 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4443 /* scan the fractional part after the decimal point*/
4445 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4446 /* strict or lax-but-not-the-end */
4447 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4450 while (isDIGIT(*d)) {
4452 if (*d == '.' && isDIGIT(d[-1])) {
4454 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4457 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4459 d = (char *)s; /* start all over again */
4461 goto dotted_decimal_version;
4465 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4468 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4470 if ( ! isDIGIT(d[1]) ) {
4471 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4480 version_prescan_finish:
4484 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4485 /* trailing non-numeric data */
4486 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4494 *ssaw_decimal = saw_decimal;
4501 =for apidoc scan_version
4503 Returns a pointer to the next character after the parsed
4504 version string, as well as upgrading the passed in SV to
4507 Function must be called with an already existing SV like
4510 s = scan_version(s, SV *sv, bool qv);
4512 Performs some preprocessing to the string to ensure that
4513 it has the correct characteristics of a version. Flags the
4514 object if it contains an underscore (which denotes this
4515 is an alpha version). The boolean qv denotes that the version
4516 should be interpreted as if it had multiple decimals, even if
4523 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4528 const char *errstr = NULL;
4529 int saw_decimal = 0;
4533 AV * const av = newAV();
4534 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4536 PERL_ARGS_ASSERT_SCAN_VERSION;
4538 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4540 #ifndef NODEFAULT_SHAREKEYS
4541 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4544 while (isSPACE(*s)) /* leading whitespace is OK */
4547 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4549 /* "undef" is a special case and not an error */
4550 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4551 Perl_croak(aTHX_ "%s", errstr);
4561 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4563 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4564 if ( !qv && width < 3 )
4565 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4567 while (isDIGIT(*pos))
4569 if (!isALPHA(*pos)) {
4575 /* this is atoi() that delimits on underscores */
4576 const char *end = pos;
4580 /* the following if() will only be true after the decimal
4581 * point of a version originally created with a bare
4582 * floating point number, i.e. not quoted in any way
4584 if ( !qv && s > start && saw_decimal == 1 ) {
4588 rev += (*s - '0') * mult;
4590 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4591 || (PERL_ABS(rev) > VERSION_MAX )) {
4592 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4593 "Integer overflow in version %d",VERSION_MAX);
4604 while (--end >= s) {
4606 rev += (*end - '0') * mult;
4608 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4609 || (PERL_ABS(rev) > VERSION_MAX )) {
4610 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4611 "Integer overflow in version");
4620 /* Append revision */
4621 av_push(av, newSViv(rev));
4626 else if ( *pos == '.' )
4628 else if ( *pos == '_' && isDIGIT(pos[1]) )
4630 else if ( *pos == ',' && isDIGIT(pos[1]) )
4632 else if ( isDIGIT(*pos) )
4639 while ( isDIGIT(*pos) )
4644 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4652 if ( qv ) { /* quoted versions always get at least three terms*/
4653 I32 len = av_len(av);
4654 /* This for loop appears to trigger a compiler bug on OS X, as it
4655 loops infinitely. Yes, len is negative. No, it makes no sense.
4656 Compiler in question is:
4657 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4658 for ( len = 2 - len; len > 0; len-- )
4659 av_push(MUTABLE_AV(sv), newSViv(0));
4663 av_push(av, newSViv(0));
4666 /* need to save off the current version string for later */
4668 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4669 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4670 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4672 else if ( s > start ) {
4673 SV * orig = newSVpvn(start,s-start);
4674 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4675 /* need to insert a v to be consistent */
4676 sv_insert(orig, 0, 0, "v", 1);
4678 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4681 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4682 av_push(av, newSViv(0));
4685 /* And finally, store the AV in the hash */
4686 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4688 /* fix RT#19517 - special case 'undef' as string */
4689 if ( *s == 'u' && strEQ(s,"undef") ) {
4697 =for apidoc new_version
4699 Returns a new version object based on the passed in SV:
4701 SV *sv = new_version(SV *ver);
4703 Does not alter the passed in ver SV. See "upg_version" if you
4704 want to upgrade the SV.
4710 Perl_new_version(pTHX_ SV *ver)
4713 SV * const rv = newSV(0);
4714 PERL_ARGS_ASSERT_NEW_VERSION;
4715 if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4716 /* can just copy directly */
4719 AV * const av = newAV();
4721 /* This will get reblessed later if a derived class*/
4722 SV * const hv = newSVrv(rv, "version");
4723 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4724 #ifndef NODEFAULT_SHAREKEYS
4725 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4731 /* Begin copying all of the elements */
4732 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4733 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4735 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4736 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4738 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4740 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4741 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4744 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4746 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4747 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4750 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4751 /* This will get reblessed later if a derived class*/
4752 for ( key = 0; key <= av_len(sav); key++ )
4754 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4755 av_push(av, newSViv(rev));
4758 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4763 const MAGIC* const mg = SvVSTRING_mg(ver);
4764 if ( mg ) { /* already a v-string */
4765 const STRLEN len = mg->mg_len;
4766 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4767 sv_setpvn(rv,version,len);
4768 /* this is for consistency with the pure Perl class */
4769 if ( isDIGIT(*version) )
4770 sv_insert(rv, 0, 0, "v", 1);
4775 sv_setsv(rv,ver); /* make a duplicate */
4780 return upg_version(rv, FALSE);
4784 =for apidoc upg_version
4786 In-place upgrade of the supplied SV to a version object.
4788 SV *sv = upg_version(SV *sv, bool qv);
4790 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4791 to force this SV to be interpreted as an "extended" version.
4797 Perl_upg_version(pTHX_ SV *ver, bool qv)
4799 const char *version, *s;
4804 PERL_ARGS_ASSERT_UPG_VERSION;
4806 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4810 /* may get too much accuracy */
4812 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4814 #ifdef USE_LOCALE_NUMERIC
4815 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
4816 setlocale(LC_NUMERIC, "C");
4819 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4820 buf = SvPV(sv, len);
4823 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4826 #ifdef USE_LOCALE_NUMERIC
4827 setlocale(LC_NUMERIC, loc);
4830 while (buf[len-1] == '0' && len > 0) len--;
4831 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4832 version = savepvn(buf, len);
4836 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4837 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4841 else /* must be a string or something like a string */
4844 version = savepv(SvPV(ver,len));
4846 # if PERL_VERSION > 5
4847 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4848 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4849 /* may be a v-string */
4850 char *testv = (char *)version;
4852 for (tlen=0; tlen < len; tlen++, testv++) {
4853 /* if one of the characters is non-text assume v-string */
4854 if (testv[0] < ' ') {
4855 SV * const nsv = sv_newmortal();
4858 int saw_decimal = 0;
4859 sv_setpvf(nsv,"v%vd",ver);
4860 pos = nver = savepv(SvPV_nolen(nsv));
4862 /* scan the resulting formatted string */
4863 pos++; /* skip the leading 'v' */
4864 while ( *pos == '.' || isDIGIT(*pos) ) {
4870 /* is definitely a v-string */
4871 if ( saw_decimal >= 2 ) {
4883 s = scan_version(version, ver, qv);
4885 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4886 "Version string '%s' contains invalid data; "
4887 "ignoring: '%s'", version, s);
4895 Validates that the SV contains valid internal structure for a version object.
4896 It may be passed either the version object (RV) or the hash itself (HV). If
4897 the structure is valid, it returns the HV. If the structure is invalid,
4900 SV *hv = vverify(sv);
4902 Note that it only confirms the bare minimum structure (so as not to get
4903 confused by derived classes which may contain additional hash entries):
4907 =item * The SV is an HV or a reference to an HV
4909 =item * The hash contains a "version" key
4911 =item * The "version" key has a reference to an AV as its value
4919 Perl_vverify(pTHX_ SV *vs)
4923 PERL_ARGS_ASSERT_VVERIFY;
4928 /* see if the appropriate elements exist */
4929 if ( SvTYPE(vs) == SVt_PVHV
4930 && hv_exists(MUTABLE_HV(vs), "version", 7)
4931 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4932 && SvTYPE(sv) == SVt_PVAV )
4941 Accepts a version object and returns the normalized floating
4942 point representation. Call like:
4946 NOTE: you can pass either the object directly or the SV
4947 contained within the RV.
4949 The SV returned has a refcount of 1.
4955 Perl_vnumify(pTHX_ SV *vs)
4963 PERL_ARGS_ASSERT_VNUMIFY;
4965 /* extract the HV from the object */
4968 Perl_croak(aTHX_ "Invalid version object");
4970 /* see if various flags exist */
4971 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4973 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4974 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4979 /* attempt to retrieve the version array */
4980 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4981 return newSVpvs("0");
4987 return newSVpvs("0");
4990 digit = SvIV(*av_fetch(av, 0, 0));
4991 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4992 for ( i = 1 ; i < len ; i++ )
4994 digit = SvIV(*av_fetch(av, i, 0));
4996 const int denom = (width == 2 ? 10 : 100);
4997 const div_t term = div((int)PERL_ABS(digit),denom);
4998 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5001 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5007 digit = SvIV(*av_fetch(av, len, 0));
5008 if ( alpha && width == 3 ) /* alpha version */
5010 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5014 sv_catpvs(sv, "000");
5022 Accepts a version object and returns the normalized string
5023 representation. Call like:
5027 NOTE: you can pass either the object directly or the SV
5028 contained within the RV.
5030 The SV returned has a refcount of 1.
5036 Perl_vnormal(pTHX_ SV *vs)
5043 PERL_ARGS_ASSERT_VNORMAL;
5045 /* extract the HV from the object */
5048 Perl_croak(aTHX_ "Invalid version object");
5050 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5052 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5057 return newSVpvs("");
5059 digit = SvIV(*av_fetch(av, 0, 0));
5060 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5061 for ( i = 1 ; i < len ; i++ ) {
5062 digit = SvIV(*av_fetch(av, i, 0));
5063 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5068 /* handle last digit specially */
5069 digit = SvIV(*av_fetch(av, len, 0));
5071 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5073 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5076 if ( len <= 2 ) { /* short version, must be at least three */
5077 for ( len = 2 - len; len != 0; len-- )
5084 =for apidoc vstringify
5086 In order to maintain maximum compatibility with earlier versions
5087 of Perl, this function will return either the floating point
5088 notation or the multiple dotted notation, depending on whether
5089 the original version contained 1 or more dots, respectively.
5091 The SV returned has a refcount of 1.
5097 Perl_vstringify(pTHX_ SV *vs)
5099 PERL_ARGS_ASSERT_VSTRINGIFY;
5101 /* extract the HV from the object */
5104 Perl_croak(aTHX_ "Invalid version object");
5106 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
5108 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5112 return &PL_sv_undef;
5115 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5125 Version object aware cmp. Both operands must already have been
5126 converted into version objects.
5132 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5135 bool lalpha = FALSE;
5136 bool ralpha = FALSE;
5141 PERL_ARGS_ASSERT_VCMP;
5143 /* extract the HVs from the objects */
5146 if ( ! ( lhv && rhv ) )
5147 Perl_croak(aTHX_ "Invalid version object");
5149 /* get the left hand term */
5150 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5151 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5154 /* and the right hand term */
5155 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5156 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5164 while ( i <= m && retval == 0 )
5166 left = SvIV(*av_fetch(lav,i,0));
5167 right = SvIV(*av_fetch(rav,i,0));
5175 /* tiebreaker for alpha with identical terms */
5176 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5178 if ( lalpha && !ralpha )
5182 else if ( ralpha && !lalpha)
5188 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5192 while ( i <= r && retval == 0 )
5194 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5195 retval = -1; /* not a match after all */
5201 while ( i <= l && retval == 0 )
5203 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5204 retval = +1; /* not a match after all */
5212 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5213 # define EMULATE_SOCKETPAIR_UDP
5216 #ifdef EMULATE_SOCKETPAIR_UDP
5218 S_socketpair_udp (int fd[2]) {
5220 /* Fake a datagram socketpair using UDP to localhost. */
5221 int sockets[2] = {-1, -1};
5222 struct sockaddr_in addresses[2];
5224 Sock_size_t size = sizeof(struct sockaddr_in);
5225 unsigned short port;
5228 memset(&addresses, 0, sizeof(addresses));
5231 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5232 if (sockets[i] == -1)
5233 goto tidy_up_and_fail;
5235 addresses[i].sin_family = AF_INET;
5236 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5237 addresses[i].sin_port = 0; /* kernel choses port. */
5238 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5239 sizeof(struct sockaddr_in)) == -1)
5240 goto tidy_up_and_fail;
5243 /* Now have 2 UDP sockets. Find out which port each is connected to, and
5244 for each connect the other socket to it. */
5247 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5249 goto tidy_up_and_fail;
5250 if (size != sizeof(struct sockaddr_in))
5251 goto abort_tidy_up_and_fail;
5252 /* !1 is 0, !0 is 1 */
5253 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5254 sizeof(struct sockaddr_in)) == -1)
5255 goto tidy_up_and_fail;
5258 /* Now we have 2 sockets connected to each other. I don't trust some other
5259 process not to have already sent a packet to us (by random) so send
5260 a packet from each to the other. */
5263 /* I'm going to send my own port number. As a short.
5264 (Who knows if someone somewhere has sin_port as a bitfield and needs
5265 this routine. (I'm assuming crays have socketpair)) */
5266 port = addresses[i].sin_port;
5267 got = PerlLIO_write(sockets[i], &port, sizeof(port));
5268 if (got != sizeof(port)) {
5270 goto tidy_up_and_fail;
5271 goto abort_tidy_up_and_fail;
5275 /* Packets sent. I don't trust them to have arrived though.
5276 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5277 connect to localhost will use a second kernel thread. In 2.6 the
5278 first thread running the connect() returns before the second completes,
5279 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5280 returns 0. Poor programs have tripped up. One poor program's authors'
5281 had a 50-1 reverse stock split. Not sure how connected these were.)
5282 So I don't trust someone not to have an unpredictable UDP stack.
5286 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5287 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5291 FD_SET((unsigned int)sockets[0], &rset);
5292 FD_SET((unsigned int)sockets[1], &rset);
5294 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5295 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5296 || !FD_ISSET(sockets[1], &rset)) {
5297 /* I hope this is portable and appropriate. */
5299 goto tidy_up_and_fail;
5300 goto abort_tidy_up_and_fail;
5304 /* And the paranoia department even now doesn't trust it to have arrive
5305 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5307 struct sockaddr_in readfrom;
5308 unsigned short buffer[2];
5313 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5314 sizeof(buffer), MSG_DONTWAIT,
5315 (struct sockaddr *) &readfrom, &size);
5317 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5319 (struct sockaddr *) &readfrom, &size);
5323 goto tidy_up_and_fail;
5324 if (got != sizeof(port)
5325 || size != sizeof(struct sockaddr_in)
5326 /* Check other socket sent us its port. */
5327 || buffer[0] != (unsigned short) addresses[!i].sin_port
5328 /* Check kernel says we got the datagram from that socket */
5329 || readfrom.sin_family != addresses[!i].sin_family
5330 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5331 || readfrom.sin_port != addresses[!i].sin_port)
5332 goto abort_tidy_up_and_fail;
5335 /* My caller (my_socketpair) has validated that this is non-NULL */
5338 /* I hereby declare this connection open. May God bless all who cross
5342 abort_tidy_up_and_fail:
5343 errno = ECONNABORTED;
5347 if (sockets[0] != -1)
5348 PerlLIO_close(sockets[0]);
5349 if (sockets[1] != -1)
5350 PerlLIO_close(sockets[1]);
5355 #endif /* EMULATE_SOCKETPAIR_UDP */
5357 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5359 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5360 /* Stevens says that family must be AF_LOCAL, protocol 0.
5361 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5366 struct sockaddr_in listen_addr;
5367 struct sockaddr_in connect_addr;
5372 || family != AF_UNIX
5375 errno = EAFNOSUPPORT;
5383 #ifdef EMULATE_SOCKETPAIR_UDP
5384 if (type == SOCK_DGRAM)
5385 return S_socketpair_udp(fd);
5388 listener = PerlSock_socket(AF_INET, type, 0);
5391 memset(&listen_addr, 0, sizeof(listen_addr));
5392 listen_addr.sin_family = AF_INET;
5393 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5394 listen_addr.sin_port = 0; /* kernel choses port. */
5395 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5396 sizeof(listen_addr)) == -1)
5397 goto tidy_up_and_fail;
5398 if (PerlSock_listen(listener, 1) == -1)
5399 goto tidy_up_and_fail;
5401 connector = PerlSock_socket(AF_INET, type, 0);
5402 if (connector == -1)
5403 goto tidy_up_and_fail;
5404 /* We want to find out the port number to connect to. */
5405 size = sizeof(connect_addr);
5406 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5408 goto tidy_up_and_fail;
5409 if (size != sizeof(connect_addr))
5410 goto abort_tidy_up_and_fail;
5411 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5412 sizeof(connect_addr)) == -1)
5413 goto tidy_up_and_fail;
5415 size = sizeof(listen_addr);
5416 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5419 goto tidy_up_and_fail;
5420 if (size != sizeof(listen_addr))
5421 goto abort_tidy_up_and_fail;
5422 PerlLIO_close(listener);
5423 /* Now check we are talking to ourself by matching port and host on the
5425 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5427 goto tidy_up_and_fail;
5428 if (size != sizeof(connect_addr)
5429 || listen_addr.sin_family != connect_addr.sin_family
5430 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5431 || listen_addr.sin_port != connect_addr.sin_port) {
5432 goto abort_tidy_up_and_fail;
5438 abort_tidy_up_and_fail:
5440 errno = ECONNABORTED; /* This would be the standard thing to do. */
5442 # ifdef ECONNREFUSED
5443 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5445 errno = ETIMEDOUT; /* Desperation time. */
5452 PerlLIO_close(listener);
5453 if (connector != -1)
5454 PerlLIO_close(connector);
5456 PerlLIO_close(acceptor);
5462 /* In any case have a stub so that there's code corresponding
5463 * to the my_socketpair in embed.fnc. */
5465 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5466 #ifdef HAS_SOCKETPAIR
5467 return socketpair(family, type, protocol, fd);
5476 =for apidoc sv_nosharing
5478 Dummy routine which "shares" an SV when there is no sharing module present.
5479 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5480 Exists to avoid test for a NULL function pointer and because it could
5481 potentially warn under some level of strict-ness.
5487 Perl_sv_nosharing(pTHX_ SV *sv)
5489 PERL_UNUSED_CONTEXT;
5490 PERL_UNUSED_ARG(sv);
5495 =for apidoc sv_destroyable
5497 Dummy routine which reports that object can be destroyed when there is no
5498 sharing module present. It ignores its single SV argument, and returns
5499 'true'. Exists to avoid test for a NULL function pointer and because it
5500 could potentially warn under some level of strict-ness.
5506 Perl_sv_destroyable(pTHX_ SV *sv)
5508 PERL_UNUSED_CONTEXT;
5509 PERL_UNUSED_ARG(sv);
5514 Perl_parse_unicode_opts(pTHX_ const char **popt)
5516 const char *p = *popt;
5519 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5523 opt = (U32) atoi(p);
5526 if (*p && *p != '\n' && *p != '\r') {
5527 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5529 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5535 case PERL_UNICODE_STDIN:
5536 opt |= PERL_UNICODE_STDIN_FLAG; break;
5537 case PERL_UNICODE_STDOUT:
5538 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5539 case PERL_UNICODE_STDERR:
5540 opt |= PERL_UNICODE_STDERR_FLAG; break;
5541 case PERL_UNICODE_STD:
5542 opt |= PERL_UNICODE_STD_FLAG; break;
5543 case PERL_UNICODE_IN:
5544 opt |= PERL_UNICODE_IN_FLAG; break;
5545 case PERL_UNICODE_OUT:
5546 opt |= PERL_UNICODE_OUT_FLAG; break;
5547 case PERL_UNICODE_INOUT:
5548 opt |= PERL_UNICODE_INOUT_FLAG; break;
5549 case PERL_UNICODE_LOCALE:
5550 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5551 case PERL_UNICODE_ARGV:
5552 opt |= PERL_UNICODE_ARGV_FLAG; break;
5553 case PERL_UNICODE_UTF8CACHEASSERT:
5554 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5556 if (*p != '\n' && *p != '\r') {
5557 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5560 "Unknown Unicode option letter '%c'", *p);
5567 opt = PERL_UNICODE_DEFAULT_FLAGS;
5569 the_end_of_the_opts_parser:
5571 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5572 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5573 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5581 # include <starlet.h>
5589 * This is really just a quick hack which grabs various garbage
5590 * values. It really should be a real hash algorithm which
5591 * spreads the effect of every input bit onto every output bit,
5592 * if someone who knows about such things would bother to write it.
5593 * Might be a good idea to add that function to CORE as well.
5594 * No numbers below come from careful analysis or anything here,
5595 * except they are primes and SEED_C1 > 1E6 to get a full-width
5596 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5597 * probably be bigger too.
5600 # define SEED_C1 1000003
5601 #define SEED_C4 73819
5603 # define SEED_C1 25747
5604 #define SEED_C4 20639
5608 #define SEED_C5 26107
5610 #ifndef PERL_NO_DEV_RANDOM
5615 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5616 * in 100-ns units, typically incremented ever 10 ms. */
5617 unsigned int when[2];
5619 # ifdef HAS_GETTIMEOFDAY
5620 struct timeval when;
5626 /* This test is an escape hatch, this symbol isn't set by Configure. */
5627 #ifndef PERL_NO_DEV_RANDOM
5628 #ifndef PERL_RANDOM_DEVICE
5629 /* /dev/random isn't used by default because reads from it will block
5630 * if there isn't enough entropy available. You can compile with
5631 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5632 * is enough real entropy to fill the seed. */
5633 # define PERL_RANDOM_DEVICE "/dev/urandom"
5635 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5637 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5646 _ckvmssts(sys$gettim(when));
5647 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5649 # ifdef HAS_GETTIMEOFDAY
5650 PerlProc_gettimeofday(&when,NULL);
5651 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5654 u = (U32)SEED_C1 * when;
5657 u += SEED_C3 * (U32)PerlProc_getpid();
5658 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5659 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5660 u += SEED_C5 * (U32)PTR2UV(&when);
5666 Perl_get_hash_seed(pTHX)
5669 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5675 if (s && isDIGIT(*s))
5676 myseed = (UV)Atoul(s);
5678 #ifdef USE_HASH_SEED_EXPLICIT
5682 /* Compute a random seed */
5683 (void)seedDrand01((Rand_seed_t)seed());
5684 myseed = (UV)(Drand01() * (NV)UV_MAX);
5685 #if RANDBITS < (UVSIZE * 8)
5686 /* Since there are not enough randbits to to reach all
5687 * the bits of a UV, the low bits might need extra
5688 * help. Sum in another random number that will
5689 * fill in the low bits. */
5691 (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5692 #endif /* RANDBITS < (UVSIZE * 8) */
5693 if (myseed == 0) { /* Superparanoia. */
5694 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5696 Perl_croak(aTHX_ "Your random numbers are not that random");
5699 PL_rehash_seed_set = TRUE;
5704 #ifdef PERL_GLOBAL_STRUCT
5706 #define PERL_GLOBAL_STRUCT_INIT
5707 #include "opcode.h" /* the ppaddr and check */
5710 Perl_init_global_struct(pTHX)
5712 struct perl_vars *plvarsp = NULL;
5713 # ifdef PERL_GLOBAL_STRUCT
5714 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5715 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5716 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5717 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5718 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5722 plvarsp = PL_VarsPtr;
5723 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5728 # define PERLVAR(prefix,var,type) /**/
5729 # define PERLVARA(prefix,var,n,type) /**/
5730 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5731 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5732 # include "perlvars.h"
5737 # ifdef PERL_GLOBAL_STRUCT
5740 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5741 if (!plvarsp->Gppaddr)
5745 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5746 if (!plvarsp->Gcheck)
5748 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5749 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5751 # ifdef PERL_SET_VARS
5752 PERL_SET_VARS(plvarsp);
5754 # undef PERL_GLOBAL_STRUCT_INIT
5759 #endif /* PERL_GLOBAL_STRUCT */
5761 #ifdef PERL_GLOBAL_STRUCT
5764 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5766 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5767 # ifdef PERL_GLOBAL_STRUCT
5768 # ifdef PERL_UNSET_VARS
5769 PERL_UNSET_VARS(plvarsp);
5771 free(plvarsp->Gppaddr);
5772 free(plvarsp->Gcheck);
5773 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5779 #endif /* PERL_GLOBAL_STRUCT */
5783 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5784 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5785 * given, and you supply your own implementation.
5787 * The default implementation reads a single env var, PERL_MEM_LOG,
5788 * expecting one or more of the following:
5790 * \d+ - fd fd to write to : must be 1st (atoi)
5791 * 'm' - memlog was PERL_MEM_LOG=1
5792 * 's' - svlog was PERL_SV_LOG=1
5793 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5795 * This makes the logger controllable enough that it can reasonably be
5796 * added to the system perl.
5799 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5800 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5802 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5804 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5805 * writes to. In the default logger, this is settable at runtime.
5807 #ifndef PERL_MEM_LOG_FD
5808 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5811 #ifndef PERL_MEM_LOG_NOIMPL
5813 # ifdef DEBUG_LEAKING_SCALARS
5814 # define SV_LOG_SERIAL_FMT " [%lu]"
5815 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5817 # define SV_LOG_SERIAL_FMT
5818 # define _SV_LOG_SERIAL_ARG(sv)
5822 S_mem_log_common(enum mem_log_type mlt, const UV n,
5823 const UV typesize, const char *type_name, const SV *sv,
5824 Malloc_t oldalloc, Malloc_t newalloc,
5825 const char *filename, const int linenumber,
5826 const char *funcname)
5830 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5832 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5835 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5837 /* We can't use SVs or PerlIO for obvious reasons,
5838 * so we'll use stdio and low-level IO instead. */
5839 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5841 # ifdef HAS_GETTIMEOFDAY
5842 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5843 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5845 gettimeofday(&tv, 0);
5847 # define MEM_LOG_TIME_FMT "%10d: "
5848 # define MEM_LOG_TIME_ARG (int)when
5852 /* If there are other OS specific ways of hires time than
5853 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5854 * probably that they would be used to fill in the struct
5858 int fd = atoi(pmlenv);
5860 fd = PERL_MEM_LOG_FD;
5862 if (strchr(pmlenv, 't')) {
5863 len = my_snprintf(buf, sizeof(buf),
5864 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5865 PerlLIO_write(fd, buf, len);
5869 len = my_snprintf(buf, sizeof(buf),
5870 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5871 " %s = %"IVdf": %"UVxf"\n",
5872 filename, linenumber, funcname, n, typesize,
5873 type_name, n * typesize, PTR2UV(newalloc));
5876 len = my_snprintf(buf, sizeof(buf),
5877 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5878 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5879 filename, linenumber, funcname, n, typesize,
5880 type_name, n * typesize, PTR2UV(oldalloc),
5884 len = my_snprintf(buf, sizeof(buf),
5885 "free: %s:%d:%s: %"UVxf"\n",
5886 filename, linenumber, funcname,
5891 len = my_snprintf(buf, sizeof(buf),
5892 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5893 mlt == MLT_NEW_SV ? "new" : "del",
5894 filename, linenumber, funcname,
5895 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5900 PerlLIO_write(fd, buf, len);
5904 #endif /* !PERL_MEM_LOG_NOIMPL */
5906 #ifndef PERL_MEM_LOG_NOIMPL
5908 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5909 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5911 /* this is suboptimal, but bug compatible. User is providing their
5912 own implementation, but is getting these functions anyway, and they
5913 do nothing. But _NOIMPL users should be able to cope or fix */
5915 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5916 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5920 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5922 const char *filename, const int linenumber,
5923 const char *funcname)
5925 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5926 NULL, NULL, newalloc,
5927 filename, linenumber, funcname);
5932 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5933 Malloc_t oldalloc, Malloc_t newalloc,
5934 const char *filename, const int linenumber,
5935 const char *funcname)
5937 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5938 NULL, oldalloc, newalloc,
5939 filename, linenumber, funcname);
5944 Perl_mem_log_free(Malloc_t oldalloc,
5945 const char *filename, const int linenumber,
5946 const char *funcname)
5948 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5949 filename, linenumber, funcname);
5954 Perl_mem_log_new_sv(const SV *sv,
5955 const char *filename, const int linenumber,
5956 const char *funcname)
5958 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5959 filename, linenumber, funcname);
5963 Perl_mem_log_del_sv(const SV *sv,
5964 const char *filename, const int linenumber,
5965 const char *funcname)
5967 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5968 filename, linenumber, funcname);
5971 #endif /* PERL_MEM_LOG */
5974 =for apidoc my_sprintf
5976 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5977 the length of the string written to the buffer. Only rare pre-ANSI systems
5978 need the wrapper function - usually this is a direct call to C<sprintf>.
5982 #ifndef SPRINTF_RETURNS_STRLEN
5984 Perl_my_sprintf(char *buffer, const char* pat, ...)
5987 PERL_ARGS_ASSERT_MY_SPRINTF;
5988 va_start(args, pat);
5989 vsprintf(buffer, pat, args);
5991 return strlen(buffer);
5996 =for apidoc my_snprintf
5998 The C library C<snprintf> functionality, if available and
5999 standards-compliant (uses C<vsnprintf>, actually). However, if the
6000 C<vsnprintf> is not available, will unfortunately use the unsafe
6001 C<vsprintf> which can overrun the buffer (there is an overrun check,
6002 but that may be too late). Consider using C<sv_vcatpvf> instead, or
6003 getting C<vsnprintf>.
6008 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6012 PERL_ARGS_ASSERT_MY_SNPRINTF;
6013 va_start(ap, format);
6014 #ifdef HAS_VSNPRINTF
6015 retval = vsnprintf(buffer, len, format, ap);
6017 retval = vsprintf(buffer, format, ap);
6020 /* vsprintf() shows failure with < 0 */
6022 #ifdef HAS_VSNPRINTF
6023 /* vsnprintf() shows failure with >= len */
6025 (len > 0 && (Size_t)retval >= len)
6028 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
6033 =for apidoc my_vsnprintf
6035 The C library C<vsnprintf> if available and standards-compliant.
6036 However, if if the C<vsnprintf> is not available, will unfortunately
6037 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6038 overrun check, but that may be too late). Consider using
6039 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6044 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6050 PERL_ARGS_ASSERT_MY_VSNPRINTF;
6052 Perl_va_copy(ap, apc);
6053 # ifdef HAS_VSNPRINTF
6054 retval = vsnprintf(buffer, len, format, apc);
6056 retval = vsprintf(buffer, format, apc);
6059 # ifdef HAS_VSNPRINTF
6060 retval = vsnprintf(buffer, len, format, ap);
6062 retval = vsprintf(buffer, format, ap);
6064 #endif /* #ifdef NEED_VA_COPY */
6065 /* vsprintf() shows failure with < 0 */
6067 #ifdef HAS_VSNPRINTF
6068 /* vsnprintf() shows failure with >= len */
6070 (len > 0 && (Size_t)retval >= len)
6073 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
6078 Perl_my_clearenv(pTHX)
6081 #if ! defined(PERL_MICRO)
6082 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6084 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6085 # if defined(USE_ENVIRON_ARRAY)
6086 # if defined(USE_ITHREADS)
6087 /* only the parent thread can clobber the process environment */
6088 if (PL_curinterp == aTHX)
6089 # endif /* USE_ITHREADS */
6091 # if ! defined(PERL_USE_SAFE_PUTENV)
6092 if ( !PL_use_safe_putenv) {
6094 if (environ == PL_origenviron)
6095 environ = (char**)safesysmalloc(sizeof(char*));
6097 for (i = 0; environ[i]; i++)
6098 (void)safesysfree(environ[i]);
6101 # else /* PERL_USE_SAFE_PUTENV */
6102 # if defined(HAS_CLEARENV)
6104 # elif defined(HAS_UNSETENV)
6105 int bsiz = 80; /* Most envvar names will be shorter than this. */
6106 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6107 char *buf = (char*)safesysmalloc(bufsiz);
6108 while (*environ != NULL) {
6109 char *e = strchr(*environ, '=');
6110 int l = e ? e - *environ : (int)strlen(*environ);
6112 (void)safesysfree(buf);
6113 bsiz = l + 1; /* + 1 for the \0. */
6114 buf = (char*)safesysmalloc(bufsiz);
6116 memcpy(buf, *environ, l);
6118 (void)unsetenv(buf);
6120 (void)safesysfree(buf);
6121 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6122 /* Just null environ and accept the leakage. */
6124 # endif /* HAS_CLEARENV || HAS_UNSETENV */
6125 # endif /* ! PERL_USE_SAFE_PUTENV */
6127 # endif /* USE_ENVIRON_ARRAY */
6128 # endif /* PERL_IMPLICIT_SYS || WIN32 */
6129 #endif /* PERL_MICRO */
6132 #ifdef PERL_IMPLICIT_CONTEXT
6134 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6135 the global PL_my_cxt_index is incremented, and that value is assigned to
6136 that module's static my_cxt_index (who's address is passed as an arg).
6137 Then, for each interpreter this function is called for, it makes sure a
6138 void* slot is available to hang the static data off, by allocating or
6139 extending the interpreter's PL_my_cxt_list array */
6141 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6143 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6147 PERL_ARGS_ASSERT_MY_CXT_INIT;
6149 /* this module hasn't been allocated an index yet */
6150 #if defined(USE_ITHREADS)
6151 MUTEX_LOCK(&PL_my_ctx_mutex);
6153 *index = PL_my_cxt_index++;
6154 #if defined(USE_ITHREADS)
6155 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6159 /* make sure the array is big enough */
6160 if (PL_my_cxt_size <= *index) {
6161 if (PL_my_cxt_size) {
6162 while (PL_my_cxt_size <= *index)
6163 PL_my_cxt_size *= 2;
6164 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6167 PL_my_cxt_size = 16;
6168 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6171 /* newSV() allocates one more than needed */
6172 p = (void*)SvPVX(newSV(size-1));
6173 PL_my_cxt_list[*index] = p;
6174 Zero(p, size, char);
6178 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6181 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6186 PERL_ARGS_ASSERT_MY_CXT_INDEX;
6188 for (index = 0; index < PL_my_cxt_index; index++) {
6189 const char *key = PL_my_cxt_keys[index];
6190 /* try direct pointer compare first - there are chances to success,
6191 * and it's much faster.
6193 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6200 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6206 PERL_ARGS_ASSERT_MY_CXT_INIT;
6208 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6210 /* this module hasn't been allocated an index yet */
6211 #if defined(USE_ITHREADS)
6212 MUTEX_LOCK(&PL_my_ctx_mutex);
6214 index = PL_my_cxt_index++;
6215 #if defined(USE_ITHREADS)
6216 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6220 /* make sure the array is big enough */
6221 if (PL_my_cxt_size <= index) {
6222 int old_size = PL_my_cxt_size;
6224 if (PL_my_cxt_size) {
6225 while (PL_my_cxt_size <= index)
6226 PL_my_cxt_size *= 2;
6227 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6228 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6231 PL_my_cxt_size = 16;
6232 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6233 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6235 for (i = old_size; i < PL_my_cxt_size; i++) {
6236 PL_my_cxt_keys[i] = 0;
6237 PL_my_cxt_list[i] = 0;
6240 PL_my_cxt_keys[index] = my_cxt_key;
6241 /* newSV() allocates one more than needed */
6242 p = (void*)SvPVX(newSV(size-1));
6243 PL_my_cxt_list[index] = p;
6244 Zero(p, size, char);
6247 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6248 #endif /* PERL_IMPLICIT_CONTEXT */
6251 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
6255 const char *vn = NULL;
6256 SV *const module = PL_stack_base[ax];
6258 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
6260 if (items >= 2) /* version supplied as bootstrap arg */
6261 sv = PL_stack_base[ax + 1];
6263 /* XXX GV_ADDWARN */
6265 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6266 if (!sv || !SvOK(sv)) {
6268 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6272 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
6273 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
6274 ? sv : sv_2mortal(new_version(sv));
6275 xssv = upg_version(xssv, 0);
6276 if ( vcmp(pmsv,xssv) ) {
6277 SV *string = vstringify(xssv);
6278 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
6279 " does not match ", module, string);
6281 SvREFCNT_dec(string);
6282 string = vstringify(pmsv);
6285 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
6288 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6290 SvREFCNT_dec(string);
6292 Perl_sv_2mortal(aTHX_ xpt);
6293 Perl_croak_sv(aTHX_ xpt);
6299 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6303 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6306 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6308 /* This might croak */
6309 compver = upg_version(compver, 0);
6310 /* This should never croak */
6311 runver = new_version(PL_apiversion);
6312 if (vcmp(compver, runver)) {
6313 SV *compver_string = vstringify(compver);
6314 SV *runver_string = vstringify(runver);
6315 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6316 " of %"SVf" does not match %"SVf,
6317 compver_string, module, runver_string);
6318 Perl_sv_2mortal(aTHX_ xpt);
6320 SvREFCNT_dec(compver_string);
6321 SvREFCNT_dec(runver_string);
6323 SvREFCNT_dec(runver);
6325 Perl_croak_sv(aTHX_ xpt);
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 ); }
6367 PERL_STATIC_INLINE bool
6368 S_gv_has_usable_name(pTHX_ GV *gv)
6372 && HvENAME(GvSTASH(gv))
6373 && (gvp = (GV **)hv_fetch(
6374 GvSTASH(gv), GvNAME(gv),
6375 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6381 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6384 SV * const dbsv = GvSVn(PL_DBsub);
6385 const bool save_taint = TAINT_get; /* Accepted unused var warning under NO_TAINT_SUPPORT */
6387 /* When we are called from pp_goto (svp is null),
6388 * we do not care about using dbsv to call CV;
6389 * it's for informational purposes only.
6392 PERL_ARGS_ASSERT_GET_DB_SUB;
6396 if (!PERLDB_SUB_NN) {
6400 gv_efullname3(dbsv, gv, NULL);
6402 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6403 || strEQ(GvNAME(gv), "END")
6404 || ( /* Could be imported, and old sub redefined. */
6405 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6407 !( (SvTYPE(*svp) == SVt_PVGV)
6408 && (GvCV((const GV *)*svp) == cv)
6409 /* Use GV from the stack as a fallback. */
6410 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6414 /* GV is potentially non-unique, or contain different CV. */
6415 SV * const tmp = newRV(MUTABLE_SV(cv));
6416 sv_setsv(dbsv, tmp);
6420 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6421 sv_catpvs(dbsv, "::");
6423 dbsv, GvNAME(gv), GvNAMELEN(gv),
6424 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6429 const int type = SvTYPE(dbsv);
6430 if (type < SVt_PVIV && type != SVt_IV)
6431 sv_upgrade(dbsv, SVt_PVIV);
6432 (void)SvIOK_on(dbsv);
6433 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6435 TAINT_IF(save_taint);
6439 Perl_my_dirfd(pTHX_ DIR * dir) {
6441 /* Most dirfd implementations have problems when passed NULL. */
6446 #elif defined(HAS_DIR_DD_FD)
6449 Perl_die(aTHX_ PL_no_func, "dirfd");
6450 assert(0); /* NOT REACHED */
6456 Perl_get_re_arg(pTHX_ SV *sv) {
6462 sv = MUTABLE_SV(SvRV(sv));
6463 if (SvTYPE(sv) == SVt_REGEXP)
6464 return (REGEXP*) sv;
6472 * c-indentation-style: bsd
6474 * indent-tabs-mode: nil
6477 * ex: set ts=8 sts=4 sw=4 et: