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 */
45 # include <sys/wait.h>
50 # include <sys/select.h>
56 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
57 # define FD_CLOEXEC 1 /* NeXT needs this */
60 /* NOTE: Do not call the next three routines directly. Use the macros
61 * in handy.h, so that we can easily redefine everything to do tracking of
62 * allocated hunks back to the original New to track down any memory leaks.
63 * XXX This advice seems to be widely ignored :-( --AD August 1996.
70 /* Can't use PerlIO to write as it allocates memory */
71 PerlLIO_write(PerlIO_fileno(Perl_error_log),
72 PL_no_mem, strlen(PL_no_mem));
74 NORETURN_FUNCTION_END;
77 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
78 # define ALWAYS_NEED_THX
81 /* paranoid version of system's malloc() */
84 Perl_safesysmalloc(MEM_SIZE size)
86 #ifdef ALWAYS_NEED_THX
92 PerlIO_printf(Perl_error_log,
93 "Allocation too large: %lx\n", size) FLUSH;
96 #endif /* HAS_64K_LIMIT */
97 #ifdef PERL_TRACK_MEMPOOL
102 Perl_croak_nocontext("panic: malloc");
104 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
105 PERL_ALLOC_CHECK(ptr);
107 #ifdef PERL_TRACK_MEMPOOL
108 struct perl_memory_debug_header *const header
109 = (struct perl_memory_debug_header *)ptr;
113 PoisonNew(((char *)ptr), size, char);
116 #ifdef PERL_TRACK_MEMPOOL
117 header->interpreter = aTHX;
118 /* Link us into the list. */
119 header->prev = &PL_memory_debug_header;
120 header->next = PL_memory_debug_header.next;
121 PL_memory_debug_header.next = header;
122 header->next->prev = header;
126 ptr = (Malloc_t)((char*)ptr+sTHX);
128 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
132 #ifndef ALWAYS_NEED_THX
138 return write_no_mem();
144 /* paranoid version of system's realloc() */
147 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
149 #ifdef ALWAYS_NEED_THX
153 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
154 Malloc_t PerlMem_realloc();
155 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
159 PerlIO_printf(Perl_error_log,
160 "Reallocation too large: %lx\n", size) FLUSH;
163 #endif /* HAS_64K_LIMIT */
170 return safesysmalloc(size);
171 #ifdef PERL_TRACK_MEMPOOL
172 where = (Malloc_t)((char*)where-sTHX);
175 struct perl_memory_debug_header *const header
176 = (struct perl_memory_debug_header *)where;
178 if (header->interpreter != aTHX) {
179 Perl_croak_nocontext("panic: realloc from wrong pool");
181 assert(header->next->prev == header);
182 assert(header->prev->next == header);
184 if (header->size > size) {
185 const MEM_SIZE freed_up = header->size - size;
186 char *start_of_freed = ((char *)where) + size;
187 PoisonFree(start_of_freed, freed_up, char);
195 Perl_croak_nocontext("panic: realloc");
197 ptr = (Malloc_t)PerlMem_realloc(where,size);
198 PERL_ALLOC_CHECK(ptr);
200 /* MUST do this fixup first, before doing ANYTHING else, as anything else
201 might allocate memory/free/move memory, and until we do the fixup, it
202 may well be chasing (and writing to) free memory. */
203 #ifdef PERL_TRACK_MEMPOOL
205 struct perl_memory_debug_header *const header
206 = (struct perl_memory_debug_header *)ptr;
209 if (header->size < size) {
210 const MEM_SIZE fresh = size - header->size;
211 char *start_of_fresh = ((char *)ptr) + size;
212 PoisonNew(start_of_fresh, fresh, char);
216 header->next->prev = header;
217 header->prev->next = header;
219 ptr = (Malloc_t)((char*)ptr+sTHX);
223 /* In particular, must do that fixup above before logging anything via
224 *printf(), as it can reallocate memory, which can cause SEGVs. */
226 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
227 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
234 #ifndef ALWAYS_NEED_THX
240 return write_no_mem();
246 /* safe version of system's free() */
249 Perl_safesysfree(Malloc_t where)
251 #ifdef ALWAYS_NEED_THX
256 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
258 #ifdef PERL_TRACK_MEMPOOL
259 where = (Malloc_t)((char*)where-sTHX);
261 struct perl_memory_debug_header *const header
262 = (struct perl_memory_debug_header *)where;
264 if (header->interpreter != aTHX) {
265 Perl_croak_nocontext("panic: free from wrong pool");
268 Perl_croak_nocontext("panic: duplicate free");
270 if (!(header->next) || header->next->prev != header
271 || header->prev->next != header) {
272 Perl_croak_nocontext("panic: bad free");
274 /* Unlink us from the chain. */
275 header->next->prev = header->prev;
276 header->prev->next = header->next;
278 PoisonNew(where, header->size, char);
280 /* Trigger the duplicate free warning. */
288 /* safe version of system's calloc() */
291 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
293 #ifdef ALWAYS_NEED_THX
297 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
298 MEM_SIZE total_size = 0;
301 /* Even though calloc() for zero bytes is strange, be robust. */
302 if (size && (count <= MEM_SIZE_MAX / size)) {
303 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
304 total_size = size * count;
308 Perl_croak_nocontext("%s", PL_memory_wrap);
309 #ifdef PERL_TRACK_MEMPOOL
310 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
313 Perl_croak_nocontext("%s", PL_memory_wrap);
316 if (total_size > 0xffff) {
317 PerlIO_printf(Perl_error_log,
318 "Allocation too large: %lx\n", total_size) FLUSH;
321 #endif /* HAS_64K_LIMIT */
323 if ((long)size < 0 || (long)count < 0)
324 Perl_croak_nocontext("panic: calloc");
326 #ifdef PERL_TRACK_MEMPOOL
327 /* Have to use malloc() because we've added some space for our tracking
329 /* malloc(0) is non-portable. */
330 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
332 /* Use calloc() because it might save a memset() if the memory is fresh
333 and clean from the OS. */
335 ptr = (Malloc_t)PerlMem_calloc(count, size);
336 else /* calloc(0) is non-portable. */
337 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
339 PERL_ALLOC_CHECK(ptr);
340 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));
342 #ifdef PERL_TRACK_MEMPOOL
344 struct perl_memory_debug_header *const header
345 = (struct perl_memory_debug_header *)ptr;
347 memset((void*)ptr, 0, total_size);
348 header->interpreter = aTHX;
349 /* Link us into the list. */
350 header->prev = &PL_memory_debug_header;
351 header->next = PL_memory_debug_header.next;
352 PL_memory_debug_header.next = header;
353 header->next->prev = header;
355 header->size = total_size;
357 ptr = (Malloc_t)((char*)ptr+sTHX);
363 #ifndef ALWAYS_NEED_THX
368 return write_no_mem();
372 /* These must be defined when not using Perl's malloc for binary
377 Malloc_t Perl_malloc (MEM_SIZE nbytes)
380 return (Malloc_t)PerlMem_malloc(nbytes);
383 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
386 return (Malloc_t)PerlMem_calloc(elements, size);
389 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
392 return (Malloc_t)PerlMem_realloc(where, nbytes);
395 Free_t Perl_mfree (Malloc_t where)
403 /* copy a string up to some (non-backslashed) delimiter, if any */
406 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
410 PERL_ARGS_ASSERT_DELIMCPY;
412 for (tolen = 0; from < fromend; from++, tolen++) {
414 if (from[1] != delim) {
421 else if (*from == delim)
432 /* return ptr to little string in big string, NULL if not found */
433 /* This routine was donated by Corey Satten. */
436 Perl_instr(register const char *big, register const char *little)
440 PERL_ARGS_ASSERT_INSTR;
448 register const char *s, *x;
451 for (x=big,s=little; *s; /**/ ) {
462 return (char*)(big-1);
467 /* same as instr but allow embedded nulls */
470 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
472 PERL_ARGS_ASSERT_NINSTR;
476 const char first = *little;
478 bigend -= lend - little++;
480 while (big <= bigend) {
481 if (*big++ == first) {
482 for (x=big,s=little; s < lend; x++,s++) {
486 return (char*)(big-1);
493 /* reverse of the above--find last substring */
496 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
498 register const char *bigbeg;
499 register const I32 first = *little;
500 register const char * const littleend = lend;
502 PERL_ARGS_ASSERT_RNINSTR;
504 if (little >= littleend)
505 return (char*)bigend;
507 big = bigend - (littleend - little++);
508 while (big >= bigbeg) {
509 register const char *s, *x;
512 for (x=big+2,s=little; s < littleend; /**/ ) {
521 return (char*)(big+1);
526 /* As a space optimization, we do not compile tables for strings of length
527 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
528 special-cased in fbm_instr().
530 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
533 =head1 Miscellaneous Functions
535 =for apidoc fbm_compile
537 Analyses the string in order to make fast searches on it using fbm_instr()
538 -- the Boyer-Moore algorithm.
544 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
547 register const U8 *s;
553 PERL_ARGS_ASSERT_FBM_COMPILE;
555 if (flags & FBMcf_TAIL) {
556 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
557 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
558 if (mg && mg->mg_len >= 0)
561 s = (U8*)SvPV_force_mutable(sv, len);
562 if (len == 0) /* TAIL might be on a zero-length string. */
564 SvUPGRADE(sv, SVt_PVGV);
569 const unsigned char *sb;
570 const U8 mlen = (len>255) ? 255 : (U8)len;
573 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
575 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
576 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
577 memset((void*)table, mlen, 256);
579 sb = s - mlen + 1; /* first char (maybe) */
581 if (table[*s] == mlen)
586 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
588 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
590 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
591 for (i = 0; i < len; i++) {
592 if (PL_freq[s[i]] < frequency) {
594 frequency = PL_freq[s[i]];
597 BmFLAGS(sv) = (U8)flags;
598 BmRARE(sv) = s[rarest];
599 BmPREVIOUS(sv) = rarest;
600 BmUSEFUL(sv) = 100; /* Initial value */
601 if (flags & FBMcf_TAIL)
603 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
604 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
607 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
608 /* If SvTAIL is actually due to \Z or \z, this gives false positives
612 =for apidoc fbm_instr
614 Returns the location of the SV in the string delimited by C<str> and
615 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
616 does not have to be fbm_compiled, but the search will not be as fast
623 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
625 register unsigned char *s;
627 register const unsigned char *little
628 = (const unsigned char *)SvPV_const(littlestr,l);
629 register STRLEN littlelen = l;
630 register const I32 multiline = flags & FBMrf_MULTILINE;
632 PERL_ARGS_ASSERT_FBM_INSTR;
634 if ((STRLEN)(bigend - big) < littlelen) {
635 if ( SvTAIL(littlestr)
636 && ((STRLEN)(bigend - big) == littlelen - 1)
638 || (*big == *little &&
639 memEQ((char *)big, (char *)little, littlelen - 1))))
644 if (littlelen <= 2) { /* Special-cased */
646 if (littlelen == 1) {
647 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
648 /* Know that bigend != big. */
649 if (bigend[-1] == '\n')
650 return (char *)(bigend - 1);
651 return (char *) bigend;
659 if (SvTAIL(littlestr))
660 return (char *) bigend;
664 return (char*)big; /* Cannot be SvTAIL! */
667 if (SvTAIL(littlestr) && !multiline) {
668 if (bigend[-1] == '\n' && bigend[-2] == *little)
669 return (char*)bigend - 2;
670 if (bigend[-1] == *little)
671 return (char*)bigend - 1;
675 /* This should be better than FBM if c1 == c2, and almost
676 as good otherwise: maybe better since we do less indirection.
677 And we save a lot of memory by caching no table. */
678 const unsigned char c1 = little[0];
679 const unsigned char c2 = little[1];
684 while (s <= bigend) {
694 goto check_1char_anchor;
705 goto check_1char_anchor;
708 while (s <= bigend) {
713 goto check_1char_anchor;
722 check_1char_anchor: /* One char and anchor! */
723 if (SvTAIL(littlestr) && (*bigend == *little))
724 return (char *)bigend; /* bigend is already decremented. */
727 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
728 s = bigend - littlelen;
729 if (s >= big && bigend[-1] == '\n' && *s == *little
730 /* Automatically of length > 2 */
731 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
733 return (char*)s; /* how sweet it is */
736 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
738 return (char*)s + 1; /* how sweet it is */
742 if (!SvVALID(littlestr)) {
743 char * const b = ninstr((char*)big,(char*)bigend,
744 (char*)little, (char*)little + littlelen);
746 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
747 /* Chop \n from littlestr: */
748 s = bigend - littlelen + 1;
750 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
760 if (littlelen > (STRLEN)(bigend - big))
764 register const unsigned char * const table
765 = little + littlelen + PERL_FBM_TABLE_OFFSET;
766 register const unsigned char *oldlittle;
768 --littlelen; /* Last char found by table lookup */
771 little += littlelen; /* last char */
777 if ((tmp = table[*s])) {
778 if ((s += tmp) < bigend)
782 else { /* less expensive than calling strncmp() */
783 register unsigned char * const olds = s;
788 if (*--s == *--little)
790 s = olds + 1; /* here we pay the price for failure */
792 if (s < bigend) /* fake up continue to outer loop */
801 && (BmFLAGS(littlestr) & FBMcf_TAIL)
802 && memEQ((char *)(bigend - littlelen),
803 (char *)(oldlittle - littlelen), littlelen) )
804 return (char*)bigend - littlelen;
809 /* start_shift, end_shift are positive quantities which give offsets
810 of ends of some substring of bigstr.
811 If "last" we want the last occurrence.
812 old_posp is the way of communication between consequent calls if
813 the next call needs to find the .
814 The initial *old_posp should be -1.
816 Note that we take into account SvTAIL, so one can get extra
817 optimizations if _ALL flag is set.
820 /* If SvTAIL is actually due to \Z or \z, this gives false positives
821 if PL_multiline. In fact if !PL_multiline the authoritative answer
822 is not supported yet. */
825 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
828 register const unsigned char *big;
830 register I32 previous;
832 register const unsigned char *little;
833 register I32 stop_pos;
834 register const unsigned char *littleend;
837 PERL_ARGS_ASSERT_SCREAMINSTR;
839 assert(SvTYPE(littlestr) == SVt_PVGV);
840 assert(SvVALID(littlestr));
843 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
844 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
846 if ( BmRARE(littlestr) == '\n'
847 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
848 little = (const unsigned char *)(SvPVX_const(littlestr));
849 littleend = little + SvCUR(littlestr);
856 little = (const unsigned char *)(SvPVX_const(littlestr));
857 littleend = little + SvCUR(littlestr);
859 /* The value of pos we can start at: */
860 previous = BmPREVIOUS(littlestr);
861 big = (const unsigned char *)(SvPVX_const(bigstr));
862 /* The value of pos we can stop at: */
863 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
864 if (previous + start_shift > stop_pos) {
866 stop_pos does not include SvTAIL in the count, so this check is incorrect
867 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
870 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
875 while (pos < previous + start_shift) {
876 if (!(pos += PL_screamnext[pos]))
881 register const unsigned char *s, *x;
882 if (pos >= stop_pos) break;
883 if (big[pos] != first)
885 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
891 if (s == littleend) {
893 if (!last) return (char *)(big+pos);
896 } while ( pos += PL_screamnext[pos] );
898 return (char *)(big+(*old_posp));
900 if (!SvTAIL(littlestr) || (end_shift > 0))
902 /* Ignore the trailing "\n". This code is not microoptimized */
903 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
904 stop_pos = littleend - little; /* Actual littlestr len */
909 && ((stop_pos == 1) ||
910 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
918 Returns true if the leading len bytes of the strings s1 and s2 are the same
919 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
920 match themselves and their opposite case counterparts. Non-cased and non-ASCII
921 range bytes match only themselves.
928 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
930 register const U8 *a = (const U8 *)s1;
931 register const U8 *b = (const U8 *)s2;
933 PERL_ARGS_ASSERT_FOLDEQ;
936 if (*a != *b && *a != PL_fold[*b])
943 Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
945 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
946 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
947 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
948 * does it check that the strings each have at least 'len' characters */
950 register const U8 *a = (const U8 *)s1;
951 register const U8 *b = (const U8 *)s2;
953 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
956 if (*a != *b && *a != PL_fold_latin1[*b]) {
965 =for apidoc foldEQ_locale
967 Returns true if the leading len bytes of the strings s1 and s2 are the same
968 case-insensitively in the current locale; false otherwise.
974 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
977 register const U8 *a = (const U8 *)s1;
978 register const U8 *b = (const U8 *)s2;
980 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
983 if (*a != *b && *a != PL_fold_locale[*b])
990 /* copy a string to a safe spot */
993 =head1 Memory Management
997 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
998 string which is a duplicate of C<pv>. The size of the string is
999 determined by C<strlen()>. The memory allocated for the new string can
1000 be freed with the C<Safefree()> function.
1006 Perl_savepv(pTHX_ const char *pv)
1008 PERL_UNUSED_CONTEXT;
1013 const STRLEN pvlen = strlen(pv)+1;
1014 Newx(newaddr, pvlen, char);
1015 return (char*)memcpy(newaddr, pv, pvlen);
1019 /* same thing but with a known length */
1024 Perl's version of what C<strndup()> would be if it existed. Returns a
1025 pointer to a newly allocated string which is a duplicate of the first
1026 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
1027 the new string can be freed with the C<Safefree()> function.
1033 Perl_savepvn(pTHX_ const char *pv, register I32 len)
1035 register char *newaddr;
1036 PERL_UNUSED_CONTEXT;
1038 Newx(newaddr,len+1,char);
1039 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1041 /* might not be null terminated */
1042 newaddr[len] = '\0';
1043 return (char *) CopyD(pv,newaddr,len,char);
1046 return (char *) ZeroD(newaddr,len+1,char);
1051 =for apidoc savesharedpv
1053 A version of C<savepv()> which allocates the duplicate string in memory
1054 which is shared between threads.
1059 Perl_savesharedpv(pTHX_ const char *pv)
1061 register char *newaddr;
1066 pvlen = strlen(pv)+1;
1067 newaddr = (char*)PerlMemShared_malloc(pvlen);
1069 return write_no_mem();
1071 return (char*)memcpy(newaddr, pv, pvlen);
1075 =for apidoc savesharedpvn
1077 A version of C<savepvn()> which allocates the duplicate string in memory
1078 which is shared between threads. (With the specific difference that a NULL
1079 pointer is not acceptable)
1084 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1086 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1088 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1091 return write_no_mem();
1093 newaddr[len] = '\0';
1094 return (char*)memcpy(newaddr, pv, len);
1098 =for apidoc savesvpv
1100 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1101 the passed in SV using C<SvPV()>
1107 Perl_savesvpv(pTHX_ SV *sv)
1110 const char * const pv = SvPV_const(sv, len);
1111 register char *newaddr;
1113 PERL_ARGS_ASSERT_SAVESVPV;
1116 Newx(newaddr,len,char);
1117 return (char *) CopyD(pv,newaddr,len,char);
1121 =for apidoc savesharedsvpv
1123 A version of C<savesharedpv()> which allocates the duplicate string in
1124 memory which is shared between threads.
1130 Perl_savesharedsvpv(pTHX_ SV *sv)
1133 const char * const pv = SvPV_const(sv, len);
1135 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1137 return savesharedpvn(pv, len);
1140 /* the SV for Perl_form() and mess() is not kept in an arena */
1149 if (PL_phase != PERL_PHASE_DESTRUCT)
1150 return newSVpvs_flags("", SVs_TEMP);
1155 /* Create as PVMG now, to avoid any upgrading later */
1157 Newxz(any, 1, XPVMG);
1158 SvFLAGS(sv) = SVt_PVMG;
1159 SvANY(sv) = (void*)any;
1161 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1166 #if defined(PERL_IMPLICIT_CONTEXT)
1168 Perl_form_nocontext(const char* pat, ...)
1173 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1174 va_start(args, pat);
1175 retval = vform(pat, &args);
1179 #endif /* PERL_IMPLICIT_CONTEXT */
1182 =head1 Miscellaneous Functions
1185 Takes a sprintf-style format pattern and conventional
1186 (non-SV) arguments and returns the formatted string.
1188 (char *) Perl_form(pTHX_ const char* pat, ...)
1190 can be used any place a string (char *) is required:
1192 char * s = Perl_form("%d.%d",major,minor);
1194 Uses a single private buffer so if you want to format several strings you
1195 must explicitly copy the earlier strings away (and free the copies when you
1202 Perl_form(pTHX_ const char* pat, ...)
1206 PERL_ARGS_ASSERT_FORM;
1207 va_start(args, pat);
1208 retval = vform(pat, &args);
1214 Perl_vform(pTHX_ const char *pat, va_list *args)
1216 SV * const sv = mess_alloc();
1217 PERL_ARGS_ASSERT_VFORM;
1218 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1223 =for apidoc Am|SV *|mess|const char *pat|...
1225 Take a sprintf-style format pattern and argument list. These are used to
1226 generate a string message. If the message does not end with a newline,
1227 then it will be extended with some indication of the current location
1228 in the code, as described for L</mess_sv>.
1230 Normally, the resulting message is returned in a new mortal SV.
1231 During global destruction a single SV may be shared between uses of
1237 #if defined(PERL_IMPLICIT_CONTEXT)
1239 Perl_mess_nocontext(const char *pat, ...)
1244 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1245 va_start(args, pat);
1246 retval = vmess(pat, &args);
1250 #endif /* PERL_IMPLICIT_CONTEXT */
1253 Perl_mess(pTHX_ const char *pat, ...)
1257 PERL_ARGS_ASSERT_MESS;
1258 va_start(args, pat);
1259 retval = vmess(pat, &args);
1265 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1268 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1270 PERL_ARGS_ASSERT_CLOSEST_COP;
1272 if (!o || o == PL_op)
1275 if (o->op_flags & OPf_KIDS) {
1277 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1280 /* If the OP_NEXTSTATE has been optimised away we can still use it
1281 * the get the file and line number. */
1283 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1284 cop = (const COP *)kid;
1286 /* Keep searching, and return when we've found something. */
1288 new_cop = closest_cop(cop, kid);
1294 /* Nothing found. */
1300 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1302 Expands a message, intended for the user, to include an indication of
1303 the current location in the code, if the message does not already appear
1306 C<basemsg> is the initial message or object. If it is a reference, it
1307 will be used as-is and will be the result of this function. Otherwise it
1308 is used as a string, and if it already ends with a newline, it is taken
1309 to be complete, and the result of this function will be the same string.
1310 If the message does not end with a newline, then a segment such as C<at
1311 foo.pl line 37> will be appended, and possibly other clauses indicating
1312 the current state of execution. The resulting message will end with a
1315 Normally, the resulting message is returned in a new mortal SV.
1316 During global destruction a single SV may be shared between uses of this
1317 function. If C<consume> is true, then the function is permitted (but not
1318 required) to modify and return C<basemsg> instead of allocating a new SV.
1324 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1329 PERL_ARGS_ASSERT_MESS_SV;
1331 if (SvROK(basemsg)) {
1337 sv_setsv(sv, basemsg);
1342 if (SvPOK(basemsg) && consume) {
1347 sv_copypv(sv, basemsg);
1350 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1352 * Try and find the file and line for PL_op. This will usually be
1353 * PL_curcop, but it might be a cop that has been optimised away. We
1354 * can try to find such a cop by searching through the optree starting
1355 * from the sibling of PL_curcop.
1358 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1363 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1364 OutCopFILE(cop), (IV)CopLINE(cop));
1365 /* Seems that GvIO() can be untrustworthy during global destruction. */
1366 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1367 && IoLINES(GvIOp(PL_last_in_gv)))
1369 const bool line_mode = (RsSIMPLE(PL_rs) &&
1370 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1371 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1372 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1373 line_mode ? "line" : "chunk",
1374 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1376 if (PL_phase == PERL_PHASE_DESTRUCT)
1377 sv_catpvs(sv, " during global destruction");
1378 sv_catpvs(sv, ".\n");
1384 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1386 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1387 argument list. These are used to generate a string message. If the
1388 message does not end with a newline, then it will be extended with
1389 some indication of the current location in the code, as described for
1392 Normally, the resulting message is returned in a new mortal SV.
1393 During global destruction a single SV may be shared between uses of
1400 Perl_vmess(pTHX_ const char *pat, va_list *args)
1403 SV * const sv = mess_alloc();
1405 PERL_ARGS_ASSERT_VMESS;
1407 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1408 return mess_sv(sv, 1);
1412 Perl_write_to_stderr(pTHX_ SV* msv)
1418 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1420 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1421 && (io = GvIO(PL_stderrgv))
1422 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1423 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
1424 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1427 /* SFIO can really mess with your errno */
1430 PerlIO * const serr = Perl_error_log;
1432 do_print(msv, serr);
1433 (void)PerlIO_flush(serr);
1441 =head1 Warning and Dieing
1444 /* Common code used in dieing and warning */
1447 S_with_queued_errors(pTHX_ SV *ex)
1449 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1450 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1451 sv_catsv(PL_errors, ex);
1452 ex = sv_mortalcopy(PL_errors);
1453 SvCUR_set(PL_errors, 0);
1459 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1465 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1466 /* sv_2cv might call Perl_croak() or Perl_warner() */
1467 SV * const oldhook = *hook;
1475 cv = sv_2cv(oldhook, &stash, &gv, 0);
1477 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1487 exarg = newSVsv(ex);
1488 SvREADONLY_on(exarg);
1491 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1495 call_sv(MUTABLE_SV(cv), G_DISCARD);
1504 =for apidoc Am|OP *|die_sv|SV *baseex
1506 Behaves the same as L</croak_sv>, except for the return type.
1507 It should be used only where the C<OP *> return type is required.
1508 The function never actually returns.
1514 Perl_die_sv(pTHX_ SV *baseex)
1516 PERL_ARGS_ASSERT_DIE_SV;
1523 =for apidoc Am|OP *|die|const char *pat|...
1525 Behaves the same as L</croak>, except for the return type.
1526 It should be used only where the C<OP *> return type is required.
1527 The function never actually returns.
1532 #if defined(PERL_IMPLICIT_CONTEXT)
1534 Perl_die_nocontext(const char* pat, ...)
1538 va_start(args, pat);
1544 #endif /* PERL_IMPLICIT_CONTEXT */
1547 Perl_die(pTHX_ const char* pat, ...)
1550 va_start(args, pat);
1558 =for apidoc Am|void|croak_sv|SV *baseex
1560 This is an XS interface to Perl's C<die> function.
1562 C<baseex> is the error message or object. If it is a reference, it
1563 will be used as-is. Otherwise it is used as a string, and if it does
1564 not end with a newline then it will be extended with some indication of
1565 the current location in the code, as described for L</mess_sv>.
1567 The error message or object will be used as an exception, by default
1568 returning control to the nearest enclosing C<eval>, but subject to
1569 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1570 function never returns normally.
1572 To die with a simple string message, the L</croak> function may be
1579 Perl_croak_sv(pTHX_ SV *baseex)
1581 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1582 PERL_ARGS_ASSERT_CROAK_SV;
1583 invoke_exception_hook(ex, FALSE);
1588 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1590 This is an XS interface to Perl's C<die> function.
1592 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1593 argument list. These are used to generate a string message. If the
1594 message does not end with a newline, then it will be extended with
1595 some indication of the current location in the code, as described for
1598 The error message will be used as an exception, by default
1599 returning control to the nearest enclosing C<eval>, but subject to
1600 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1601 function never returns normally.
1603 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1604 (C<$@>) will be used as an error message or object instead of building an
1605 error message from arguments. If you want to throw a non-string object,
1606 or build an error message in an SV yourself, it is preferable to use
1607 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1613 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1615 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1616 invoke_exception_hook(ex, FALSE);
1621 =for apidoc Am|void|croak|const char *pat|...
1623 This is an XS interface to Perl's C<die> function.
1625 Take a sprintf-style format pattern and argument list. These are used to
1626 generate a string message. If the message does not end with a newline,
1627 then it will be extended with some indication of the current location
1628 in the code, as described for L</mess_sv>.
1630 The error message will be used as an exception, by default
1631 returning control to the nearest enclosing C<eval>, but subject to
1632 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1633 function never returns normally.
1635 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1636 (C<$@>) will be used as an error message or object instead of building an
1637 error message from arguments. If you want to throw a non-string object,
1638 or build an error message in an SV yourself, it is preferable to use
1639 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1644 #if defined(PERL_IMPLICIT_CONTEXT)
1646 Perl_croak_nocontext(const char *pat, ...)
1650 va_start(args, pat);
1655 #endif /* PERL_IMPLICIT_CONTEXT */
1658 Perl_croak(pTHX_ const char *pat, ...)
1661 va_start(args, pat);
1668 =for apidoc Am|void|croak_no_modify
1670 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1671 terser object code than using C<Perl_croak>. Less code used on exception code
1672 paths reduces CPU cache pressure.
1678 Perl_croak_no_modify(pTHX)
1680 Perl_croak(aTHX_ "%s", PL_no_modify);
1684 =for apidoc Am|void|warn_sv|SV *baseex
1686 This is an XS interface to Perl's C<warn> function.
1688 C<baseex> is the error message or object. If it is a reference, it
1689 will be used as-is. Otherwise it is used as a string, and if it does
1690 not end with a newline then it will be extended with some indication of
1691 the current location in the code, as described for L</mess_sv>.
1693 The error message or object will by default be written to standard error,
1694 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1696 To warn with a simple string message, the L</warn> function may be
1703 Perl_warn_sv(pTHX_ SV *baseex)
1705 SV *ex = mess_sv(baseex, 0);
1706 PERL_ARGS_ASSERT_WARN_SV;
1707 if (!invoke_exception_hook(ex, TRUE))
1708 write_to_stderr(ex);
1712 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1714 This is an XS interface to Perl's C<warn> function.
1716 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1717 argument list. These are used to generate a string message. If the
1718 message does not end with a newline, then it will be extended with
1719 some indication of the current location in the code, as described for
1722 The error message or object will by default be written to standard error,
1723 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1725 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1731 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1733 SV *ex = vmess(pat, args);
1734 PERL_ARGS_ASSERT_VWARN;
1735 if (!invoke_exception_hook(ex, TRUE))
1736 write_to_stderr(ex);
1740 =for apidoc Am|void|warn|const char *pat|...
1742 This is an XS interface to Perl's C<warn> function.
1744 Take a sprintf-style format pattern and argument list. These are used to
1745 generate a string message. If the message does not end with a newline,
1746 then it will be extended with some indication of the current location
1747 in the code, as described for L</mess_sv>.
1749 The error message or object will by default be written to standard error,
1750 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1752 Unlike with L</croak>, C<pat> is not permitted to be null.
1757 #if defined(PERL_IMPLICIT_CONTEXT)
1759 Perl_warn_nocontext(const char *pat, ...)
1763 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1764 va_start(args, pat);
1768 #endif /* PERL_IMPLICIT_CONTEXT */
1771 Perl_warn(pTHX_ const char *pat, ...)
1774 PERL_ARGS_ASSERT_WARN;
1775 va_start(args, pat);
1780 #if defined(PERL_IMPLICIT_CONTEXT)
1782 Perl_warner_nocontext(U32 err, const char *pat, ...)
1786 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1787 va_start(args, pat);
1788 vwarner(err, pat, &args);
1791 #endif /* PERL_IMPLICIT_CONTEXT */
1794 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1796 PERL_ARGS_ASSERT_CK_WARNER_D;
1798 if (Perl_ckwarn_d(aTHX_ err)) {
1800 va_start(args, pat);
1801 vwarner(err, pat, &args);
1807 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1809 PERL_ARGS_ASSERT_CK_WARNER;
1811 if (Perl_ckwarn(aTHX_ err)) {
1813 va_start(args, pat);
1814 vwarner(err, pat, &args);
1820 Perl_warner(pTHX_ U32 err, const char* pat,...)
1823 PERL_ARGS_ASSERT_WARNER;
1824 va_start(args, pat);
1825 vwarner(err, pat, &args);
1830 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1833 PERL_ARGS_ASSERT_VWARNER;
1834 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1835 SV * const msv = vmess(pat, args);
1837 invoke_exception_hook(msv, FALSE);
1841 Perl_vwarn(aTHX_ pat, args);
1845 /* implements the ckWARN? macros */
1848 Perl_ckwarn(pTHX_ U32 w)
1851 /* If lexical warnings have not been set, use $^W. */
1853 return PL_dowarn & G_WARN_ON;
1855 return ckwarn_common(w);
1858 /* implements the ckWARN?_d macro */
1861 Perl_ckwarn_d(pTHX_ U32 w)
1864 /* If lexical warnings have not been set then default classes warn. */
1868 return ckwarn_common(w);
1872 S_ckwarn_common(pTHX_ U32 w)
1874 if (PL_curcop->cop_warnings == pWARN_ALL)
1877 if (PL_curcop->cop_warnings == pWARN_NONE)
1880 /* Check the assumption that at least the first slot is non-zero. */
1881 assert(unpackWARN1(w));
1883 /* Check the assumption that it is valid to stop as soon as a zero slot is
1885 if (!unpackWARN2(w)) {
1886 assert(!unpackWARN3(w));
1887 assert(!unpackWARN4(w));
1888 } else if (!unpackWARN3(w)) {
1889 assert(!unpackWARN4(w));
1892 /* Right, dealt with all the special cases, which are implemented as non-
1893 pointers, so there is a pointer to a real warnings mask. */
1895 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1897 } while (w >>= WARNshift);
1902 /* Set buffer=NULL to get a new one. */
1904 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1906 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1907 PERL_UNUSED_CONTEXT;
1908 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1911 (specialWARN(buffer) ?
1912 PerlMemShared_malloc(len_wanted) :
1913 PerlMemShared_realloc(buffer, len_wanted));
1915 Copy(bits, (buffer + 1), size, char);
1919 /* since we've already done strlen() for both nam and val
1920 * we can use that info to make things faster than
1921 * sprintf(s, "%s=%s", nam, val)
1923 #define my_setenv_format(s, nam, nlen, val, vlen) \
1924 Copy(nam, s, nlen, char); \
1926 Copy(val, s+(nlen+1), vlen, char); \
1927 *(s+(nlen+1+vlen)) = '\0'
1929 #ifdef USE_ENVIRON_ARRAY
1930 /* VMS' my_setenv() is in vms.c */
1931 #if !defined(WIN32) && !defined(NETWARE)
1933 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1937 /* only parent thread can modify process environment */
1938 if (PL_curinterp == aTHX)
1941 #ifndef PERL_USE_SAFE_PUTENV
1942 if (!PL_use_safe_putenv) {
1943 /* most putenv()s leak, so we manipulate environ directly */
1945 register const I32 len = strlen(nam);
1948 /* where does it go? */
1949 for (i = 0; environ[i]; i++) {
1950 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1954 if (environ == PL_origenviron) { /* need we copy environment? */
1960 while (environ[max])
1962 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1963 for (j=0; j<max; j++) { /* copy environment */
1964 const int len = strlen(environ[j]);
1965 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1966 Copy(environ[j], tmpenv[j], len+1, char);
1969 environ = tmpenv; /* tell exec where it is now */
1972 safesysfree(environ[i]);
1973 while (environ[i]) {
1974 environ[i] = environ[i+1];
1979 if (!environ[i]) { /* does not exist yet */
1980 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1981 environ[i+1] = NULL; /* make sure it's null terminated */
1984 safesysfree(environ[i]);
1988 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1989 /* all that work just for this */
1990 my_setenv_format(environ[i], nam, nlen, val, vlen);
1993 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1994 # if defined(HAS_UNSETENV)
1996 (void)unsetenv(nam);
1998 (void)setenv(nam, val, 1);
2000 # else /* ! HAS_UNSETENV */
2001 (void)setenv(nam, val, 1);
2002 # endif /* HAS_UNSETENV */
2004 # if defined(HAS_UNSETENV)
2006 (void)unsetenv(nam);
2008 const int nlen = strlen(nam);
2009 const int vlen = strlen(val);
2010 char * const new_env =
2011 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2012 my_setenv_format(new_env, nam, nlen, val, vlen);
2013 (void)putenv(new_env);
2015 # else /* ! HAS_UNSETENV */
2017 const int nlen = strlen(nam);
2023 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2024 /* all that work just for this */
2025 my_setenv_format(new_env, nam, nlen, val, vlen);
2026 (void)putenv(new_env);
2027 # endif /* HAS_UNSETENV */
2028 # endif /* __CYGWIN__ */
2029 #ifndef PERL_USE_SAFE_PUTENV
2035 #else /* WIN32 || NETWARE */
2038 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2041 register char *envstr;
2042 const int nlen = strlen(nam);
2049 Newx(envstr, nlen+vlen+2, char);
2050 my_setenv_format(envstr, nam, nlen, val, vlen);
2051 (void)PerlEnv_putenv(envstr);
2055 #endif /* WIN32 || NETWARE */
2057 #endif /* !VMS && !EPOC*/
2059 #ifdef UNLINK_ALL_VERSIONS
2061 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2065 PERL_ARGS_ASSERT_UNLNK;
2067 while (PerlLIO_unlink(f) >= 0)
2069 return retries ? 0 : -1;
2073 /* this is a drop-in replacement for bcopy() */
2074 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2076 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2078 char * const retval = to;
2080 PERL_ARGS_ASSERT_MY_BCOPY;
2082 if (from - to >= 0) {
2090 *(--to) = *(--from);
2096 /* this is a drop-in replacement for memset() */
2099 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2101 char * const retval = loc;
2103 PERL_ARGS_ASSERT_MY_MEMSET;
2111 /* this is a drop-in replacement for bzero() */
2112 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2114 Perl_my_bzero(register char *loc, register I32 len)
2116 char * const retval = loc;
2118 PERL_ARGS_ASSERT_MY_BZERO;
2126 /* this is a drop-in replacement for memcmp() */
2127 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2129 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2131 register const U8 *a = (const U8 *)s1;
2132 register const U8 *b = (const U8 *)s2;
2135 PERL_ARGS_ASSERT_MY_MEMCMP;
2138 if ((tmp = *a++ - *b++))
2143 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2146 /* This vsprintf replacement should generally never get used, since
2147 vsprintf was available in both System V and BSD 2.11. (There may
2148 be some cross-compilation or embedded set-ups where it is needed,
2151 If you encounter a problem in this function, it's probably a symptom
2152 that Configure failed to detect your system's vprintf() function.
2153 See the section on "item vsprintf" in the INSTALL file.
2155 This version may compile on systems with BSD-ish <stdio.h>,
2156 but probably won't on others.
2159 #ifdef USE_CHAR_VSPRINTF
2164 vsprintf(char *dest, const char *pat, void *args)
2168 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2169 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2170 FILE_cnt(&fakebuf) = 32767;
2172 /* These probably won't compile -- If you really need
2173 this, you'll have to figure out some other method. */
2174 fakebuf._ptr = dest;
2175 fakebuf._cnt = 32767;
2180 fakebuf._flag = _IOWRT|_IOSTRG;
2181 _doprnt(pat, args, &fakebuf); /* what a kludge */
2182 #if defined(STDIO_PTR_LVALUE)
2183 *(FILE_ptr(&fakebuf)++) = '\0';
2185 /* PerlIO has probably #defined away fputc, but we want it here. */
2187 # undef fputc /* XXX Should really restore it later */
2189 (void)fputc('\0', &fakebuf);
2191 #ifdef USE_CHAR_VSPRINTF
2194 return 0; /* perl doesn't use return value */
2198 #endif /* HAS_VPRINTF */
2201 #if BYTEORDER != 0x4321
2203 Perl_my_swap(pTHX_ short s)
2205 #if (BYTEORDER & 1) == 0
2208 result = ((s & 255) << 8) + ((s >> 8) & 255);
2216 Perl_my_htonl(pTHX_ long l)
2220 char c[sizeof(long)];
2223 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2224 #if BYTEORDER == 0x12345678
2227 u.c[0] = (l >> 24) & 255;
2228 u.c[1] = (l >> 16) & 255;
2229 u.c[2] = (l >> 8) & 255;
2233 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2234 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2239 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2240 u.c[o & 0xf] = (l >> s) & 255;
2248 Perl_my_ntohl(pTHX_ long l)
2252 char c[sizeof(long)];
2255 #if BYTEORDER == 0x1234
2256 u.c[0] = (l >> 24) & 255;
2257 u.c[1] = (l >> 16) & 255;
2258 u.c[2] = (l >> 8) & 255;
2262 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2263 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2270 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2271 l |= (u.c[o & 0xf] & 255) << s;
2278 #endif /* BYTEORDER != 0x4321 */
2282 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2283 * If these functions are defined,
2284 * the BYTEORDER is neither 0x1234 nor 0x4321.
2285 * However, this is not assumed.
2289 #define HTOLE(name,type) \
2291 name (register type n) \
2295 char c[sizeof(type)]; \
2298 register U32 s = 0; \
2299 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2300 u.c[i] = (n >> s) & 0xFF; \
2305 #define LETOH(name,type) \
2307 name (register type n) \
2311 char c[sizeof(type)]; \
2314 register U32 s = 0; \
2317 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2318 n |= ((type)(u.c[i] & 0xFF)) << s; \
2324 * Big-endian byte order functions.
2327 #define HTOBE(name,type) \
2329 name (register type n) \
2333 char c[sizeof(type)]; \
2336 register U32 s = 8*(sizeof(u.c)-1); \
2337 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2338 u.c[i] = (n >> s) & 0xFF; \
2343 #define BETOH(name,type) \
2345 name (register type n) \
2349 char c[sizeof(type)]; \
2352 register U32 s = 8*(sizeof(u.c)-1); \
2355 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2356 n |= ((type)(u.c[i] & 0xFF)) << s; \
2362 * If we just can't do it...
2365 #define NOT_AVAIL(name,type) \
2367 name (register type n) \
2369 Perl_croak_nocontext(#name "() not available"); \
2370 return n; /* not reached */ \
2374 #if defined(HAS_HTOVS) && !defined(htovs)
2377 #if defined(HAS_HTOVL) && !defined(htovl)
2380 #if defined(HAS_VTOHS) && !defined(vtohs)
2383 #if defined(HAS_VTOHL) && !defined(vtohl)
2387 #ifdef PERL_NEED_MY_HTOLE16
2389 HTOLE(Perl_my_htole16,U16)
2391 NOT_AVAIL(Perl_my_htole16,U16)
2394 #ifdef PERL_NEED_MY_LETOH16
2396 LETOH(Perl_my_letoh16,U16)
2398 NOT_AVAIL(Perl_my_letoh16,U16)
2401 #ifdef PERL_NEED_MY_HTOBE16
2403 HTOBE(Perl_my_htobe16,U16)
2405 NOT_AVAIL(Perl_my_htobe16,U16)
2408 #ifdef PERL_NEED_MY_BETOH16
2410 BETOH(Perl_my_betoh16,U16)
2412 NOT_AVAIL(Perl_my_betoh16,U16)
2416 #ifdef PERL_NEED_MY_HTOLE32
2418 HTOLE(Perl_my_htole32,U32)
2420 NOT_AVAIL(Perl_my_htole32,U32)
2423 #ifdef PERL_NEED_MY_LETOH32
2425 LETOH(Perl_my_letoh32,U32)
2427 NOT_AVAIL(Perl_my_letoh32,U32)
2430 #ifdef PERL_NEED_MY_HTOBE32
2432 HTOBE(Perl_my_htobe32,U32)
2434 NOT_AVAIL(Perl_my_htobe32,U32)
2437 #ifdef PERL_NEED_MY_BETOH32
2439 BETOH(Perl_my_betoh32,U32)
2441 NOT_AVAIL(Perl_my_betoh32,U32)
2445 #ifdef PERL_NEED_MY_HTOLE64
2447 HTOLE(Perl_my_htole64,U64)
2449 NOT_AVAIL(Perl_my_htole64,U64)
2452 #ifdef PERL_NEED_MY_LETOH64
2454 LETOH(Perl_my_letoh64,U64)
2456 NOT_AVAIL(Perl_my_letoh64,U64)
2459 #ifdef PERL_NEED_MY_HTOBE64
2461 HTOBE(Perl_my_htobe64,U64)
2463 NOT_AVAIL(Perl_my_htobe64,U64)
2466 #ifdef PERL_NEED_MY_BETOH64
2468 BETOH(Perl_my_betoh64,U64)
2470 NOT_AVAIL(Perl_my_betoh64,U64)
2474 #ifdef PERL_NEED_MY_HTOLES
2475 HTOLE(Perl_my_htoles,short)
2477 #ifdef PERL_NEED_MY_LETOHS
2478 LETOH(Perl_my_letohs,short)
2480 #ifdef PERL_NEED_MY_HTOBES
2481 HTOBE(Perl_my_htobes,short)
2483 #ifdef PERL_NEED_MY_BETOHS
2484 BETOH(Perl_my_betohs,short)
2487 #ifdef PERL_NEED_MY_HTOLEI
2488 HTOLE(Perl_my_htolei,int)
2490 #ifdef PERL_NEED_MY_LETOHI
2491 LETOH(Perl_my_letohi,int)
2493 #ifdef PERL_NEED_MY_HTOBEI
2494 HTOBE(Perl_my_htobei,int)
2496 #ifdef PERL_NEED_MY_BETOHI
2497 BETOH(Perl_my_betohi,int)
2500 #ifdef PERL_NEED_MY_HTOLEL
2501 HTOLE(Perl_my_htolel,long)
2503 #ifdef PERL_NEED_MY_LETOHL
2504 LETOH(Perl_my_letohl,long)
2506 #ifdef PERL_NEED_MY_HTOBEL
2507 HTOBE(Perl_my_htobel,long)
2509 #ifdef PERL_NEED_MY_BETOHL
2510 BETOH(Perl_my_betohl,long)
2514 Perl_my_swabn(void *ptr, int n)
2516 register char *s = (char *)ptr;
2517 register char *e = s + (n-1);
2520 PERL_ARGS_ASSERT_MY_SWABN;
2522 for (n /= 2; n > 0; s++, e--, n--) {
2530 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2532 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2535 register I32 This, that;
2541 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2543 PERL_FLUSHALL_FOR_CHILD;
2544 This = (*mode == 'w');
2548 taint_proper("Insecure %s%s", "EXEC");
2550 if (PerlProc_pipe(p) < 0)
2552 /* Try for another pipe pair for error return */
2553 if (PerlProc_pipe(pp) >= 0)
2555 while ((pid = PerlProc_fork()) < 0) {
2556 if (errno != EAGAIN) {
2557 PerlLIO_close(p[This]);
2558 PerlLIO_close(p[that]);
2560 PerlLIO_close(pp[0]);
2561 PerlLIO_close(pp[1]);
2565 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2574 /* Close parent's end of error status pipe (if any) */
2576 PerlLIO_close(pp[0]);
2577 #if defined(HAS_FCNTL) && defined(F_SETFD)
2578 /* Close error pipe automatically if exec works */
2579 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2582 /* Now dup our end of _the_ pipe to right position */
2583 if (p[THIS] != (*mode == 'r')) {
2584 PerlLIO_dup2(p[THIS], *mode == 'r');
2585 PerlLIO_close(p[THIS]);
2586 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2587 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2590 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2591 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2592 /* No automatic close - do it by hand */
2599 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2605 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2611 do_execfree(); /* free any memory malloced by child on fork */
2613 PerlLIO_close(pp[1]);
2614 /* Keep the lower of the two fd numbers */
2615 if (p[that] < p[This]) {
2616 PerlLIO_dup2(p[This], p[that]);
2617 PerlLIO_close(p[This]);
2621 PerlLIO_close(p[that]); /* close child's end of pipe */
2623 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2624 SvUPGRADE(sv,SVt_IV);
2626 PL_forkprocess = pid;
2627 /* If we managed to get status pipe check for exec fail */
2628 if (did_pipes && pid > 0) {
2633 while (n < sizeof(int)) {
2634 n1 = PerlLIO_read(pp[0],
2635 (void*)(((char*)&errkid)+n),
2641 PerlLIO_close(pp[0]);
2643 if (n) { /* Error */
2645 PerlLIO_close(p[This]);
2646 if (n != sizeof(int))
2647 Perl_croak(aTHX_ "panic: kid popen errno read");
2649 pid2 = wait4pid(pid, &status, 0);
2650 } while (pid2 == -1 && errno == EINTR);
2651 errno = errkid; /* Propagate errno from kid */
2656 PerlLIO_close(pp[0]);
2657 return PerlIO_fdopen(p[This], mode);
2659 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2660 return my_syspopen4(aTHX_ NULL, mode, n, args);
2662 Perl_croak(aTHX_ "List form of piped open not implemented");
2663 return (PerlIO *) NULL;
2668 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2669 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2671 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2675 register I32 This, that;
2678 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2682 PERL_ARGS_ASSERT_MY_POPEN;
2684 PERL_FLUSHALL_FOR_CHILD;
2687 return my_syspopen(aTHX_ cmd,mode);
2690 This = (*mode == 'w');
2692 if (doexec && PL_tainting) {
2694 taint_proper("Insecure %s%s", "EXEC");
2696 if (PerlProc_pipe(p) < 0)
2698 if (doexec && PerlProc_pipe(pp) >= 0)
2700 while ((pid = PerlProc_fork()) < 0) {
2701 if (errno != EAGAIN) {
2702 PerlLIO_close(p[This]);
2703 PerlLIO_close(p[that]);
2705 PerlLIO_close(pp[0]);
2706 PerlLIO_close(pp[1]);
2709 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2712 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2723 PerlLIO_close(pp[0]);
2724 #if defined(HAS_FCNTL) && defined(F_SETFD)
2725 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2728 if (p[THIS] != (*mode == 'r')) {
2729 PerlLIO_dup2(p[THIS], *mode == 'r');
2730 PerlLIO_close(p[THIS]);
2731 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2732 PerlLIO_close(p[THAT]);
2735 PerlLIO_close(p[THAT]);
2738 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2745 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2750 /* may or may not use the shell */
2751 do_exec3(cmd, pp[1], did_pipes);
2754 #endif /* defined OS2 */
2756 #ifdef PERLIO_USING_CRLF
2757 /* Since we circumvent IO layers when we manipulate low-level
2758 filedescriptors directly, need to manually switch to the
2759 default, binary, low-level mode; see PerlIOBuf_open(). */
2760 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2762 #ifdef THREADS_HAVE_PIDS
2763 PL_ppid = (IV)getppid();
2766 #ifdef PERL_USES_PL_PIDSTATUS
2767 hv_clear(PL_pidstatus); /* we have no children */
2773 do_execfree(); /* free any memory malloced by child on vfork */
2775 PerlLIO_close(pp[1]);
2776 if (p[that] < p[This]) {
2777 PerlLIO_dup2(p[This], p[that]);
2778 PerlLIO_close(p[This]);
2782 PerlLIO_close(p[that]);
2784 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2785 SvUPGRADE(sv,SVt_IV);
2787 PL_forkprocess = pid;
2788 if (did_pipes && pid > 0) {
2793 while (n < sizeof(int)) {
2794 n1 = PerlLIO_read(pp[0],
2795 (void*)(((char*)&errkid)+n),
2801 PerlLIO_close(pp[0]);
2803 if (n) { /* Error */
2805 PerlLIO_close(p[This]);
2806 if (n != sizeof(int))
2807 Perl_croak(aTHX_ "panic: kid popen errno read");
2809 pid2 = wait4pid(pid, &status, 0);
2810 } while (pid2 == -1 && errno == EINTR);
2811 errno = errkid; /* Propagate errno from kid */
2816 PerlLIO_close(pp[0]);
2817 return PerlIO_fdopen(p[This], mode);
2820 #if defined(atarist) || defined(EPOC)
2823 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2825 PERL_ARGS_ASSERT_MY_POPEN;
2826 PERL_FLUSHALL_FOR_CHILD;
2827 /* Call system's popen() to get a FILE *, then import it.
2828 used 0 for 2nd parameter to PerlIO_importFILE;
2831 return PerlIO_importFILE(popen(cmd, mode), 0);
2835 FILE *djgpp_popen();
2837 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2839 PERL_FLUSHALL_FOR_CHILD;
2840 /* Call system's popen() to get a FILE *, then import it.
2841 used 0 for 2nd parameter to PerlIO_importFILE;
2844 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2847 #if defined(__LIBCATAMOUNT__)
2849 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2857 #endif /* !DOSISH */
2859 /* this is called in parent before the fork() */
2861 Perl_atfork_lock(void)
2864 #if defined(USE_ITHREADS)
2865 /* locks must be held in locking order (if any) */
2867 MUTEX_LOCK(&PL_malloc_mutex);
2873 /* this is called in both parent and child after the fork() */
2875 Perl_atfork_unlock(void)
2878 #if defined(USE_ITHREADS)
2879 /* locks must be released in same order as in atfork_lock() */
2881 MUTEX_UNLOCK(&PL_malloc_mutex);
2890 #if defined(HAS_FORK)
2892 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2897 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2898 * handlers elsewhere in the code */
2903 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2904 Perl_croak_nocontext("fork() not available");
2906 #endif /* HAS_FORK */
2911 Perl_dump_fds(pTHX_ const char *const s)
2916 PERL_ARGS_ASSERT_DUMP_FDS;
2918 PerlIO_printf(Perl_debug_log,"%s", s);
2919 for (fd = 0; fd < 32; fd++) {
2920 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2921 PerlIO_printf(Perl_debug_log," %d",fd);
2923 PerlIO_printf(Perl_debug_log,"\n");
2926 #endif /* DUMP_FDS */
2930 dup2(int oldfd, int newfd)
2932 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2935 PerlLIO_close(newfd);
2936 return fcntl(oldfd, F_DUPFD, newfd);
2938 #define DUP2_MAX_FDS 256
2939 int fdtmp[DUP2_MAX_FDS];
2945 PerlLIO_close(newfd);
2946 /* good enough for low fd's... */
2947 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2948 if (fdx >= DUP2_MAX_FDS) {
2956 PerlLIO_close(fdtmp[--fdx]);
2963 #ifdef HAS_SIGACTION
2966 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2969 struct sigaction act, oact;
2972 /* only "parent" interpreter can diddle signals */
2973 if (PL_curinterp != aTHX)
2974 return (Sighandler_t) SIG_ERR;
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 if (sigaction(signo, &act, &oact) == -1)
2989 return (Sighandler_t) SIG_ERR;
2991 return (Sighandler_t) oact.sa_handler;
2995 Perl_rsignal_state(pTHX_ int signo)
2997 struct sigaction oact;
2998 PERL_UNUSED_CONTEXT;
3000 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3001 return (Sighandler_t) SIG_ERR;
3003 return (Sighandler_t) oact.sa_handler;
3007 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3010 struct sigaction act;
3012 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3015 /* only "parent" interpreter can diddle signals */
3016 if (PL_curinterp != aTHX)
3020 act.sa_handler = (void(*)(int))handler;
3021 sigemptyset(&act.sa_mask);
3024 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3025 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3027 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3028 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3029 act.sa_flags |= SA_NOCLDWAIT;
3031 return sigaction(signo, &act, save);
3035 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3039 /* only "parent" interpreter can diddle signals */
3040 if (PL_curinterp != aTHX)
3044 return sigaction(signo, save, (struct sigaction *)NULL);
3047 #else /* !HAS_SIGACTION */
3050 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3052 #if defined(USE_ITHREADS) && !defined(WIN32)
3053 /* only "parent" interpreter can diddle signals */
3054 if (PL_curinterp != aTHX)
3055 return (Sighandler_t) SIG_ERR;
3058 return PerlProc_signal(signo, handler);
3069 Perl_rsignal_state(pTHX_ int signo)
3072 Sighandler_t oldsig;
3074 #if defined(USE_ITHREADS) && !defined(WIN32)
3075 /* only "parent" interpreter can diddle signals */
3076 if (PL_curinterp != aTHX)
3077 return (Sighandler_t) SIG_ERR;
3081 oldsig = PerlProc_signal(signo, sig_trap);
3082 PerlProc_signal(signo, oldsig);
3084 PerlProc_kill(PerlProc_getpid(), signo);
3089 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3091 #if defined(USE_ITHREADS) && !defined(WIN32)
3092 /* only "parent" interpreter can diddle signals */
3093 if (PL_curinterp != aTHX)
3096 *save = PerlProc_signal(signo, handler);
3097 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3101 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3103 #if defined(USE_ITHREADS) && !defined(WIN32)
3104 /* only "parent" interpreter can diddle signals */
3105 if (PL_curinterp != aTHX)
3108 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3111 #endif /* !HAS_SIGACTION */
3112 #endif /* !PERL_MICRO */
3114 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3115 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3117 Perl_my_pclose(pTHX_ PerlIO *ptr)
3120 Sigsave_t hstat, istat, qstat;
3127 const int fd = PerlIO_fileno(ptr);
3130 /* Find out whether the refcount is low enough for us to wait for the
3131 child proc without blocking. */
3132 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3134 const bool should_wait = 1;
3137 svp = av_fetch(PL_fdpid,fd,TRUE);
3138 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3140 *svp = &PL_sv_undef;
3142 if (pid == -1) { /* Opened by popen. */
3143 return my_syspclose(ptr);
3146 close_failed = (PerlIO_close(ptr) == EOF);
3149 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
3152 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3153 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3154 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3156 if (should_wait) do {
3157 pid2 = wait4pid(pid, &status, 0);
3158 } while (pid2 == -1 && errno == EINTR);
3160 rsignal_restore(SIGHUP, &hstat);
3161 rsignal_restore(SIGINT, &istat);
3162 rsignal_restore(SIGQUIT, &qstat);
3170 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3175 #if defined(__LIBCATAMOUNT__)
3177 Perl_my_pclose(pTHX_ PerlIO *ptr)
3182 #endif /* !DOSISH */
3184 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3186 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3190 PERL_ARGS_ASSERT_WAIT4PID;
3193 #ifdef PERL_USES_PL_PIDSTATUS
3196 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3197 pid, rather than a string form. */
3198 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3199 if (svp && *svp != &PL_sv_undef) {
3200 *statusp = SvIVX(*svp);
3201 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3209 hv_iterinit(PL_pidstatus);
3210 if ((entry = hv_iternext(PL_pidstatus))) {
3211 SV * const sv = hv_iterval(PL_pidstatus,entry);
3213 const char * const spid = hv_iterkey(entry,&len);
3215 assert (len == sizeof(Pid_t));
3216 memcpy((char *)&pid, spid, len);
3217 *statusp = SvIVX(sv);
3218 /* The hash iterator is currently on this entry, so simply
3219 calling hv_delete would trigger the lazy delete, which on
3220 aggregate does more work, beacuse next call to hv_iterinit()
3221 would spot the flag, and have to call the delete routine,
3222 while in the meantime any new entries can't re-use that
3224 hv_iterinit(PL_pidstatus);
3225 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3232 # ifdef HAS_WAITPID_RUNTIME
3233 if (!HAS_WAITPID_RUNTIME)
3236 result = PerlProc_waitpid(pid,statusp,flags);
3239 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3240 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3243 #ifdef PERL_USES_PL_PIDSTATUS
3244 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3249 Perl_croak(aTHX_ "Can't do waitpid with flags");
3251 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3252 pidgone(result,*statusp);
3258 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3261 if (result < 0 && errno == EINTR) {
3263 errno = EINTR; /* reset in case a signal handler changed $! */
3267 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3269 #ifdef PERL_USES_PL_PIDSTATUS
3271 S_pidgone(pTHX_ Pid_t pid, int status)
3275 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3276 SvUPGRADE(sv,SVt_IV);
3277 SvIV_set(sv, status);
3282 #if defined(atarist) || defined(OS2) || defined(EPOC)
3285 int /* Cannot prototype with I32
3287 my_syspclose(PerlIO *ptr)
3290 Perl_my_pclose(pTHX_ PerlIO *ptr)
3293 /* Needs work for PerlIO ! */
3294 FILE * const f = PerlIO_findFILE(ptr);
3295 const I32 result = pclose(f);
3296 PerlIO_releaseFILE(ptr,f);
3304 Perl_my_pclose(pTHX_ PerlIO *ptr)
3306 /* Needs work for PerlIO ! */
3307 FILE * const f = PerlIO_findFILE(ptr);
3308 I32 result = djgpp_pclose(f);
3309 result = (result << 8) & 0xff00;
3310 PerlIO_releaseFILE(ptr,f);
3315 #define PERL_REPEATCPY_LINEAR 4
3317 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3319 PERL_ARGS_ASSERT_REPEATCPY;
3322 memset(to, *from, count);
3324 register char *p = to;
3325 I32 items, linear, half;
3327 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3328 for (items = 0; items < linear; ++items) {
3329 register const char *q = from;
3331 for (todo = len; todo > 0; todo--)
3336 while (items <= half) {
3337 I32 size = items * len;
3338 memcpy(p, to, size);
3344 memcpy(p, to, (count - items) * len);
3350 Perl_same_dirent(pTHX_ const char *a, const char *b)
3352 char *fa = strrchr(a,'/');
3353 char *fb = strrchr(b,'/');
3356 SV * const tmpsv = sv_newmortal();
3358 PERL_ARGS_ASSERT_SAME_DIRENT;
3371 sv_setpvs(tmpsv, ".");
3373 sv_setpvn(tmpsv, a, fa - a);
3374 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3377 sv_setpvs(tmpsv, ".");
3379 sv_setpvn(tmpsv, b, fb - b);
3380 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3382 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3383 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3385 #endif /* !HAS_RENAME */
3388 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3389 const char *const *const search_ext, I32 flags)
3392 const char *xfound = NULL;
3393 char *xfailed = NULL;
3394 char tmpbuf[MAXPATHLEN];
3399 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3400 # define SEARCH_EXTS ".bat", ".cmd", NULL
3401 # define MAX_EXT_LEN 4
3404 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3405 # define MAX_EXT_LEN 4
3408 # define SEARCH_EXTS ".pl", ".com", NULL
3409 # define MAX_EXT_LEN 4
3411 /* additional extensions to try in each dir if scriptname not found */
3413 static const char *const exts[] = { SEARCH_EXTS };
3414 const char *const *const ext = search_ext ? search_ext : exts;
3415 int extidx = 0, i = 0;
3416 const char *curext = NULL;
3418 PERL_UNUSED_ARG(search_ext);
3419 # define MAX_EXT_LEN 0
3422 PERL_ARGS_ASSERT_FIND_SCRIPT;
3425 * If dosearch is true and if scriptname does not contain path
3426 * delimiters, search the PATH for scriptname.
3428 * If SEARCH_EXTS is also defined, will look for each
3429 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3430 * while searching the PATH.
3432 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3433 * proceeds as follows:
3434 * If DOSISH or VMSISH:
3435 * + look for ./scriptname{,.foo,.bar}
3436 * + search the PATH for scriptname{,.foo,.bar}
3439 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3440 * this will not look in '.' if it's not in the PATH)
3445 # ifdef ALWAYS_DEFTYPES
3446 len = strlen(scriptname);
3447 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3448 int idx = 0, deftypes = 1;
3451 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3454 int idx = 0, deftypes = 1;
3457 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3459 /* The first time through, just add SEARCH_EXTS to whatever we
3460 * already have, so we can check for default file types. */
3462 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3468 if ((strlen(tmpbuf) + strlen(scriptname)
3469 + MAX_EXT_LEN) >= sizeof tmpbuf)
3470 continue; /* don't search dir with too-long name */
3471 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3475 if (strEQ(scriptname, "-"))
3477 if (dosearch) { /* Look in '.' first. */
3478 const char *cur = scriptname;
3480 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3482 if (strEQ(ext[i++],curext)) {
3483 extidx = -1; /* already has an ext */
3488 DEBUG_p(PerlIO_printf(Perl_debug_log,
3489 "Looking for %s\n",cur));
3490 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3491 && !S_ISDIR(PL_statbuf.st_mode)) {
3499 if (cur == scriptname) {
3500 len = strlen(scriptname);
3501 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3503 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3506 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3507 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3512 if (dosearch && !strchr(scriptname, '/')
3514 && !strchr(scriptname, '\\')
3516 && (s = PerlEnv_getenv("PATH")))
3520 bufend = s + strlen(s);
3521 while (s < bufend) {
3522 #if defined(atarist) || defined(DOSISH)
3527 && *s != ';'; len++, s++) {
3528 if (len < sizeof tmpbuf)
3531 if (len < sizeof tmpbuf)
3533 #else /* ! (atarist || DOSISH) */
3534 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3537 #endif /* ! (atarist || DOSISH) */
3540 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3541 continue; /* don't search dir with too-long name */
3543 # if defined(atarist) || defined(DOSISH)
3544 && tmpbuf[len - 1] != '/'
3545 && tmpbuf[len - 1] != '\\'
3548 tmpbuf[len++] = '/';
3549 if (len == 2 && tmpbuf[0] == '.')
3551 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3555 len = strlen(tmpbuf);
3556 if (extidx > 0) /* reset after previous loop */
3560 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3561 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3562 if (S_ISDIR(PL_statbuf.st_mode)) {
3566 } while ( retval < 0 /* not there */
3567 && extidx>=0 && ext[extidx] /* try an extension? */
3568 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3573 if (S_ISREG(PL_statbuf.st_mode)
3574 && cando(S_IRUSR,TRUE,&PL_statbuf)
3575 #if !defined(DOSISH)
3576 && cando(S_IXUSR,TRUE,&PL_statbuf)
3580 xfound = tmpbuf; /* bingo! */
3584 xfailed = savepv(tmpbuf);
3587 if (!xfound && !seen_dot && !xfailed &&
3588 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3589 || S_ISDIR(PL_statbuf.st_mode)))
3591 seen_dot = 1; /* Disable message. */
3593 if (flags & 1) { /* do or die? */
3594 Perl_croak(aTHX_ "Can't %s %s%s%s",
3595 (xfailed ? "execute" : "find"),
3596 (xfailed ? xfailed : scriptname),
3597 (xfailed ? "" : " on PATH"),
3598 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3603 scriptname = xfound;
3605 return (scriptname ? savepv(scriptname) : NULL);
3608 #ifndef PERL_GET_CONTEXT_DEFINED
3611 Perl_get_context(void)
3614 #if defined(USE_ITHREADS)
3615 # ifdef OLD_PTHREADS_API
3617 if (pthread_getspecific(PL_thr_key, &t))
3618 Perl_croak_nocontext("panic: pthread_getspecific");
3621 # ifdef I_MACH_CTHREADS
3622 return (void*)cthread_data(cthread_self());
3624 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3633 Perl_set_context(void *t)
3636 PERL_ARGS_ASSERT_SET_CONTEXT;
3637 #if defined(USE_ITHREADS)
3638 # ifdef I_MACH_CTHREADS
3639 cthread_set_data(cthread_self(), t);
3641 if (pthread_setspecific(PL_thr_key, t))
3642 Perl_croak_nocontext("panic: pthread_setspecific");
3649 #endif /* !PERL_GET_CONTEXT_DEFINED */
3651 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3660 Perl_get_op_names(pTHX)
3662 PERL_UNUSED_CONTEXT;
3663 return (char **)PL_op_name;
3667 Perl_get_op_descs(pTHX)
3669 PERL_UNUSED_CONTEXT;
3670 return (char **)PL_op_desc;
3674 Perl_get_no_modify(pTHX)
3676 PERL_UNUSED_CONTEXT;
3677 return PL_no_modify;
3681 Perl_get_opargs(pTHX)
3683 PERL_UNUSED_CONTEXT;
3684 return (U32 *)PL_opargs;
3688 Perl_get_ppaddr(pTHX)
3691 PERL_UNUSED_CONTEXT;
3692 return (PPADDR_t*)PL_ppaddr;
3695 #ifndef HAS_GETENV_LEN
3697 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3699 char * const env_trans = PerlEnv_getenv(env_elem);
3700 PERL_UNUSED_CONTEXT;
3701 PERL_ARGS_ASSERT_GETENV_LEN;
3703 *len = strlen(env_trans);
3710 Perl_get_vtbl(pTHX_ int vtbl_id)
3712 const MGVTBL* result;
3713 PERL_UNUSED_CONTEXT;
3717 result = &PL_vtbl_sv;
3720 result = &PL_vtbl_env;
3722 case want_vtbl_envelem:
3723 result = &PL_vtbl_envelem;
3726 result = &PL_vtbl_sig;
3728 case want_vtbl_sigelem:
3729 result = &PL_vtbl_sigelem;
3731 case want_vtbl_pack:
3732 result = &PL_vtbl_pack;
3734 case want_vtbl_packelem:
3735 result = &PL_vtbl_packelem;
3737 case want_vtbl_dbline:
3738 result = &PL_vtbl_dbline;
3741 result = &PL_vtbl_isa;
3743 case want_vtbl_isaelem:
3744 result = &PL_vtbl_isaelem;
3746 case want_vtbl_arylen:
3747 result = &PL_vtbl_arylen;
3749 case want_vtbl_mglob:
3750 result = &PL_vtbl_mglob;
3752 case want_vtbl_nkeys:
3753 result = &PL_vtbl_nkeys;
3755 case want_vtbl_taint:
3756 result = &PL_vtbl_taint;
3758 case want_vtbl_substr:
3759 result = &PL_vtbl_substr;
3762 result = &PL_vtbl_vec;
3765 result = &PL_vtbl_pos;
3768 result = &PL_vtbl_bm;
3771 result = &PL_vtbl_fm;
3773 case want_vtbl_uvar:
3774 result = &PL_vtbl_uvar;
3776 case want_vtbl_defelem:
3777 result = &PL_vtbl_defelem;
3779 case want_vtbl_regexp:
3780 result = &PL_vtbl_regexp;
3782 case want_vtbl_regdata:
3783 result = &PL_vtbl_regdata;
3785 case want_vtbl_regdatum:
3786 result = &PL_vtbl_regdatum;
3788 #ifdef USE_LOCALE_COLLATE
3789 case want_vtbl_collxfrm:
3790 result = &PL_vtbl_collxfrm;
3793 case want_vtbl_amagic:
3794 result = &PL_vtbl_amagic;
3796 case want_vtbl_amagicelem:
3797 result = &PL_vtbl_amagicelem;
3799 case want_vtbl_backref:
3800 result = &PL_vtbl_backref;
3802 case want_vtbl_utf8:
3803 result = &PL_vtbl_utf8;
3809 return (MGVTBL*)result;
3813 Perl_my_fflush_all(pTHX)
3815 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3816 return PerlIO_flush(NULL);
3818 # if defined(HAS__FWALK)
3819 extern int fflush(FILE *);
3820 /* undocumented, unprototyped, but very useful BSDism */
3821 extern void _fwalk(int (*)(FILE *));
3825 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3827 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3828 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3830 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3831 open_max = sysconf(_SC_OPEN_MAX);
3834 open_max = FOPEN_MAX;
3837 open_max = OPEN_MAX;
3848 for (i = 0; i < open_max; i++)
3849 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3850 STDIO_STREAM_ARRAY[i]._file < open_max &&
3851 STDIO_STREAM_ARRAY[i]._flag)
3852 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3856 SETERRNO(EBADF,RMS_IFI);
3863 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3865 if (ckWARN(WARN_IO)) {
3866 const char * const name
3867 = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3868 const char * const direction = have == '>' ? "out" : "in";
3871 Perl_warner(aTHX_ packWARN(WARN_IO),
3872 "Filehandle %s opened only for %sput",
3875 Perl_warner(aTHX_ packWARN(WARN_IO),
3876 "Filehandle opened only for %sput", direction);
3881 Perl_report_evil_fh(pTHX_ const GV *gv)
3883 const IO *io = gv ? GvIO(gv) : NULL;
3884 const PERL_BITFIELD16 op = PL_op->op_type;
3888 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3890 warn_type = WARN_CLOSED;
3894 warn_type = WARN_UNOPENED;
3897 if (ckWARN(warn_type)) {
3898 const char * const name
3899 = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3900 const char * const pars =
3901 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3902 const char * const func =
3904 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3905 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3907 const char * const type =
3909 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3910 ? "socket" : "filehandle");
3911 if (name && *name) {
3912 Perl_warner(aTHX_ packWARN(warn_type),
3913 "%s%s on %s %s %s", func, pars, vile, type, name);
3914 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3916 aTHX_ packWARN(warn_type),
3917 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3922 Perl_warner(aTHX_ packWARN(warn_type),
3923 "%s%s on %s %s", func, pars, vile, type);
3924 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3926 aTHX_ packWARN(warn_type),
3927 "\t(Are you trying to call %s%s on dirhandle?)\n",
3934 /* To workaround core dumps from the uninitialised tm_zone we get the
3935 * system to give us a reasonable struct to copy. This fix means that
3936 * strftime uses the tm_zone and tm_gmtoff values returned by
3937 * localtime(time()). That should give the desired result most of the
3938 * time. But probably not always!
3940 * This does not address tzname aspects of NETaa14816.
3945 # ifndef STRUCT_TM_HASZONE
3946 # define STRUCT_TM_HASZONE
3950 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3951 # ifndef HAS_TM_TM_ZONE
3952 # define HAS_TM_TM_ZONE
3957 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3959 #ifdef HAS_TM_TM_ZONE
3961 const struct tm* my_tm;
3962 PERL_ARGS_ASSERT_INIT_TM;
3964 my_tm = localtime(&now);
3966 Copy(my_tm, ptm, 1, struct tm);
3968 PERL_ARGS_ASSERT_INIT_TM;
3969 PERL_UNUSED_ARG(ptm);
3974 * mini_mktime - normalise struct tm values without the localtime()
3975 * semantics (and overhead) of mktime().
3978 Perl_mini_mktime(pTHX_ struct tm *ptm)
3982 int month, mday, year, jday;
3983 int odd_cent, odd_year;
3984 PERL_UNUSED_CONTEXT;
3986 PERL_ARGS_ASSERT_MINI_MKTIME;
3988 #define DAYS_PER_YEAR 365
3989 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3990 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3991 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3992 #define SECS_PER_HOUR (60*60)
3993 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3994 /* parentheses deliberately absent on these two, otherwise they don't work */
3995 #define MONTH_TO_DAYS 153/5
3996 #define DAYS_TO_MONTH 5/153
3997 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3998 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3999 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
4000 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
4003 * Year/day algorithm notes:
4005 * With a suitable offset for numeric value of the month, one can find
4006 * an offset into the year by considering months to have 30.6 (153/5) days,
4007 * using integer arithmetic (i.e., with truncation). To avoid too much
4008 * messing about with leap days, we consider January and February to be
4009 * the 13th and 14th month of the previous year. After that transformation,
4010 * we need the month index we use to be high by 1 from 'normal human' usage,
4011 * so the month index values we use run from 4 through 15.
4013 * Given that, and the rules for the Gregorian calendar (leap years are those
4014 * divisible by 4 unless also divisible by 100, when they must be divisible
4015 * by 400 instead), we can simply calculate the number of days since some
4016 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4017 * the days we derive from our month index, and adding in the day of the
4018 * month. The value used here is not adjusted for the actual origin which
4019 * it normally would use (1 January A.D. 1), since we're not exposing it.
4020 * We're only building the value so we can turn around and get the
4021 * normalised values for the year, month, day-of-month, and day-of-year.
4023 * For going backward, we need to bias the value we're using so that we find
4024 * the right year value. (Basically, we don't want the contribution of
4025 * March 1st to the number to apply while deriving the year). Having done
4026 * that, we 'count up' the contribution to the year number by accounting for
4027 * full quadracenturies (400-year periods) with their extra leap days, plus
4028 * the contribution from full centuries (to avoid counting in the lost leap
4029 * days), plus the contribution from full quad-years (to count in the normal
4030 * leap days), plus the leftover contribution from any non-leap years.
4031 * At this point, if we were working with an actual leap day, we'll have 0
4032 * days left over. This is also true for March 1st, however. So, we have
4033 * to special-case that result, and (earlier) keep track of the 'odd'
4034 * century and year contributions. If we got 4 extra centuries in a qcent,
4035 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4036 * Otherwise, we add back in the earlier bias we removed (the 123 from
4037 * figuring in March 1st), find the month index (integer division by 30.6),
4038 * and the remainder is the day-of-month. We then have to convert back to
4039 * 'real' months (including fixing January and February from being 14/15 in
4040 * the previous year to being in the proper year). After that, to get
4041 * tm_yday, we work with the normalised year and get a new yearday value for
4042 * January 1st, which we subtract from the yearday value we had earlier,
4043 * representing the date we've re-built. This is done from January 1
4044 * because tm_yday is 0-origin.
4046 * Since POSIX time routines are only guaranteed to work for times since the
4047 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4048 * applies Gregorian calendar rules even to dates before the 16th century
4049 * doesn't bother me. Besides, you'd need cultural context for a given
4050 * date to know whether it was Julian or Gregorian calendar, and that's
4051 * outside the scope for this routine. Since we convert back based on the
4052 * same rules we used to build the yearday, you'll only get strange results
4053 * for input which needed normalising, or for the 'odd' century years which
4054 * were leap years in the Julian calendar but not in the Gregorian one.
4055 * I can live with that.
4057 * This algorithm also fails to handle years before A.D. 1 gracefully, but
4058 * that's still outside the scope for POSIX time manipulation, so I don't
4062 year = 1900 + ptm->tm_year;
4063 month = ptm->tm_mon;
4064 mday = ptm->tm_mday;
4065 /* allow given yday with no month & mday to dominate the result */
4066 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4069 jday = 1 + ptm->tm_yday;
4078 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4079 yearday += month*MONTH_TO_DAYS + mday + jday;
4081 * Note that we don't know when leap-seconds were or will be,
4082 * so we have to trust the user if we get something which looks
4083 * like a sensible leap-second. Wild values for seconds will
4084 * be rationalised, however.
4086 if ((unsigned) ptm->tm_sec <= 60) {
4093 secs += 60 * ptm->tm_min;
4094 secs += SECS_PER_HOUR * ptm->tm_hour;
4096 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4097 /* got negative remainder, but need positive time */
4098 /* back off an extra day to compensate */
4099 yearday += (secs/SECS_PER_DAY)-1;
4100 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4103 yearday += (secs/SECS_PER_DAY);
4104 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4107 else if (secs >= SECS_PER_DAY) {
4108 yearday += (secs/SECS_PER_DAY);
4109 secs %= SECS_PER_DAY;
4111 ptm->tm_hour = secs/SECS_PER_HOUR;
4112 secs %= SECS_PER_HOUR;
4113 ptm->tm_min = secs/60;
4115 ptm->tm_sec += secs;
4116 /* done with time of day effects */
4118 * The algorithm for yearday has (so far) left it high by 428.
4119 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4120 * bias it by 123 while trying to figure out what year it
4121 * really represents. Even with this tweak, the reverse
4122 * translation fails for years before A.D. 0001.
4123 * It would still fail for Feb 29, but we catch that one below.
4125 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
4126 yearday -= YEAR_ADJUST;
4127 year = (yearday / DAYS_PER_QCENT) * 400;
4128 yearday %= DAYS_PER_QCENT;
4129 odd_cent = yearday / DAYS_PER_CENT;
4130 year += odd_cent * 100;
4131 yearday %= DAYS_PER_CENT;
4132 year += (yearday / DAYS_PER_QYEAR) * 4;
4133 yearday %= DAYS_PER_QYEAR;
4134 odd_year = yearday / DAYS_PER_YEAR;
4136 yearday %= DAYS_PER_YEAR;
4137 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4142 yearday += YEAR_ADJUST; /* recover March 1st crock */
4143 month = yearday*DAYS_TO_MONTH;
4144 yearday -= month*MONTH_TO_DAYS;
4145 /* recover other leap-year adjustment */
4154 ptm->tm_year = year - 1900;
4156 ptm->tm_mday = yearday;
4157 ptm->tm_mon = month;
4161 ptm->tm_mon = month - 1;
4163 /* re-build yearday based on Jan 1 to get tm_yday */
4165 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4166 yearday += 14*MONTH_TO_DAYS + 1;
4167 ptm->tm_yday = jday - yearday;
4168 /* fix tm_wday if not overridden by caller */
4169 if ((unsigned)ptm->tm_wday > 6)
4170 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4174 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)
4182 PERL_ARGS_ASSERT_MY_STRFTIME;
4184 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4187 mytm.tm_hour = hour;
4188 mytm.tm_mday = mday;
4190 mytm.tm_year = year;
4191 mytm.tm_wday = wday;
4192 mytm.tm_yday = yday;
4193 mytm.tm_isdst = isdst;
4195 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4196 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4201 #ifdef HAS_TM_TM_GMTOFF
4202 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4204 #ifdef HAS_TM_TM_ZONE
4205 mytm.tm_zone = mytm2.tm_zone;
4210 Newx(buf, buflen, char);
4211 len = strftime(buf, buflen, fmt, &mytm);
4213 ** The following is needed to handle to the situation where
4214 ** tmpbuf overflows. Basically we want to allocate a buffer
4215 ** and try repeatedly. The reason why it is so complicated
4216 ** is that getting a return value of 0 from strftime can indicate
4217 ** one of the following:
4218 ** 1. buffer overflowed,
4219 ** 2. illegal conversion specifier, or
4220 ** 3. the format string specifies nothing to be returned(not
4221 ** an error). This could be because format is an empty string
4222 ** or it specifies %p that yields an empty string in some locale.
4223 ** If there is a better way to make it portable, go ahead by
4226 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4229 /* Possibly buf overflowed - try again with a bigger buf */
4230 const int fmtlen = strlen(fmt);
4231 int bufsize = fmtlen + buflen;
4233 Renew(buf, bufsize, char);
4235 buflen = strftime(buf, bufsize, fmt, &mytm);
4236 if (buflen > 0 && buflen < bufsize)
4238 /* heuristic to prevent out-of-memory errors */
4239 if (bufsize > 100*fmtlen) {
4245 Renew(buf, bufsize, char);
4250 Perl_croak(aTHX_ "panic: no strftime");
4256 #define SV_CWD_RETURN_UNDEF \
4257 sv_setsv(sv, &PL_sv_undef); \
4260 #define SV_CWD_ISDOT(dp) \
4261 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4262 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4265 =head1 Miscellaneous Functions
4267 =for apidoc getcwd_sv
4269 Fill the sv with current working directory
4274 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4275 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4276 * getcwd(3) if available
4277 * Comments from the orignal:
4278 * This is a faster version of getcwd. It's also more dangerous
4279 * because you might chdir out of a directory that you can't chdir
4283 Perl_getcwd_sv(pTHX_ register SV *sv)
4287 #ifndef INCOMPLETE_TAINTS
4291 PERL_ARGS_ASSERT_GETCWD_SV;
4295 char buf[MAXPATHLEN];
4297 /* Some getcwd()s automatically allocate a buffer of the given
4298 * size from the heap if they are given a NULL buffer pointer.
4299 * The problem is that this behaviour is not portable. */
4300 if (getcwd(buf, sizeof(buf) - 1)) {
4305 sv_setsv(sv, &PL_sv_undef);
4313 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4317 SvUPGRADE(sv, SVt_PV);
4319 if (PerlLIO_lstat(".", &statbuf) < 0) {
4320 SV_CWD_RETURN_UNDEF;
4323 orig_cdev = statbuf.st_dev;
4324 orig_cino = statbuf.st_ino;
4334 if (PerlDir_chdir("..") < 0) {
4335 SV_CWD_RETURN_UNDEF;
4337 if (PerlLIO_stat(".", &statbuf) < 0) {
4338 SV_CWD_RETURN_UNDEF;
4341 cdev = statbuf.st_dev;
4342 cino = statbuf.st_ino;
4344 if (odev == cdev && oino == cino) {
4347 if (!(dir = PerlDir_open("."))) {
4348 SV_CWD_RETURN_UNDEF;
4351 while ((dp = PerlDir_read(dir)) != NULL) {
4353 namelen = dp->d_namlen;
4355 namelen = strlen(dp->d_name);
4358 if (SV_CWD_ISDOT(dp)) {
4362 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4363 SV_CWD_RETURN_UNDEF;
4366 tdev = statbuf.st_dev;
4367 tino = statbuf.st_ino;
4368 if (tino == oino && tdev == odev) {
4374 SV_CWD_RETURN_UNDEF;
4377 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4378 SV_CWD_RETURN_UNDEF;
4381 SvGROW(sv, pathlen + namelen + 1);
4385 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4388 /* prepend current directory to the front */
4390 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4391 pathlen += (namelen + 1);
4393 #ifdef VOID_CLOSEDIR
4396 if (PerlDir_close(dir) < 0) {
4397 SV_CWD_RETURN_UNDEF;
4403 SvCUR_set(sv, pathlen);
4407 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4408 SV_CWD_RETURN_UNDEF;
4411 if (PerlLIO_stat(".", &statbuf) < 0) {
4412 SV_CWD_RETURN_UNDEF;
4415 cdev = statbuf.st_dev;
4416 cino = statbuf.st_ino;
4418 if (cdev != orig_cdev || cino != orig_cino) {
4419 Perl_croak(aTHX_ "Unstable directory path, "
4420 "current directory changed unexpectedly");
4431 #define VERSION_MAX 0x7FFFFFFF
4434 =for apidoc prescan_version
4436 Validate that a given string can be parsed as a version object, but doesn't
4437 actually perform the parsing. Can use either strict or lax validation rules.
4438 Can optionally set a number of hint variables to save the parsing code
4439 some time when tokenizing.
4444 Perl_prescan_version(pTHX_ const char *s, bool strict,
4445 const char **errstr,
4446 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4447 bool qv = (sqv ? *sqv : FALSE);
4449 int saw_decimal = 0;
4453 PERL_ARGS_ASSERT_PRESCAN_VERSION;
4455 if (qv && isDIGIT(*d))
4456 goto dotted_decimal_version;
4458 if (*d == 'v') { /* explicit v-string */
4463 else { /* degenerate v-string */
4464 /* requires v1.2.3 */
4465 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4468 dotted_decimal_version:
4469 if (strict && d[0] == '0' && isDIGIT(d[1])) {
4470 /* no leading zeros allowed */
4471 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4474 while (isDIGIT(*d)) /* integer part */
4480 d++; /* decimal point */
4485 /* require v1.2.3 */
4486 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4489 goto version_prescan_finish;
4496 while (isDIGIT(*d)) { /* just keep reading */
4498 while (isDIGIT(*d)) {
4500 /* maximum 3 digits between decimal */
4501 if (strict && j > 3) {
4502 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4507 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4510 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4515 else if (*d == '.') {
4517 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4522 else if (!isDIGIT(*d)) {
4528 if (strict && i < 2) {
4529 /* requires v1.2.3 */
4530 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4533 } /* end if dotted-decimal */
4535 { /* decimal versions */
4536 /* special strict case for leading '.' or '0' */
4539 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4541 if (*d == '0' && isDIGIT(d[1])) {
4542 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4546 /* consume all of the integer part */
4550 /* look for a fractional part */
4552 /* we found it, so consume it */
4556 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4559 BADVERSION(s,errstr,"Invalid version format (version required)");
4561 /* found just an integer */
4562 goto version_prescan_finish;
4564 else if ( d == s ) {
4565 /* didn't find either integer or period */
4566 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4568 else if (*d == '_') {
4569 /* underscore can't come after integer part */
4571 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4573 else if (isDIGIT(d[1])) {
4574 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4577 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4581 /* anything else after integer part is just invalid data */
4582 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4585 /* scan the fractional part after the decimal point*/
4587 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4588 /* strict or lax-but-not-the-end */
4589 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4592 while (isDIGIT(*d)) {
4594 if (*d == '.' && isDIGIT(d[-1])) {
4596 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4599 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4601 d = (char *)s; /* start all over again */
4603 goto dotted_decimal_version;
4607 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4610 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4612 if ( ! isDIGIT(d[1]) ) {
4613 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4621 version_prescan_finish:
4625 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4626 /* trailing non-numeric data */
4627 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4635 *ssaw_decimal = saw_decimal;
4642 =for apidoc scan_version
4644 Returns a pointer to the next character after the parsed
4645 version string, as well as upgrading the passed in SV to
4648 Function must be called with an already existing SV like
4651 s = scan_version(s, SV *sv, bool qv);
4653 Performs some preprocessing to the string to ensure that
4654 it has the correct characteristics of a version. Flags the
4655 object if it contains an underscore (which denotes this
4656 is an alpha version). The boolean qv denotes that the version
4657 should be interpreted as if it had multiple decimals, even if
4664 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4669 const char *errstr = NULL;
4670 int saw_decimal = 0;
4674 AV * const av = newAV();
4675 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4677 PERL_ARGS_ASSERT_SCAN_VERSION;
4679 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4681 #ifndef NODEFAULT_SHAREKEYS
4682 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4685 while (isSPACE(*s)) /* leading whitespace is OK */
4688 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4690 /* "undef" is a special case and not an error */
4691 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4692 Perl_croak(aTHX_ "%s", errstr);
4702 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4704 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4705 if ( !qv && width < 3 )
4706 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4708 while (isDIGIT(*pos))
4710 if (!isALPHA(*pos)) {
4716 /* this is atoi() that delimits on underscores */
4717 const char *end = pos;
4721 /* the following if() will only be true after the decimal
4722 * point of a version originally created with a bare
4723 * floating point number, i.e. not quoted in any way
4725 if ( !qv && s > start && saw_decimal == 1 ) {
4729 rev += (*s - '0') * mult;
4731 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4732 || (PERL_ABS(rev) > VERSION_MAX )) {
4733 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4734 "Integer overflow in version %d",VERSION_MAX);
4745 while (--end >= s) {
4747 rev += (*end - '0') * mult;
4749 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4750 || (PERL_ABS(rev) > VERSION_MAX )) {
4751 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4752 "Integer overflow in version");
4761 /* Append revision */
4762 av_push(av, newSViv(rev));
4767 else if ( *pos == '.' )
4769 else if ( *pos == '_' && isDIGIT(pos[1]) )
4771 else if ( *pos == ',' && isDIGIT(pos[1]) )
4773 else if ( isDIGIT(*pos) )
4780 while ( isDIGIT(*pos) )
4785 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4793 if ( qv ) { /* quoted versions always get at least three terms*/
4794 I32 len = av_len(av);
4795 /* This for loop appears to trigger a compiler bug on OS X, as it
4796 loops infinitely. Yes, len is negative. No, it makes no sense.
4797 Compiler in question is:
4798 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4799 for ( len = 2 - len; len > 0; len-- )
4800 av_push(MUTABLE_AV(sv), newSViv(0));
4804 av_push(av, newSViv(0));
4807 /* need to save off the current version string for later */
4809 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4810 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4811 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4813 else if ( s > start ) {
4814 SV * orig = newSVpvn(start,s-start);
4815 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4816 /* need to insert a v to be consistent */
4817 sv_insert(orig, 0, 0, "v", 1);
4819 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4822 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4823 av_push(av, newSViv(0));
4826 /* And finally, store the AV in the hash */
4827 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4829 /* fix RT#19517 - special case 'undef' as string */
4830 if ( *s == 'u' && strEQ(s,"undef") ) {
4838 =for apidoc new_version
4840 Returns a new version object based on the passed in SV:
4842 SV *sv = new_version(SV *ver);
4844 Does not alter the passed in ver SV. See "upg_version" if you
4845 want to upgrade the SV.
4851 Perl_new_version(pTHX_ SV *ver)
4854 SV * const rv = newSV(0);
4855 PERL_ARGS_ASSERT_NEW_VERSION;
4856 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4859 AV * const av = newAV();
4861 /* This will get reblessed later if a derived class*/
4862 SV * const hv = newSVrv(rv, "version");
4863 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4864 #ifndef NODEFAULT_SHAREKEYS
4865 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4871 /* Begin copying all of the elements */
4872 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4873 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4875 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4876 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4878 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4880 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4881 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4884 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4886 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4887 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4890 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4891 /* This will get reblessed later if a derived class*/
4892 for ( key = 0; key <= av_len(sav); key++ )
4894 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4895 av_push(av, newSViv(rev));
4898 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4903 const MAGIC* const mg = SvVSTRING_mg(ver);
4904 if ( mg ) { /* already a v-string */
4905 const STRLEN len = mg->mg_len;
4906 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4907 sv_setpvn(rv,version,len);
4908 /* this is for consistency with the pure Perl class */
4909 if ( isDIGIT(*version) )
4910 sv_insert(rv, 0, 0, "v", 1);
4915 sv_setsv(rv,ver); /* make a duplicate */
4920 return upg_version(rv, FALSE);
4924 =for apidoc upg_version
4926 In-place upgrade of the supplied SV to a version object.
4928 SV *sv = upg_version(SV *sv, bool qv);
4930 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4931 to force this SV to be interpreted as an "extended" version.
4937 Perl_upg_version(pTHX_ SV *ver, bool qv)
4939 const char *version, *s;
4944 PERL_ARGS_ASSERT_UPG_VERSION;
4946 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4948 /* may get too much accuracy */
4950 #ifdef USE_LOCALE_NUMERIC
4951 char *loc = setlocale(LC_NUMERIC, "C");
4953 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4954 #ifdef USE_LOCALE_NUMERIC
4955 setlocale(LC_NUMERIC, loc);
4957 while (tbuf[len-1] == '0' && len > 0) len--;
4958 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4959 version = savepvn(tbuf, len);
4962 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4963 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4967 else /* must be a string or something like a string */
4970 version = savepv(SvPV(ver,len));
4972 # if PERL_VERSION > 5
4973 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4974 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4975 /* may be a v-string */
4976 char *testv = (char *)version;
4978 for (tlen=0; tlen < len; tlen++, testv++) {
4979 /* if one of the characters is non-text assume v-string */
4980 if (testv[0] < ' ') {
4981 SV * const nsv = sv_newmortal();
4984 int saw_decimal = 0;
4985 sv_setpvf(nsv,"v%vd",ver);
4986 pos = nver = savepv(SvPV_nolen(nsv));
4988 /* scan the resulting formatted string */
4989 pos++; /* skip the leading 'v' */
4990 while ( *pos == '.' || isDIGIT(*pos) ) {
4996 /* is definitely a v-string */
4997 if ( saw_decimal >= 2 ) {
5009 s = scan_version(version, ver, qv);
5011 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5012 "Version string '%s' contains invalid data; "
5013 "ignoring: '%s'", version, s);
5021 Validates that the SV contains valid internal structure for a version object.
5022 It may be passed either the version object (RV) or the hash itself (HV). If
5023 the structure is valid, it returns the HV. If the structure is invalid,
5026 SV *hv = vverify(sv);
5028 Note that it only confirms the bare minimum structure (so as not to get
5029 confused by derived classes which may contain additional hash entries):
5033 =item * The SV is an HV or a reference to an HV
5035 =item * The hash contains a "version" key
5037 =item * The "version" key has a reference to an AV as its value
5045 Perl_vverify(pTHX_ SV *vs)
5049 PERL_ARGS_ASSERT_VVERIFY;
5054 /* see if the appropriate elements exist */
5055 if ( SvTYPE(vs) == SVt_PVHV
5056 && hv_exists(MUTABLE_HV(vs), "version", 7)
5057 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
5058 && SvTYPE(sv) == SVt_PVAV )
5067 Accepts a version object and returns the normalized floating
5068 point representation. Call like:
5072 NOTE: you can pass either the object directly or the SV
5073 contained within the RV.
5075 The SV returned has a refcount of 1.
5081 Perl_vnumify(pTHX_ SV *vs)
5089 PERL_ARGS_ASSERT_VNUMIFY;
5091 /* extract the HV from the object */
5094 Perl_croak(aTHX_ "Invalid version object");
5096 /* see if various flags exist */
5097 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5099 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5100 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5105 /* attempt to retrieve the version array */
5106 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5107 return newSVpvs("0");
5113 return newSVpvs("0");
5116 digit = SvIV(*av_fetch(av, 0, 0));
5117 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5118 for ( i = 1 ; i < len ; i++ )
5120 digit = SvIV(*av_fetch(av, i, 0));
5122 const int denom = (width == 2 ? 10 : 100);
5123 const div_t term = div((int)PERL_ABS(digit),denom);
5124 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5127 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5133 digit = SvIV(*av_fetch(av, len, 0));
5134 if ( alpha && width == 3 ) /* alpha version */
5136 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5140 sv_catpvs(sv, "000");
5148 Accepts a version object and returns the normalized string
5149 representation. Call like:
5153 NOTE: you can pass either the object directly or the SV
5154 contained within the RV.
5156 The SV returned has a refcount of 1.
5162 Perl_vnormal(pTHX_ SV *vs)
5169 PERL_ARGS_ASSERT_VNORMAL;
5171 /* extract the HV from the object */
5174 Perl_croak(aTHX_ "Invalid version object");
5176 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5178 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5183 return newSVpvs("");
5185 digit = SvIV(*av_fetch(av, 0, 0));
5186 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5187 for ( i = 1 ; i < len ; i++ ) {
5188 digit = SvIV(*av_fetch(av, i, 0));
5189 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5194 /* handle last digit specially */
5195 digit = SvIV(*av_fetch(av, len, 0));
5197 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5199 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5202 if ( len <= 2 ) { /* short version, must be at least three */
5203 for ( len = 2 - len; len != 0; len-- )
5210 =for apidoc vstringify
5212 In order to maintain maximum compatibility with earlier versions
5213 of Perl, this function will return either the floating point
5214 notation or the multiple dotted notation, depending on whether
5215 the original version contained 1 or more dots, respectively.
5217 The SV returned has a refcount of 1.
5223 Perl_vstringify(pTHX_ SV *vs)
5225 PERL_ARGS_ASSERT_VSTRINGIFY;
5227 /* extract the HV from the object */
5230 Perl_croak(aTHX_ "Invalid version object");
5232 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
5234 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5238 return &PL_sv_undef;
5241 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5251 Version object aware cmp. Both operands must already have been
5252 converted into version objects.
5258 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5261 bool lalpha = FALSE;
5262 bool ralpha = FALSE;
5267 PERL_ARGS_ASSERT_VCMP;
5269 /* extract the HVs from the objects */
5272 if ( ! ( lhv && rhv ) )
5273 Perl_croak(aTHX_ "Invalid version object");
5275 /* get the left hand term */
5276 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5277 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5280 /* and the right hand term */
5281 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5282 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5290 while ( i <= m && retval == 0 )
5292 left = SvIV(*av_fetch(lav,i,0));
5293 right = SvIV(*av_fetch(rav,i,0));
5301 /* tiebreaker for alpha with identical terms */
5302 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5304 if ( lalpha && !ralpha )
5308 else if ( ralpha && !lalpha)
5314 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5318 while ( i <= r && retval == 0 )
5320 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5321 retval = -1; /* not a match after all */
5327 while ( i <= l && retval == 0 )
5329 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5330 retval = +1; /* not a match after all */
5338 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5339 # define EMULATE_SOCKETPAIR_UDP
5342 #ifdef EMULATE_SOCKETPAIR_UDP
5344 S_socketpair_udp (int fd[2]) {
5346 /* Fake a datagram socketpair using UDP to localhost. */
5347 int sockets[2] = {-1, -1};
5348 struct sockaddr_in addresses[2];
5350 Sock_size_t size = sizeof(struct sockaddr_in);
5351 unsigned short port;
5354 memset(&addresses, 0, sizeof(addresses));
5357 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5358 if (sockets[i] == -1)
5359 goto tidy_up_and_fail;
5361 addresses[i].sin_family = AF_INET;
5362 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5363 addresses[i].sin_port = 0; /* kernel choses port. */
5364 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5365 sizeof(struct sockaddr_in)) == -1)
5366 goto tidy_up_and_fail;
5369 /* Now have 2 UDP sockets. Find out which port each is connected to, and
5370 for each connect the other socket to it. */
5373 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5375 goto tidy_up_and_fail;
5376 if (size != sizeof(struct sockaddr_in))
5377 goto abort_tidy_up_and_fail;
5378 /* !1 is 0, !0 is 1 */
5379 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5380 sizeof(struct sockaddr_in)) == -1)
5381 goto tidy_up_and_fail;
5384 /* Now we have 2 sockets connected to each other. I don't trust some other
5385 process not to have already sent a packet to us (by random) so send
5386 a packet from each to the other. */
5389 /* I'm going to send my own port number. As a short.
5390 (Who knows if someone somewhere has sin_port as a bitfield and needs
5391 this routine. (I'm assuming crays have socketpair)) */
5392 port = addresses[i].sin_port;
5393 got = PerlLIO_write(sockets[i], &port, sizeof(port));
5394 if (got != sizeof(port)) {
5396 goto tidy_up_and_fail;
5397 goto abort_tidy_up_and_fail;
5401 /* Packets sent. I don't trust them to have arrived though.
5402 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5403 connect to localhost will use a second kernel thread. In 2.6 the
5404 first thread running the connect() returns before the second completes,
5405 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5406 returns 0. Poor programs have tripped up. One poor program's authors'
5407 had a 50-1 reverse stock split. Not sure how connected these were.)
5408 So I don't trust someone not to have an unpredictable UDP stack.
5412 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5413 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5417 FD_SET((unsigned int)sockets[0], &rset);
5418 FD_SET((unsigned int)sockets[1], &rset);
5420 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5421 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5422 || !FD_ISSET(sockets[1], &rset)) {
5423 /* I hope this is portable and appropriate. */
5425 goto tidy_up_and_fail;
5426 goto abort_tidy_up_and_fail;
5430 /* And the paranoia department even now doesn't trust it to have arrive
5431 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5433 struct sockaddr_in readfrom;
5434 unsigned short buffer[2];
5439 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5440 sizeof(buffer), MSG_DONTWAIT,
5441 (struct sockaddr *) &readfrom, &size);
5443 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5445 (struct sockaddr *) &readfrom, &size);
5449 goto tidy_up_and_fail;
5450 if (got != sizeof(port)
5451 || size != sizeof(struct sockaddr_in)
5452 /* Check other socket sent us its port. */
5453 || buffer[0] != (unsigned short) addresses[!i].sin_port
5454 /* Check kernel says we got the datagram from that socket */
5455 || readfrom.sin_family != addresses[!i].sin_family
5456 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5457 || readfrom.sin_port != addresses[!i].sin_port)
5458 goto abort_tidy_up_and_fail;
5461 /* My caller (my_socketpair) has validated that this is non-NULL */
5464 /* I hereby declare this connection open. May God bless all who cross
5468 abort_tidy_up_and_fail:
5469 errno = ECONNABORTED;
5473 if (sockets[0] != -1)
5474 PerlLIO_close(sockets[0]);
5475 if (sockets[1] != -1)
5476 PerlLIO_close(sockets[1]);
5481 #endif /* EMULATE_SOCKETPAIR_UDP */
5483 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5485 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5486 /* Stevens says that family must be AF_LOCAL, protocol 0.
5487 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5492 struct sockaddr_in listen_addr;
5493 struct sockaddr_in connect_addr;
5498 || family != AF_UNIX
5501 errno = EAFNOSUPPORT;
5509 #ifdef EMULATE_SOCKETPAIR_UDP
5510 if (type == SOCK_DGRAM)
5511 return S_socketpair_udp(fd);
5514 listener = PerlSock_socket(AF_INET, type, 0);
5517 memset(&listen_addr, 0, sizeof(listen_addr));
5518 listen_addr.sin_family = AF_INET;
5519 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5520 listen_addr.sin_port = 0; /* kernel choses port. */
5521 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5522 sizeof(listen_addr)) == -1)
5523 goto tidy_up_and_fail;
5524 if (PerlSock_listen(listener, 1) == -1)
5525 goto tidy_up_and_fail;
5527 connector = PerlSock_socket(AF_INET, type, 0);
5528 if (connector == -1)
5529 goto tidy_up_and_fail;
5530 /* We want to find out the port number to connect to. */
5531 size = sizeof(connect_addr);
5532 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5534 goto tidy_up_and_fail;
5535 if (size != sizeof(connect_addr))
5536 goto abort_tidy_up_and_fail;
5537 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5538 sizeof(connect_addr)) == -1)
5539 goto tidy_up_and_fail;
5541 size = sizeof(listen_addr);
5542 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5545 goto tidy_up_and_fail;
5546 if (size != sizeof(listen_addr))
5547 goto abort_tidy_up_and_fail;
5548 PerlLIO_close(listener);
5549 /* Now check we are talking to ourself by matching port and host on the
5551 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5553 goto tidy_up_and_fail;
5554 if (size != sizeof(connect_addr)
5555 || listen_addr.sin_family != connect_addr.sin_family
5556 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5557 || listen_addr.sin_port != connect_addr.sin_port) {
5558 goto abort_tidy_up_and_fail;
5564 abort_tidy_up_and_fail:
5566 errno = ECONNABORTED; /* This would be the standard thing to do. */
5568 # ifdef ECONNREFUSED
5569 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5571 errno = ETIMEDOUT; /* Desperation time. */
5578 PerlLIO_close(listener);
5579 if (connector != -1)
5580 PerlLIO_close(connector);
5582 PerlLIO_close(acceptor);
5588 /* In any case have a stub so that there's code corresponding
5589 * to the my_socketpair in global.sym. */
5591 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5592 #ifdef HAS_SOCKETPAIR
5593 return socketpair(family, type, protocol, fd);
5602 =for apidoc sv_nosharing
5604 Dummy routine which "shares" an SV when there is no sharing module present.
5605 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5606 Exists to avoid test for a NULL function pointer and because it could
5607 potentially warn under some level of strict-ness.
5613 Perl_sv_nosharing(pTHX_ SV *sv)
5615 PERL_UNUSED_CONTEXT;
5616 PERL_UNUSED_ARG(sv);
5621 =for apidoc sv_destroyable
5623 Dummy routine which reports that object can be destroyed when there is no
5624 sharing module present. It ignores its single SV argument, and returns
5625 'true'. Exists to avoid test for a NULL function pointer and because it
5626 could potentially warn under some level of strict-ness.
5632 Perl_sv_destroyable(pTHX_ SV *sv)
5634 PERL_UNUSED_CONTEXT;
5635 PERL_UNUSED_ARG(sv);
5640 Perl_parse_unicode_opts(pTHX_ const char **popt)
5642 const char *p = *popt;
5645 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5649 opt = (U32) atoi(p);
5652 if (*p && *p != '\n' && *p != '\r') {
5653 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5655 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5661 case PERL_UNICODE_STDIN:
5662 opt |= PERL_UNICODE_STDIN_FLAG; break;
5663 case PERL_UNICODE_STDOUT:
5664 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5665 case PERL_UNICODE_STDERR:
5666 opt |= PERL_UNICODE_STDERR_FLAG; break;
5667 case PERL_UNICODE_STD:
5668 opt |= PERL_UNICODE_STD_FLAG; break;
5669 case PERL_UNICODE_IN:
5670 opt |= PERL_UNICODE_IN_FLAG; break;
5671 case PERL_UNICODE_OUT:
5672 opt |= PERL_UNICODE_OUT_FLAG; break;
5673 case PERL_UNICODE_INOUT:
5674 opt |= PERL_UNICODE_INOUT_FLAG; break;
5675 case PERL_UNICODE_LOCALE:
5676 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5677 case PERL_UNICODE_ARGV:
5678 opt |= PERL_UNICODE_ARGV_FLAG; break;
5679 case PERL_UNICODE_UTF8CACHEASSERT:
5680 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5682 if (*p != '\n' && *p != '\r') {
5683 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5686 "Unknown Unicode option letter '%c'", *p);
5693 opt = PERL_UNICODE_DEFAULT_FLAGS;
5695 the_end_of_the_opts_parser:
5697 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5698 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5699 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5711 * This is really just a quick hack which grabs various garbage
5712 * values. It really should be a real hash algorithm which
5713 * spreads the effect of every input bit onto every output bit,
5714 * if someone who knows about such things would bother to write it.
5715 * Might be a good idea to add that function to CORE as well.
5716 * No numbers below come from careful analysis or anything here,
5717 * except they are primes and SEED_C1 > 1E6 to get a full-width
5718 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5719 * probably be bigger too.
5722 # define SEED_C1 1000003
5723 #define SEED_C4 73819
5725 # define SEED_C1 25747
5726 #define SEED_C4 20639
5730 #define SEED_C5 26107
5732 #ifndef PERL_NO_DEV_RANDOM
5737 # include <starlet.h>
5738 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5739 * in 100-ns units, typically incremented ever 10 ms. */
5740 unsigned int when[2];
5742 # ifdef HAS_GETTIMEOFDAY
5743 struct timeval when;
5749 /* This test is an escape hatch, this symbol isn't set by Configure. */
5750 #ifndef PERL_NO_DEV_RANDOM
5751 #ifndef PERL_RANDOM_DEVICE
5752 /* /dev/random isn't used by default because reads from it will block
5753 * if there isn't enough entropy available. You can compile with
5754 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5755 * is enough real entropy to fill the seed. */
5756 # define PERL_RANDOM_DEVICE "/dev/urandom"
5758 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5760 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5769 _ckvmssts(sys$gettim(when));
5770 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5772 # ifdef HAS_GETTIMEOFDAY
5773 PerlProc_gettimeofday(&when,NULL);
5774 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5777 u = (U32)SEED_C1 * when;
5780 u += SEED_C3 * (U32)PerlProc_getpid();
5781 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5782 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5783 u += SEED_C5 * (U32)PTR2UV(&when);
5789 Perl_get_hash_seed(pTHX)
5792 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5798 if (s && isDIGIT(*s))
5799 myseed = (UV)Atoul(s);
5801 #ifdef USE_HASH_SEED_EXPLICIT
5805 /* Compute a random seed */
5806 (void)seedDrand01((Rand_seed_t)seed());
5807 myseed = (UV)(Drand01() * (NV)UV_MAX);
5808 #if RANDBITS < (UVSIZE * 8)
5809 /* Since there are not enough randbits to to reach all
5810 * the bits of a UV, the low bits might need extra
5811 * help. Sum in another random number that will
5812 * fill in the low bits. */
5814 (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5815 #endif /* RANDBITS < (UVSIZE * 8) */
5816 if (myseed == 0) { /* Superparanoia. */
5817 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5819 Perl_croak(aTHX_ "Your random numbers are not that random");
5822 PL_rehash_seed_set = TRUE;
5829 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5831 const char * const stashpv = CopSTASHPV(c);
5832 const char * const name = HvNAME_get(hv);
5833 PERL_UNUSED_CONTEXT;
5834 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5836 if (stashpv == name)
5838 if (stashpv && name)
5839 if (strEQ(stashpv, name))
5846 #ifdef PERL_GLOBAL_STRUCT
5848 #define PERL_GLOBAL_STRUCT_INIT
5849 #include "opcode.h" /* the ppaddr and check */
5852 Perl_init_global_struct(pTHX)
5854 struct perl_vars *plvarsp = NULL;
5855 # ifdef PERL_GLOBAL_STRUCT
5856 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5857 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5858 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5859 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5860 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5864 plvarsp = PL_VarsPtr;
5865 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5871 # define PERLVAR(var,type) /**/
5872 # define PERLVARA(var,n,type) /**/
5873 # define PERLVARI(var,type,init) plvarsp->var = init;
5874 # define PERLVARIC(var,type,init) plvarsp->var = init;
5875 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5876 # include "perlvars.h"
5882 # ifdef PERL_GLOBAL_STRUCT
5885 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5886 if (!plvarsp->Gppaddr)
5890 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5891 if (!plvarsp->Gcheck)
5893 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5894 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5896 # ifdef PERL_SET_VARS
5897 PERL_SET_VARS(plvarsp);
5899 # undef PERL_GLOBAL_STRUCT_INIT
5904 #endif /* PERL_GLOBAL_STRUCT */
5906 #ifdef PERL_GLOBAL_STRUCT
5909 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5911 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5912 # ifdef PERL_GLOBAL_STRUCT
5913 # ifdef PERL_UNSET_VARS
5914 PERL_UNSET_VARS(plvarsp);
5916 free(plvarsp->Gppaddr);
5917 free(plvarsp->Gcheck);
5918 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5924 #endif /* PERL_GLOBAL_STRUCT */
5928 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5929 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5930 * given, and you supply your own implementation.
5932 * The default implementation reads a single env var, PERL_MEM_LOG,
5933 * expecting one or more of the following:
5935 * \d+ - fd fd to write to : must be 1st (atoi)
5936 * 'm' - memlog was PERL_MEM_LOG=1
5937 * 's' - svlog was PERL_SV_LOG=1
5938 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5940 * This makes the logger controllable enough that it can reasonably be
5941 * added to the system perl.
5944 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5945 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5947 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5949 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5950 * writes to. In the default logger, this is settable at runtime.
5952 #ifndef PERL_MEM_LOG_FD
5953 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5956 #ifndef PERL_MEM_LOG_NOIMPL
5958 # ifdef DEBUG_LEAKING_SCALARS
5959 # define SV_LOG_SERIAL_FMT " [%lu]"
5960 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5962 # define SV_LOG_SERIAL_FMT
5963 # define _SV_LOG_SERIAL_ARG(sv)
5967 S_mem_log_common(enum mem_log_type mlt, const UV n,
5968 const UV typesize, const char *type_name, const SV *sv,
5969 Malloc_t oldalloc, Malloc_t newalloc,
5970 const char *filename, const int linenumber,
5971 const char *funcname)
5975 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5977 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5980 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5982 /* We can't use SVs or PerlIO for obvious reasons,
5983 * so we'll use stdio and low-level IO instead. */
5984 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5986 # ifdef HAS_GETTIMEOFDAY
5987 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5988 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5990 gettimeofday(&tv, 0);
5992 # define MEM_LOG_TIME_FMT "%10d: "
5993 # define MEM_LOG_TIME_ARG (int)when
5997 /* If there are other OS specific ways of hires time than
5998 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5999 * probably that they would be used to fill in the struct
6003 int fd = atoi(pmlenv);
6005 fd = PERL_MEM_LOG_FD;
6007 if (strchr(pmlenv, 't')) {
6008 len = my_snprintf(buf, sizeof(buf),
6009 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
6010 PerlLIO_write(fd, buf, len);
6014 len = my_snprintf(buf, sizeof(buf),
6015 "alloc: %s:%d:%s: %"IVdf" %"UVuf
6016 " %s = %"IVdf": %"UVxf"\n",
6017 filename, linenumber, funcname, n, typesize,
6018 type_name, n * typesize, PTR2UV(newalloc));
6021 len = my_snprintf(buf, sizeof(buf),
6022 "realloc: %s:%d:%s: %"IVdf" %"UVuf
6023 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
6024 filename, linenumber, funcname, n, typesize,
6025 type_name, n * typesize, PTR2UV(oldalloc),
6029 len = my_snprintf(buf, sizeof(buf),
6030 "free: %s:%d:%s: %"UVxf"\n",
6031 filename, linenumber, funcname,
6036 len = my_snprintf(buf, sizeof(buf),
6037 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
6038 mlt == MLT_NEW_SV ? "new" : "del",
6039 filename, linenumber, funcname,
6040 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
6045 PerlLIO_write(fd, buf, len);
6049 #endif /* !PERL_MEM_LOG_NOIMPL */
6051 #ifndef PERL_MEM_LOG_NOIMPL
6053 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
6054 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
6056 /* this is suboptimal, but bug compatible. User is providing their
6057 own implementation, but is getting these functions anyway, and they
6058 do nothing. But _NOIMPL users should be able to cope or fix */
6060 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
6061 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
6065 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
6067 const char *filename, const int linenumber,
6068 const char *funcname)
6070 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6071 NULL, NULL, newalloc,
6072 filename, linenumber, funcname);
6077 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6078 Malloc_t oldalloc, Malloc_t newalloc,
6079 const char *filename, const int linenumber,
6080 const char *funcname)
6082 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6083 NULL, oldalloc, newalloc,
6084 filename, linenumber, funcname);
6089 Perl_mem_log_free(Malloc_t oldalloc,
6090 const char *filename, const int linenumber,
6091 const char *funcname)
6093 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6094 filename, linenumber, funcname);
6099 Perl_mem_log_new_sv(const SV *sv,
6100 const char *filename, const int linenumber,
6101 const char *funcname)
6103 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6104 filename, linenumber, funcname);
6108 Perl_mem_log_del_sv(const SV *sv,
6109 const char *filename, const int linenumber,
6110 const char *funcname)
6112 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6113 filename, linenumber, funcname);
6116 #endif /* PERL_MEM_LOG */
6119 =for apidoc my_sprintf
6121 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6122 the length of the string written to the buffer. Only rare pre-ANSI systems
6123 need the wrapper function - usually this is a direct call to C<sprintf>.
6127 #ifndef SPRINTF_RETURNS_STRLEN
6129 Perl_my_sprintf(char *buffer, const char* pat, ...)
6132 PERL_ARGS_ASSERT_MY_SPRINTF;
6133 va_start(args, pat);
6134 vsprintf(buffer, pat, args);
6136 return strlen(buffer);
6141 =for apidoc my_snprintf
6143 The C library C<snprintf> functionality, if available and
6144 standards-compliant (uses C<vsnprintf>, actually). However, if the
6145 C<vsnprintf> is not available, will unfortunately use the unsafe
6146 C<vsprintf> which can overrun the buffer (there is an overrun check,
6147 but that may be too late). Consider using C<sv_vcatpvf> instead, or
6148 getting C<vsnprintf>.
6153 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6158 PERL_ARGS_ASSERT_MY_SNPRINTF;
6159 va_start(ap, format);
6160 #ifdef HAS_VSNPRINTF
6161 retval = vsnprintf(buffer, len, format, ap);
6163 retval = vsprintf(buffer, format, ap);
6166 /* vsprintf() shows failure with < 0 */
6168 #ifdef HAS_VSNPRINTF
6169 /* vsnprintf() shows failure with >= len */
6171 (len > 0 && (Size_t)retval >= len)
6174 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6179 =for apidoc my_vsnprintf
6181 The C library C<vsnprintf> if available and standards-compliant.
6182 However, if if the C<vsnprintf> is not available, will unfortunately
6183 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6184 overrun check, but that may be too late). Consider using
6185 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6190 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6197 PERL_ARGS_ASSERT_MY_VSNPRINTF;
6199 Perl_va_copy(ap, apc);
6200 # ifdef HAS_VSNPRINTF
6201 retval = vsnprintf(buffer, len, format, apc);
6203 retval = vsprintf(buffer, format, apc);
6206 # ifdef HAS_VSNPRINTF
6207 retval = vsnprintf(buffer, len, format, ap);
6209 retval = vsprintf(buffer, format, ap);
6211 #endif /* #ifdef NEED_VA_COPY */
6212 /* vsprintf() shows failure with < 0 */
6214 #ifdef HAS_VSNPRINTF
6215 /* vsnprintf() shows failure with >= len */
6217 (len > 0 && (Size_t)retval >= len)
6220 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6225 Perl_my_clearenv(pTHX)
6228 #if ! defined(PERL_MICRO)
6229 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6231 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6232 # if defined(USE_ENVIRON_ARRAY)
6233 # if defined(USE_ITHREADS)
6234 /* only the parent thread can clobber the process environment */
6235 if (PL_curinterp == aTHX)
6236 # endif /* USE_ITHREADS */
6238 # if ! defined(PERL_USE_SAFE_PUTENV)
6239 if ( !PL_use_safe_putenv) {
6241 if (environ == PL_origenviron)
6242 environ = (char**)safesysmalloc(sizeof(char*));
6244 for (i = 0; environ[i]; i++)
6245 (void)safesysfree(environ[i]);
6248 # else /* PERL_USE_SAFE_PUTENV */
6249 # if defined(HAS_CLEARENV)
6251 # elif defined(HAS_UNSETENV)
6252 int bsiz = 80; /* Most envvar names will be shorter than this. */
6253 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6254 char *buf = (char*)safesysmalloc(bufsiz);
6255 while (*environ != NULL) {
6256 char *e = strchr(*environ, '=');
6257 int l = e ? e - *environ : (int)strlen(*environ);
6259 (void)safesysfree(buf);
6260 bsiz = l + 1; /* + 1 for the \0. */
6261 buf = (char*)safesysmalloc(bufsiz);
6263 memcpy(buf, *environ, l);
6265 (void)unsetenv(buf);
6267 (void)safesysfree(buf);
6268 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6269 /* Just null environ and accept the leakage. */
6271 # endif /* HAS_CLEARENV || HAS_UNSETENV */
6272 # endif /* ! PERL_USE_SAFE_PUTENV */
6274 # endif /* USE_ENVIRON_ARRAY */
6275 # endif /* PERL_IMPLICIT_SYS || WIN32 */
6276 #endif /* PERL_MICRO */
6279 #ifdef PERL_IMPLICIT_CONTEXT
6281 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6282 the global PL_my_cxt_index is incremented, and that value is assigned to
6283 that module's static my_cxt_index (who's address is passed as an arg).
6284 Then, for each interpreter this function is called for, it makes sure a
6285 void* slot is available to hang the static data off, by allocating or
6286 extending the interpreter's PL_my_cxt_list array */
6288 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6290 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6294 PERL_ARGS_ASSERT_MY_CXT_INIT;
6296 /* this module hasn't been allocated an index yet */
6297 #if defined(USE_ITHREADS)
6298 MUTEX_LOCK(&PL_my_ctx_mutex);
6300 *index = PL_my_cxt_index++;
6301 #if defined(USE_ITHREADS)
6302 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6306 /* make sure the array is big enough */
6307 if (PL_my_cxt_size <= *index) {
6308 if (PL_my_cxt_size) {
6309 while (PL_my_cxt_size <= *index)
6310 PL_my_cxt_size *= 2;
6311 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6314 PL_my_cxt_size = 16;
6315 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6318 /* newSV() allocates one more than needed */
6319 p = (void*)SvPVX(newSV(size-1));
6320 PL_my_cxt_list[*index] = p;
6321 Zero(p, size, char);
6325 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6328 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6333 PERL_ARGS_ASSERT_MY_CXT_INDEX;
6335 for (index = 0; index < PL_my_cxt_index; index++) {
6336 const char *key = PL_my_cxt_keys[index];
6337 /* try direct pointer compare first - there are chances to success,
6338 * and it's much faster.
6340 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6347 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6353 PERL_ARGS_ASSERT_MY_CXT_INIT;
6355 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6357 /* this module hasn't been allocated an index yet */
6358 #if defined(USE_ITHREADS)
6359 MUTEX_LOCK(&PL_my_ctx_mutex);
6361 index = PL_my_cxt_index++;
6362 #if defined(USE_ITHREADS)
6363 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6367 /* make sure the array is big enough */
6368 if (PL_my_cxt_size <= index) {
6369 int old_size = PL_my_cxt_size;
6371 if (PL_my_cxt_size) {
6372 while (PL_my_cxt_size <= index)
6373 PL_my_cxt_size *= 2;
6374 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6375 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6378 PL_my_cxt_size = 16;
6379 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6380 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6382 for (i = old_size; i < PL_my_cxt_size; i++) {
6383 PL_my_cxt_keys[i] = 0;
6384 PL_my_cxt_list[i] = 0;
6387 PL_my_cxt_keys[index] = my_cxt_key;
6388 /* newSV() allocates one more than needed */
6389 p = (void*)SvPVX(newSV(size-1));
6390 PL_my_cxt_list[index] = p;
6391 Zero(p, size, char);
6394 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6395 #endif /* PERL_IMPLICIT_CONTEXT */
6398 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
6402 const char *vn = NULL;
6403 SV *const module = PL_stack_base[ax];
6405 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
6407 if (items >= 2) /* version supplied as bootstrap arg */
6408 sv = PL_stack_base[ax + 1];
6410 /* XXX GV_ADDWARN */
6412 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6413 if (!sv || !SvOK(sv)) {
6415 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6419 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
6420 SV *pmsv = sv_derived_from(sv, "version")
6421 ? sv : sv_2mortal(new_version(sv));
6422 xssv = upg_version(xssv, 0);
6423 if ( vcmp(pmsv,xssv) ) {
6424 SV *string = vstringify(xssv);
6425 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
6426 " does not match ", module, string);
6428 SvREFCNT_dec(string);
6429 string = vstringify(pmsv);
6432 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
6435 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6437 SvREFCNT_dec(string);
6439 Perl_sv_2mortal(aTHX_ xpt);
6440 Perl_croak_sv(aTHX_ xpt);
6446 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6450 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6453 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6455 /* This might croak */
6456 compver = upg_version(compver, 0);
6457 /* This should never croak */
6458 runver = new_version(PL_apiversion);
6459 if (vcmp(compver, runver)) {
6460 SV *compver_string = vstringify(compver);
6461 SV *runver_string = vstringify(runver);
6462 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6463 " of %"SVf" does not match %"SVf,
6464 compver_string, module, runver_string);
6465 Perl_sv_2mortal(aTHX_ xpt);
6467 SvREFCNT_dec(compver_string);
6468 SvREFCNT_dec(runver_string);
6470 SvREFCNT_dec(runver);
6472 Perl_croak_sv(aTHX_ xpt);
6477 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6479 Size_t used, length, copy;
6482 length = strlen(src);
6483 if (size > 0 && used < size - 1) {
6484 copy = (length >= size - used) ? size - used - 1 : length;
6485 memcpy(dst + used, src, copy);
6486 dst[used + copy] = '\0';
6488 return used + length;
6494 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6496 Size_t length, copy;
6498 length = strlen(src);
6500 copy = (length >= size) ? size - 1 : length;
6501 memcpy(dst, src, copy);
6508 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6509 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6510 long _ftol( double ); /* Defined by VC6 C libs. */
6511 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6515 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6518 SV * const dbsv = GvSVn(PL_DBsub);
6519 const bool save_taint = PL_tainted;
6521 /* We do not care about using sv to call CV;
6522 * it's for informational purposes only.
6525 PERL_ARGS_ASSERT_GET_DB_SUB;
6529 if (!PERLDB_SUB_NN) {
6532 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6533 || strEQ(GvNAME(gv), "END")
6534 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6535 !( (SvTYPE(*svp) == SVt_PVGV)
6536 && (GvCV((const GV *)*svp) == cv)
6537 && (gv = (GV *)*svp)
6541 /* Use GV from the stack as a fallback. */
6542 /* GV is potentially non-unique, or contain different CV. */
6543 SV * const tmp = newRV(MUTABLE_SV(cv));
6544 sv_setsv(dbsv, tmp);
6548 gv_efullname3(dbsv, gv, NULL);
6552 const int type = SvTYPE(dbsv);
6553 if (type < SVt_PVIV && type != SVt_IV)
6554 sv_upgrade(dbsv, SVt_PVIV);
6555 (void)SvIOK_on(dbsv);
6556 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6558 TAINT_IF(save_taint);
6562 Perl_my_dirfd(pTHX_ DIR * dir) {
6564 /* Most dirfd implementations have problems when passed NULL. */
6569 #elif defined(HAS_DIR_DD_FD)
6572 Perl_die(aTHX_ PL_no_func, "dirfd");
6579 Perl_get_re_arg(pTHX_ SV *sv) {
6585 sv = MUTABLE_SV(SvRV(sv));
6586 if (SvTYPE(sv) == SVt_REGEXP)
6587 return (REGEXP*) sv;
6595 * c-indentation-style: bsd
6597 * indent-tabs-mode: t
6600 * ex: set ts=8 sts=4 sw=4 noet: