3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
15 * [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
18 /* This file contains assorted utility routines.
19 * Which is a polite way of saying any stuff that people couldn't think of
20 * a better place for. Amongst other things, it includes the warning and
21 * dieing stuff, plus wrappers for malloc code.
25 #define PERL_IN_UTIL_C
31 # define SIG_ERR ((Sighandler_t) -1)
36 /* Missing protos on LynxOS */
41 # include <sys/wait.h>
46 # include <sys/select.h>
52 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
53 # define FD_CLOEXEC 1 /* NeXT needs this */
56 /* NOTE: Do not call the next three routines directly. Use the macros
57 * in handy.h, so that we can easily redefine everything to do tracking of
58 * allocated hunks back to the original New to track down any memory leaks.
59 * XXX This advice seems to be widely ignored :-( --AD August 1996.
66 /* Can't use PerlIO to write as it allocates memory */
67 PerlLIO_write(PerlIO_fileno(Perl_error_log),
68 PL_no_mem, strlen(PL_no_mem));
70 NORETURN_FUNCTION_END;
73 /* paranoid version of system's malloc() */
76 Perl_safesysmalloc(MEM_SIZE size)
82 PerlIO_printf(Perl_error_log,
83 "Allocation too large: %lx\n", size) FLUSH;
86 #endif /* HAS_64K_LIMIT */
87 #ifdef PERL_TRACK_MEMPOOL
92 Perl_croak_nocontext("panic: malloc");
94 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
95 PERL_ALLOC_CHECK(ptr);
96 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
98 #ifdef PERL_TRACK_MEMPOOL
99 struct perl_memory_debug_header *const header
100 = (struct perl_memory_debug_header *)ptr;
104 PoisonNew(((char *)ptr), size, char);
107 #ifdef PERL_TRACK_MEMPOOL
108 header->interpreter = aTHX;
109 /* Link us into the list. */
110 header->prev = &PL_memory_debug_header;
111 header->next = PL_memory_debug_header.next;
112 PL_memory_debug_header.next = header;
113 header->next->prev = header;
117 ptr = (Malloc_t)((char*)ptr+sTHX);
124 return write_no_mem();
129 /* paranoid version of system's realloc() */
132 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
136 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
137 Malloc_t PerlMem_realloc();
138 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
142 PerlIO_printf(Perl_error_log,
143 "Reallocation too large: %lx\n", size) FLUSH;
146 #endif /* HAS_64K_LIMIT */
153 return safesysmalloc(size);
154 #ifdef PERL_TRACK_MEMPOOL
155 where = (Malloc_t)((char*)where-sTHX);
158 struct perl_memory_debug_header *const header
159 = (struct perl_memory_debug_header *)where;
161 if (header->interpreter != aTHX) {
162 Perl_croak_nocontext("panic: realloc from wrong pool");
164 assert(header->next->prev == header);
165 assert(header->prev->next == header);
167 if (header->size > size) {
168 const MEM_SIZE freed_up = header->size - size;
169 char *start_of_freed = ((char *)where) + size;
170 PoisonFree(start_of_freed, freed_up, char);
178 Perl_croak_nocontext("panic: realloc");
180 ptr = (Malloc_t)PerlMem_realloc(where,size);
181 PERL_ALLOC_CHECK(ptr);
183 /* MUST do this fixup first, before doing ANYTHING else, as anything else
184 might allocate memory/free/move memory, and until we do the fixup, it
185 may well be chasing (and writing to) free memory. */
186 #ifdef PERL_TRACK_MEMPOOL
188 struct perl_memory_debug_header *const header
189 = (struct perl_memory_debug_header *)ptr;
192 if (header->size < size) {
193 const MEM_SIZE fresh = size - header->size;
194 char *start_of_fresh = ((char *)ptr) + size;
195 PoisonNew(start_of_fresh, fresh, char);
199 header->next->prev = header;
200 header->prev->next = header;
202 ptr = (Malloc_t)((char*)ptr+sTHX);
206 /* In particular, must do that fixup above before logging anything via
207 *printf(), as it can reallocate memory, which can cause SEGVs. */
209 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
210 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
219 return write_no_mem();
224 /* safe version of system's free() */
227 Perl_safesysfree(Malloc_t where)
229 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
234 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
236 #ifdef PERL_TRACK_MEMPOOL
237 where = (Malloc_t)((char*)where-sTHX);
239 struct perl_memory_debug_header *const header
240 = (struct perl_memory_debug_header *)where;
242 if (header->interpreter != aTHX) {
243 Perl_croak_nocontext("panic: free from wrong pool");
246 Perl_croak_nocontext("panic: duplicate free");
248 if (!(header->next) || header->next->prev != header
249 || header->prev->next != header) {
250 Perl_croak_nocontext("panic: bad free");
252 /* Unlink us from the chain. */
253 header->next->prev = header->prev;
254 header->prev->next = header->next;
256 PoisonNew(where, header->size, char);
258 /* Trigger the duplicate free warning. */
266 /* safe version of system's calloc() */
269 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
273 MEM_SIZE total_size = 0;
275 /* Even though calloc() for zero bytes is strange, be robust. */
276 if (size && (count <= MEM_SIZE_MAX / size))
277 total_size = size * count;
279 Perl_croak_nocontext("%s", PL_memory_wrap);
280 #ifdef PERL_TRACK_MEMPOOL
281 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
284 Perl_croak_nocontext("%s", PL_memory_wrap);
287 if (total_size > 0xffff) {
288 PerlIO_printf(Perl_error_log,
289 "Allocation too large: %lx\n", total_size) FLUSH;
292 #endif /* HAS_64K_LIMIT */
294 if ((long)size < 0 || (long)count < 0)
295 Perl_croak_nocontext("panic: calloc");
297 #ifdef PERL_TRACK_MEMPOOL
298 /* Have to use malloc() because we've added some space for our tracking
300 /* malloc(0) is non-portable. */
301 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
303 /* Use calloc() because it might save a memset() if the memory is fresh
304 and clean from the OS. */
306 ptr = (Malloc_t)PerlMem_calloc(count, size);
307 else /* calloc(0) is non-portable. */
308 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
310 PERL_ALLOC_CHECK(ptr);
311 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
313 #ifdef PERL_TRACK_MEMPOOL
315 struct perl_memory_debug_header *const header
316 = (struct perl_memory_debug_header *)ptr;
318 memset((void*)ptr, 0, total_size);
319 header->interpreter = aTHX;
320 /* Link us into the list. */
321 header->prev = &PL_memory_debug_header;
322 header->next = PL_memory_debug_header.next;
323 PL_memory_debug_header.next = header;
324 header->next->prev = header;
326 header->size = total_size;
328 ptr = (Malloc_t)((char*)ptr+sTHX);
335 return write_no_mem();
338 /* These must be defined when not using Perl's malloc for binary
343 Malloc_t Perl_malloc (MEM_SIZE nbytes)
346 return (Malloc_t)PerlMem_malloc(nbytes);
349 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
352 return (Malloc_t)PerlMem_calloc(elements, size);
355 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
358 return (Malloc_t)PerlMem_realloc(where, nbytes);
361 Free_t Perl_mfree (Malloc_t where)
369 /* copy a string up to some (non-backslashed) delimiter, if any */
372 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
376 PERL_ARGS_ASSERT_DELIMCPY;
378 for (tolen = 0; from < fromend; from++, tolen++) {
380 if (from[1] != delim) {
387 else if (*from == delim)
398 /* return ptr to little string in big string, NULL if not found */
399 /* This routine was donated by Corey Satten. */
402 Perl_instr(register const char *big, register const char *little)
406 PERL_ARGS_ASSERT_INSTR;
414 register const char *s, *x;
417 for (x=big,s=little; *s; /**/ ) {
428 return (char*)(big-1);
433 /* same as instr but allow embedded nulls */
436 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
438 PERL_ARGS_ASSERT_NINSTR;
442 const char first = *little;
444 bigend -= lend - little++;
446 while (big <= bigend) {
447 if (*big++ == first) {
448 for (x=big,s=little; s < lend; x++,s++) {
452 return (char*)(big-1);
459 /* reverse of the above--find last substring */
462 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
464 register const char *bigbeg;
465 register const I32 first = *little;
466 register const char * const littleend = lend;
468 PERL_ARGS_ASSERT_RNINSTR;
470 if (little >= littleend)
471 return (char*)bigend;
473 big = bigend - (littleend - little++);
474 while (big >= bigbeg) {
475 register const char *s, *x;
478 for (x=big+2,s=little; s < littleend; /**/ ) {
487 return (char*)(big+1);
492 /* As a space optimization, we do not compile tables for strings of length
493 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
494 special-cased in fbm_instr().
496 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
499 =head1 Miscellaneous Functions
501 =for apidoc fbm_compile
503 Analyses the string in order to make fast searches on it using fbm_instr()
504 -- the Boyer-Moore algorithm.
510 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
513 register const U8 *s;
519 PERL_ARGS_ASSERT_FBM_COMPILE;
521 if (flags & FBMcf_TAIL) {
522 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
523 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
524 if (mg && mg->mg_len >= 0)
527 s = (U8*)SvPV_force_mutable(sv, len);
528 if (len == 0) /* TAIL might be on a zero-length string. */
530 SvUPGRADE(sv, SVt_PVGV);
535 const unsigned char *sb;
536 const U8 mlen = (len>255) ? 255 : (U8)len;
539 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
541 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
542 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
543 memset((void*)table, mlen, 256);
545 sb = s - mlen + 1; /* first char (maybe) */
547 if (table[*s] == mlen)
552 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
554 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
556 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
557 for (i = 0; i < len; i++) {
558 if (PL_freq[s[i]] < frequency) {
560 frequency = PL_freq[s[i]];
563 BmFLAGS(sv) = (U8)flags;
564 BmRARE(sv) = s[rarest];
565 BmPREVIOUS(sv) = rarest;
566 BmUSEFUL(sv) = 100; /* Initial value */
567 if (flags & FBMcf_TAIL)
569 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
570 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
573 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
574 /* If SvTAIL is actually due to \Z or \z, this gives false positives
578 =for apidoc fbm_instr
580 Returns the location of the SV in the string delimited by C<str> and
581 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
582 does not have to be fbm_compiled, but the search will not be as fast
589 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
591 register unsigned char *s;
593 register const unsigned char *little
594 = (const unsigned char *)SvPV_const(littlestr,l);
595 register STRLEN littlelen = l;
596 register const I32 multiline = flags & FBMrf_MULTILINE;
598 PERL_ARGS_ASSERT_FBM_INSTR;
600 if ((STRLEN)(bigend - big) < littlelen) {
601 if ( SvTAIL(littlestr)
602 && ((STRLEN)(bigend - big) == littlelen - 1)
604 || (*big == *little &&
605 memEQ((char *)big, (char *)little, littlelen - 1))))
610 if (littlelen <= 2) { /* Special-cased */
612 if (littlelen == 1) {
613 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
614 /* Know that bigend != big. */
615 if (bigend[-1] == '\n')
616 return (char *)(bigend - 1);
617 return (char *) bigend;
625 if (SvTAIL(littlestr))
626 return (char *) bigend;
630 return (char*)big; /* Cannot be SvTAIL! */
633 if (SvTAIL(littlestr) && !multiline) {
634 if (bigend[-1] == '\n' && bigend[-2] == *little)
635 return (char*)bigend - 2;
636 if (bigend[-1] == *little)
637 return (char*)bigend - 1;
641 /* This should be better than FBM if c1 == c2, and almost
642 as good otherwise: maybe better since we do less indirection.
643 And we save a lot of memory by caching no table. */
644 const unsigned char c1 = little[0];
645 const unsigned char c2 = little[1];
650 while (s <= bigend) {
660 goto check_1char_anchor;
671 goto check_1char_anchor;
674 while (s <= bigend) {
679 goto check_1char_anchor;
688 check_1char_anchor: /* One char and anchor! */
689 if (SvTAIL(littlestr) && (*bigend == *little))
690 return (char *)bigend; /* bigend is already decremented. */
693 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
694 s = bigend - littlelen;
695 if (s >= big && bigend[-1] == '\n' && *s == *little
696 /* Automatically of length > 2 */
697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
699 return (char*)s; /* how sweet it is */
702 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
704 return (char*)s + 1; /* how sweet it is */
708 if (!SvVALID(littlestr)) {
709 char * const b = ninstr((char*)big,(char*)bigend,
710 (char*)little, (char*)little + littlelen);
712 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
713 /* Chop \n from littlestr: */
714 s = bigend - littlelen + 1;
716 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
726 if (littlelen > (STRLEN)(bigend - big))
730 register const unsigned char * const table
731 = little + littlelen + PERL_FBM_TABLE_OFFSET;
732 register const unsigned char *oldlittle;
734 --littlelen; /* Last char found by table lookup */
737 little += littlelen; /* last char */
743 if ((tmp = table[*s])) {
744 if ((s += tmp) < bigend)
748 else { /* less expensive than calling strncmp() */
749 register unsigned char * const olds = s;
754 if (*--s == *--little)
756 s = olds + 1; /* here we pay the price for failure */
758 if (s < bigend) /* fake up continue to outer loop */
767 && (BmFLAGS(littlestr) & FBMcf_TAIL)
768 && memEQ((char *)(bigend - littlelen),
769 (char *)(oldlittle - littlelen), littlelen) )
770 return (char*)bigend - littlelen;
775 /* start_shift, end_shift are positive quantities which give offsets
776 of ends of some substring of bigstr.
777 If "last" we want the last occurrence.
778 old_posp is the way of communication between consequent calls if
779 the next call needs to find the .
780 The initial *old_posp should be -1.
782 Note that we take into account SvTAIL, so one can get extra
783 optimizations if _ALL flag is set.
786 /* If SvTAIL is actually due to \Z or \z, this gives false positives
787 if PL_multiline. In fact if !PL_multiline the authoritative answer
788 is not supported yet. */
791 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
794 register const unsigned char *big;
796 register I32 previous;
798 register const unsigned char *little;
799 register I32 stop_pos;
800 register const unsigned char *littleend;
803 PERL_ARGS_ASSERT_SCREAMINSTR;
805 assert(SvTYPE(littlestr) == SVt_PVGV);
806 assert(SvVALID(littlestr));
809 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
810 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
812 if ( BmRARE(littlestr) == '\n'
813 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
814 little = (const unsigned char *)(SvPVX_const(littlestr));
815 littleend = little + SvCUR(littlestr);
822 little = (const unsigned char *)(SvPVX_const(littlestr));
823 littleend = little + SvCUR(littlestr);
825 /* The value of pos we can start at: */
826 previous = BmPREVIOUS(littlestr);
827 big = (const unsigned char *)(SvPVX_const(bigstr));
828 /* The value of pos we can stop at: */
829 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
830 if (previous + start_shift > stop_pos) {
832 stop_pos does not include SvTAIL in the count, so this check is incorrect
833 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
836 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
841 while (pos < previous + start_shift) {
842 if (!(pos += PL_screamnext[pos]))
847 register const unsigned char *s, *x;
848 if (pos >= stop_pos) break;
849 if (big[pos] != first)
851 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
857 if (s == littleend) {
859 if (!last) return (char *)(big+pos);
862 } while ( pos += PL_screamnext[pos] );
864 return (char *)(big+(*old_posp));
866 if (!SvTAIL(littlestr) || (end_shift > 0))
868 /* Ignore the trailing "\n". This code is not microoptimized */
869 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
870 stop_pos = littleend - little; /* Actual littlestr len */
875 && ((stop_pos == 1) ||
876 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
882 Perl_ibcmp(const char *s1, const char *s2, register I32 len)
884 register const U8 *a = (const U8 *)s1;
885 register const U8 *b = (const U8 *)s2;
887 PERL_ARGS_ASSERT_IBCMP;
890 if (*a != *b && *a != PL_fold[*b])
898 Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
901 register const U8 *a = (const U8 *)s1;
902 register const U8 *b = (const U8 *)s2;
904 PERL_ARGS_ASSERT_IBCMP_LOCALE;
907 if (*a != *b && *a != PL_fold_locale[*b])
914 /* copy a string to a safe spot */
917 =head1 Memory Management
921 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
922 string which is a duplicate of C<pv>. The size of the string is
923 determined by C<strlen()>. The memory allocated for the new string can
924 be freed with the C<Safefree()> function.
930 Perl_savepv(pTHX_ const char *pv)
937 const STRLEN pvlen = strlen(pv)+1;
938 Newx(newaddr, pvlen, char);
939 return (char*)memcpy(newaddr, pv, pvlen);
943 /* same thing but with a known length */
948 Perl's version of what C<strndup()> would be if it existed. Returns a
949 pointer to a newly allocated string which is a duplicate of the first
950 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
951 the new string can be freed with the C<Safefree()> function.
957 Perl_savepvn(pTHX_ const char *pv, register I32 len)
959 register char *newaddr;
962 Newx(newaddr,len+1,char);
963 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
965 /* might not be null terminated */
967 return (char *) CopyD(pv,newaddr,len,char);
970 return (char *) ZeroD(newaddr,len+1,char);
975 =for apidoc savesharedpv
977 A version of C<savepv()> which allocates the duplicate string in memory
978 which is shared between threads.
983 Perl_savesharedpv(pTHX_ const char *pv)
985 register char *newaddr;
990 pvlen = strlen(pv)+1;
991 newaddr = (char*)PerlMemShared_malloc(pvlen);
993 return write_no_mem();
995 return (char*)memcpy(newaddr, pv, pvlen);
999 =for apidoc savesharedpvn
1001 A version of C<savepvn()> which allocates the duplicate string in memory
1002 which is shared between threads. (With the specific difference that a NULL
1003 pointer is not acceptable)
1008 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1010 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1012 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1015 return write_no_mem();
1017 newaddr[len] = '\0';
1018 return (char*)memcpy(newaddr, pv, len);
1022 =for apidoc savesvpv
1024 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1025 the passed in SV using C<SvPV()>
1031 Perl_savesvpv(pTHX_ SV *sv)
1034 const char * const pv = SvPV_const(sv, len);
1035 register char *newaddr;
1037 PERL_ARGS_ASSERT_SAVESVPV;
1040 Newx(newaddr,len,char);
1041 return (char *) CopyD(pv,newaddr,len,char);
1045 /* the SV for Perl_form() and mess() is not kept in an arena */
1055 return newSVpvs_flags("", SVs_TEMP);
1060 /* Create as PVMG now, to avoid any upgrading later */
1062 Newxz(any, 1, XPVMG);
1063 SvFLAGS(sv) = SVt_PVMG;
1064 SvANY(sv) = (void*)any;
1066 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1071 #if defined(PERL_IMPLICIT_CONTEXT)
1073 Perl_form_nocontext(const char* pat, ...)
1078 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1079 va_start(args, pat);
1080 retval = vform(pat, &args);
1084 #endif /* PERL_IMPLICIT_CONTEXT */
1087 =head1 Miscellaneous Functions
1090 Takes a sprintf-style format pattern and conventional
1091 (non-SV) arguments and returns the formatted string.
1093 (char *) Perl_form(pTHX_ const char* pat, ...)
1095 can be used any place a string (char *) is required:
1097 char * s = Perl_form("%d.%d",major,minor);
1099 Uses a single private buffer so if you want to format several strings you
1100 must explicitly copy the earlier strings away (and free the copies when you
1107 Perl_form(pTHX_ const char* pat, ...)
1111 PERL_ARGS_ASSERT_FORM;
1112 va_start(args, pat);
1113 retval = vform(pat, &args);
1119 Perl_vform(pTHX_ const char *pat, va_list *args)
1121 SV * const sv = mess_alloc();
1122 PERL_ARGS_ASSERT_VFORM;
1123 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1127 #if defined(PERL_IMPLICIT_CONTEXT)
1129 Perl_mess_nocontext(const char *pat, ...)
1134 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1135 va_start(args, pat);
1136 retval = vmess(pat, &args);
1140 #endif /* PERL_IMPLICIT_CONTEXT */
1143 Perl_mess(pTHX_ const char *pat, ...)
1147 PERL_ARGS_ASSERT_MESS;
1148 va_start(args, pat);
1149 retval = vmess(pat, &args);
1155 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1158 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1160 PERL_ARGS_ASSERT_CLOSEST_COP;
1162 if (!o || o == PL_op)
1165 if (o->op_flags & OPf_KIDS) {
1167 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1170 /* If the OP_NEXTSTATE has been optimised away we can still use it
1171 * the get the file and line number. */
1173 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1174 cop = (const COP *)kid;
1176 /* Keep searching, and return when we've found something. */
1178 new_cop = closest_cop(cop, kid);
1184 /* Nothing found. */
1190 Perl_vmess(pTHX_ const char *pat, va_list *args)
1193 SV * const sv = mess_alloc();
1195 PERL_ARGS_ASSERT_VMESS;
1197 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1198 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1200 * Try and find the file and line for PL_op. This will usually be
1201 * PL_curcop, but it might be a cop that has been optimised away. We
1202 * can try to find such a cop by searching through the optree starting
1203 * from the sibling of PL_curcop.
1206 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1211 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1212 OutCopFILE(cop), (IV)CopLINE(cop));
1213 /* Seems that GvIO() can be untrustworthy during global destruction. */
1214 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1215 && IoLINES(GvIOp(PL_last_in_gv)))
1217 const bool line_mode = (RsSIMPLE(PL_rs) &&
1218 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1219 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1220 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1221 line_mode ? "line" : "chunk",
1222 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1225 sv_catpvs(sv, " during global destruction");
1226 sv_catpvs(sv, ".\n");
1232 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1238 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1240 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1241 && (io = GvIO(PL_stderrgv))
1242 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1249 SAVESPTR(PL_stderrgv);
1252 PUSHSTACKi(PERLSI_MAGIC);
1256 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1257 mPUSHp(message, msglen);
1259 call_method("PRINT", G_SCALAR);
1267 /* SFIO can really mess with your errno */
1270 PerlIO * const serr = Perl_error_log;
1272 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1273 (void)PerlIO_flush(serr);
1280 /* Common code used by vcroak, vdie, vwarn and vwarner */
1283 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
1289 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1290 /* sv_2cv might call Perl_croak() or Perl_warner() */
1291 SV * const oldhook = *hook;
1298 cv = sv_2cv(oldhook, &stash, &gv, 0);
1300 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1310 if (warn || message) {
1311 msg = newSVpvn_flags(message, msglen, utf8);
1319 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1323 call_sv(MUTABLE_SV(cv), G_DISCARD);
1332 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1336 const char *message;
1339 SV * const msv = vmess(pat, args);
1340 if (PL_errors && SvCUR(PL_errors)) {
1341 sv_catsv(PL_errors, msv);
1342 message = SvPV_const(PL_errors, *msglen);
1343 SvCUR_set(PL_errors, 0);
1346 message = SvPV_const(msv,*msglen);
1347 *utf8 = SvUTF8(msv);
1354 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1360 S_vdie(pTHX_ const char* pat, va_list *args)
1363 const char *message;
1367 message = vdie_croak_common(pat, args, &msglen, &utf8);
1369 PL_restartop = die_where(message, msglen);
1370 SvFLAGS(ERRSV) |= utf8;
1376 #if defined(PERL_IMPLICIT_CONTEXT)
1378 Perl_die_nocontext(const char* pat, ...)
1383 va_start(args, pat);
1384 o = vdie(pat, &args);
1388 #endif /* PERL_IMPLICIT_CONTEXT */
1391 Perl_die(pTHX_ const char* pat, ...)
1395 va_start(args, pat);
1396 o = vdie(pat, &args);
1402 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1405 const char *message;
1409 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1412 PL_restartop = die_where(message, msglen);
1413 SvFLAGS(ERRSV) |= utf8;
1417 message = SvPVx_const(ERRSV, msglen);
1419 write_to_stderr(message, msglen);
1423 #if defined(PERL_IMPLICIT_CONTEXT)
1425 Perl_croak_nocontext(const char *pat, ...)
1429 va_start(args, pat);
1434 #endif /* PERL_IMPLICIT_CONTEXT */
1437 =head1 Warning and Dieing
1441 This is the XSUB-writer's interface to Perl's C<die> function.
1442 Normally call this function the same way you call the C C<printf>
1443 function. Calling C<croak> returns control directly to Perl,
1444 sidestepping the normal C order of execution. See C<warn>.
1446 If you want to throw an exception object, assign the object to
1447 C<$@> and then pass C<NULL> to croak():
1449 errsv = get_sv("@", GV_ADD);
1450 sv_setsv(errsv, exception_object);
1457 Perl_croak(pTHX_ const char *pat, ...)
1460 va_start(args, pat);
1467 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1471 SV * const msv = vmess(pat, args);
1472 const I32 utf8 = SvUTF8(msv);
1473 const char * const message = SvPV_const(msv, msglen);
1475 PERL_ARGS_ASSERT_VWARN;
1478 if (vdie_common(message, msglen, utf8, TRUE))
1482 write_to_stderr(message, msglen);
1485 #if defined(PERL_IMPLICIT_CONTEXT)
1487 Perl_warn_nocontext(const char *pat, ...)
1491 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1492 va_start(args, pat);
1496 #endif /* PERL_IMPLICIT_CONTEXT */
1501 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1502 function the same way you call the C C<printf> function. See C<croak>.
1508 Perl_warn(pTHX_ const char *pat, ...)
1511 PERL_ARGS_ASSERT_WARN;
1512 va_start(args, pat);
1517 #if defined(PERL_IMPLICIT_CONTEXT)
1519 Perl_warner_nocontext(U32 err, const char *pat, ...)
1523 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1524 va_start(args, pat);
1525 vwarner(err, pat, &args);
1528 #endif /* PERL_IMPLICIT_CONTEXT */
1531 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1533 PERL_ARGS_ASSERT_CK_WARNER_D;
1535 if (Perl_ckwarn_d(aTHX_ err)) {
1537 va_start(args, pat);
1538 vwarner(err, pat, &args);
1544 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1546 PERL_ARGS_ASSERT_CK_WARNER;
1548 if (Perl_ckwarn(aTHX_ err)) {
1550 va_start(args, pat);
1551 vwarner(err, pat, &args);
1557 Perl_warner(pTHX_ U32 err, const char* pat,...)
1560 PERL_ARGS_ASSERT_WARNER;
1561 va_start(args, pat);
1562 vwarner(err, pat, &args);
1567 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1570 PERL_ARGS_ASSERT_VWARNER;
1571 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1572 SV * const msv = vmess(pat, args);
1574 const char * const message = SvPV_const(msv, msglen);
1575 const I32 utf8 = SvUTF8(msv);
1579 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1582 PL_restartop = die_where(message, msglen);
1583 SvFLAGS(ERRSV) |= utf8;
1586 write_to_stderr(message, msglen);
1590 Perl_vwarn(aTHX_ pat, args);
1594 /* implements the ckWARN? macros */
1597 Perl_ckwarn(pTHX_ U32 w)
1600 /* If lexical warnings have not been set, use $^W. */
1602 return PL_dowarn & G_WARN_ON;
1604 return ckwarn_common(w);
1607 /* implements the ckWARN?_d macro */
1610 Perl_ckwarn_d(pTHX_ U32 w)
1613 /* If lexical warnings have not been set then default classes warn. */
1617 return ckwarn_common(w);
1621 S_ckwarn_common(pTHX_ U32 w)
1623 if (PL_curcop->cop_warnings == pWARN_ALL)
1626 if (PL_curcop->cop_warnings == pWARN_NONE)
1629 /* Check the assumption that at least the first slot is non-zero. */
1630 assert(unpackWARN1(w));
1632 /* Check the assumption that it is valid to stop as soon as a zero slot is
1634 if (!unpackWARN2(w)) {
1635 assert(!unpackWARN3(w));
1636 assert(!unpackWARN4(w));
1637 } else if (!unpackWARN3(w)) {
1638 assert(!unpackWARN4(w));
1641 /* Right, dealt with all the special cases, which are implemented as non-
1642 pointers, so there is a pointer to a real warnings mask. */
1644 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1646 } while (w >>= WARNshift);
1651 /* Set buffer=NULL to get a new one. */
1653 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1655 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1656 PERL_UNUSED_CONTEXT;
1657 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1660 (specialWARN(buffer) ?
1661 PerlMemShared_malloc(len_wanted) :
1662 PerlMemShared_realloc(buffer, len_wanted));
1664 Copy(bits, (buffer + 1), size, char);
1668 /* since we've already done strlen() for both nam and val
1669 * we can use that info to make things faster than
1670 * sprintf(s, "%s=%s", nam, val)
1672 #define my_setenv_format(s, nam, nlen, val, vlen) \
1673 Copy(nam, s, nlen, char); \
1675 Copy(val, s+(nlen+1), vlen, char); \
1676 *(s+(nlen+1+vlen)) = '\0'
1678 #ifdef USE_ENVIRON_ARRAY
1679 /* VMS' my_setenv() is in vms.c */
1680 #if !defined(WIN32) && !defined(NETWARE)
1682 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1686 /* only parent thread can modify process environment */
1687 if (PL_curinterp == aTHX)
1690 #ifndef PERL_USE_SAFE_PUTENV
1691 if (!PL_use_safe_putenv) {
1692 /* most putenv()s leak, so we manipulate environ directly */
1694 register const I32 len = strlen(nam);
1697 /* where does it go? */
1698 for (i = 0; environ[i]; i++) {
1699 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1703 if (environ == PL_origenviron) { /* need we copy environment? */
1709 while (environ[max])
1711 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1712 for (j=0; j<max; j++) { /* copy environment */
1713 const int len = strlen(environ[j]);
1714 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1715 Copy(environ[j], tmpenv[j], len+1, char);
1718 environ = tmpenv; /* tell exec where it is now */
1721 safesysfree(environ[i]);
1722 while (environ[i]) {
1723 environ[i] = environ[i+1];
1728 if (!environ[i]) { /* does not exist yet */
1729 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1730 environ[i+1] = NULL; /* make sure it's null terminated */
1733 safesysfree(environ[i]);
1737 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1738 /* all that work just for this */
1739 my_setenv_format(environ[i], nam, nlen, val, vlen);
1742 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1743 # if defined(HAS_UNSETENV)
1745 (void)unsetenv(nam);
1747 (void)setenv(nam, val, 1);
1749 # else /* ! HAS_UNSETENV */
1750 (void)setenv(nam, val, 1);
1751 # endif /* HAS_UNSETENV */
1753 # if defined(HAS_UNSETENV)
1755 (void)unsetenv(nam);
1757 const int nlen = strlen(nam);
1758 const int vlen = strlen(val);
1759 char * const new_env =
1760 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1761 my_setenv_format(new_env, nam, nlen, val, vlen);
1762 (void)putenv(new_env);
1764 # else /* ! HAS_UNSETENV */
1766 const int nlen = strlen(nam);
1772 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1773 /* all that work just for this */
1774 my_setenv_format(new_env, nam, nlen, val, vlen);
1775 (void)putenv(new_env);
1776 # endif /* HAS_UNSETENV */
1777 # endif /* __CYGWIN__ */
1778 #ifndef PERL_USE_SAFE_PUTENV
1784 #else /* WIN32 || NETWARE */
1787 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1790 register char *envstr;
1791 const int nlen = strlen(nam);
1798 Newx(envstr, nlen+vlen+2, char);
1799 my_setenv_format(envstr, nam, nlen, val, vlen);
1800 (void)PerlEnv_putenv(envstr);
1804 #endif /* WIN32 || NETWARE */
1806 #endif /* !VMS && !EPOC*/
1808 #ifdef UNLINK_ALL_VERSIONS
1810 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1814 PERL_ARGS_ASSERT_UNLNK;
1816 while (PerlLIO_unlink(f) >= 0)
1818 return retries ? 0 : -1;
1822 /* this is a drop-in replacement for bcopy() */
1823 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1825 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1827 char * const retval = to;
1829 PERL_ARGS_ASSERT_MY_BCOPY;
1831 if (from - to >= 0) {
1839 *(--to) = *(--from);
1845 /* this is a drop-in replacement for memset() */
1848 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1850 char * const retval = loc;
1852 PERL_ARGS_ASSERT_MY_MEMSET;
1860 /* this is a drop-in replacement for bzero() */
1861 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1863 Perl_my_bzero(register char *loc, register I32 len)
1865 char * const retval = loc;
1867 PERL_ARGS_ASSERT_MY_BZERO;
1875 /* this is a drop-in replacement for memcmp() */
1876 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1878 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1880 register const U8 *a = (const U8 *)s1;
1881 register const U8 *b = (const U8 *)s2;
1884 PERL_ARGS_ASSERT_MY_MEMCMP;
1887 if ((tmp = *a++ - *b++))
1892 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1895 /* This vsprintf replacement should generally never get used, since
1896 vsprintf was available in both System V and BSD 2.11. (There may
1897 be some cross-compilation or embedded set-ups where it is needed,
1900 If you encounter a problem in this function, it's probably a symptom
1901 that Configure failed to detect your system's vprintf() function.
1902 See the section on "item vsprintf" in the INSTALL file.
1904 This version may compile on systems with BSD-ish <stdio.h>,
1905 but probably won't on others.
1908 #ifdef USE_CHAR_VSPRINTF
1913 vsprintf(char *dest, const char *pat, void *args)
1917 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1918 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1919 FILE_cnt(&fakebuf) = 32767;
1921 /* These probably won't compile -- If you really need
1922 this, you'll have to figure out some other method. */
1923 fakebuf._ptr = dest;
1924 fakebuf._cnt = 32767;
1929 fakebuf._flag = _IOWRT|_IOSTRG;
1930 _doprnt(pat, args, &fakebuf); /* what a kludge */
1931 #if defined(STDIO_PTR_LVALUE)
1932 *(FILE_ptr(&fakebuf)++) = '\0';
1934 /* PerlIO has probably #defined away fputc, but we want it here. */
1936 # undef fputc /* XXX Should really restore it later */
1938 (void)fputc('\0', &fakebuf);
1940 #ifdef USE_CHAR_VSPRINTF
1943 return 0; /* perl doesn't use return value */
1947 #endif /* HAS_VPRINTF */
1950 #if BYTEORDER != 0x4321
1952 Perl_my_swap(pTHX_ short s)
1954 #if (BYTEORDER & 1) == 0
1957 result = ((s & 255) << 8) + ((s >> 8) & 255);
1965 Perl_my_htonl(pTHX_ long l)
1969 char c[sizeof(long)];
1972 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1973 #if BYTEORDER == 0x12345678
1976 u.c[0] = (l >> 24) & 255;
1977 u.c[1] = (l >> 16) & 255;
1978 u.c[2] = (l >> 8) & 255;
1982 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1983 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1988 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1989 u.c[o & 0xf] = (l >> s) & 255;
1997 Perl_my_ntohl(pTHX_ long l)
2001 char c[sizeof(long)];
2004 #if BYTEORDER == 0x1234
2005 u.c[0] = (l >> 24) & 255;
2006 u.c[1] = (l >> 16) & 255;
2007 u.c[2] = (l >> 8) & 255;
2011 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2012 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2019 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2020 l |= (u.c[o & 0xf] & 255) << s;
2027 #endif /* BYTEORDER != 0x4321 */
2031 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2032 * If these functions are defined,
2033 * the BYTEORDER is neither 0x1234 nor 0x4321.
2034 * However, this is not assumed.
2038 #define HTOLE(name,type) \
2040 name (register type n) \
2044 char c[sizeof(type)]; \
2047 register U32 s = 0; \
2048 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2049 u.c[i] = (n >> s) & 0xFF; \
2054 #define LETOH(name,type) \
2056 name (register type n) \
2060 char c[sizeof(type)]; \
2063 register U32 s = 0; \
2066 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2067 n |= ((type)(u.c[i] & 0xFF)) << s; \
2073 * Big-endian byte order functions.
2076 #define HTOBE(name,type) \
2078 name (register type n) \
2082 char c[sizeof(type)]; \
2085 register U32 s = 8*(sizeof(u.c)-1); \
2086 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2087 u.c[i] = (n >> s) & 0xFF; \
2092 #define BETOH(name,type) \
2094 name (register type n) \
2098 char c[sizeof(type)]; \
2101 register U32 s = 8*(sizeof(u.c)-1); \
2104 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2105 n |= ((type)(u.c[i] & 0xFF)) << s; \
2111 * If we just can't do it...
2114 #define NOT_AVAIL(name,type) \
2116 name (register type n) \
2118 Perl_croak_nocontext(#name "() not available"); \
2119 return n; /* not reached */ \
2123 #if defined(HAS_HTOVS) && !defined(htovs)
2126 #if defined(HAS_HTOVL) && !defined(htovl)
2129 #if defined(HAS_VTOHS) && !defined(vtohs)
2132 #if defined(HAS_VTOHL) && !defined(vtohl)
2136 #ifdef PERL_NEED_MY_HTOLE16
2138 HTOLE(Perl_my_htole16,U16)
2140 NOT_AVAIL(Perl_my_htole16,U16)
2143 #ifdef PERL_NEED_MY_LETOH16
2145 LETOH(Perl_my_letoh16,U16)
2147 NOT_AVAIL(Perl_my_letoh16,U16)
2150 #ifdef PERL_NEED_MY_HTOBE16
2152 HTOBE(Perl_my_htobe16,U16)
2154 NOT_AVAIL(Perl_my_htobe16,U16)
2157 #ifdef PERL_NEED_MY_BETOH16
2159 BETOH(Perl_my_betoh16,U16)
2161 NOT_AVAIL(Perl_my_betoh16,U16)
2165 #ifdef PERL_NEED_MY_HTOLE32
2167 HTOLE(Perl_my_htole32,U32)
2169 NOT_AVAIL(Perl_my_htole32,U32)
2172 #ifdef PERL_NEED_MY_LETOH32
2174 LETOH(Perl_my_letoh32,U32)
2176 NOT_AVAIL(Perl_my_letoh32,U32)
2179 #ifdef PERL_NEED_MY_HTOBE32
2181 HTOBE(Perl_my_htobe32,U32)
2183 NOT_AVAIL(Perl_my_htobe32,U32)
2186 #ifdef PERL_NEED_MY_BETOH32
2188 BETOH(Perl_my_betoh32,U32)
2190 NOT_AVAIL(Perl_my_betoh32,U32)
2194 #ifdef PERL_NEED_MY_HTOLE64
2196 HTOLE(Perl_my_htole64,U64)
2198 NOT_AVAIL(Perl_my_htole64,U64)
2201 #ifdef PERL_NEED_MY_LETOH64
2203 LETOH(Perl_my_letoh64,U64)
2205 NOT_AVAIL(Perl_my_letoh64,U64)
2208 #ifdef PERL_NEED_MY_HTOBE64
2210 HTOBE(Perl_my_htobe64,U64)
2212 NOT_AVAIL(Perl_my_htobe64,U64)
2215 #ifdef PERL_NEED_MY_BETOH64
2217 BETOH(Perl_my_betoh64,U64)
2219 NOT_AVAIL(Perl_my_betoh64,U64)
2223 #ifdef PERL_NEED_MY_HTOLES
2224 HTOLE(Perl_my_htoles,short)
2226 #ifdef PERL_NEED_MY_LETOHS
2227 LETOH(Perl_my_letohs,short)
2229 #ifdef PERL_NEED_MY_HTOBES
2230 HTOBE(Perl_my_htobes,short)
2232 #ifdef PERL_NEED_MY_BETOHS
2233 BETOH(Perl_my_betohs,short)
2236 #ifdef PERL_NEED_MY_HTOLEI
2237 HTOLE(Perl_my_htolei,int)
2239 #ifdef PERL_NEED_MY_LETOHI
2240 LETOH(Perl_my_letohi,int)
2242 #ifdef PERL_NEED_MY_HTOBEI
2243 HTOBE(Perl_my_htobei,int)
2245 #ifdef PERL_NEED_MY_BETOHI
2246 BETOH(Perl_my_betohi,int)
2249 #ifdef PERL_NEED_MY_HTOLEL
2250 HTOLE(Perl_my_htolel,long)
2252 #ifdef PERL_NEED_MY_LETOHL
2253 LETOH(Perl_my_letohl,long)
2255 #ifdef PERL_NEED_MY_HTOBEL
2256 HTOBE(Perl_my_htobel,long)
2258 #ifdef PERL_NEED_MY_BETOHL
2259 BETOH(Perl_my_betohl,long)
2263 Perl_my_swabn(void *ptr, int n)
2265 register char *s = (char *)ptr;
2266 register char *e = s + (n-1);
2269 PERL_ARGS_ASSERT_MY_SWABN;
2271 for (n /= 2; n > 0; s++, e--, n--) {
2279 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2281 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2284 register I32 This, that;
2290 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2292 PERL_FLUSHALL_FOR_CHILD;
2293 This = (*mode == 'w');
2297 taint_proper("Insecure %s%s", "EXEC");
2299 if (PerlProc_pipe(p) < 0)
2301 /* Try for another pipe pair for error return */
2302 if (PerlProc_pipe(pp) >= 0)
2304 while ((pid = PerlProc_fork()) < 0) {
2305 if (errno != EAGAIN) {
2306 PerlLIO_close(p[This]);
2307 PerlLIO_close(p[that]);
2309 PerlLIO_close(pp[0]);
2310 PerlLIO_close(pp[1]);
2314 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2323 /* Close parent's end of error status pipe (if any) */
2325 PerlLIO_close(pp[0]);
2326 #if defined(HAS_FCNTL) && defined(F_SETFD)
2327 /* Close error pipe automatically if exec works */
2328 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2331 /* Now dup our end of _the_ pipe to right position */
2332 if (p[THIS] != (*mode == 'r')) {
2333 PerlLIO_dup2(p[THIS], *mode == 'r');
2334 PerlLIO_close(p[THIS]);
2335 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2336 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2339 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2340 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2341 /* No automatic close - do it by hand */
2348 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2354 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2360 do_execfree(); /* free any memory malloced by child on fork */
2362 PerlLIO_close(pp[1]);
2363 /* Keep the lower of the two fd numbers */
2364 if (p[that] < p[This]) {
2365 PerlLIO_dup2(p[This], p[that]);
2366 PerlLIO_close(p[This]);
2370 PerlLIO_close(p[that]); /* close child's end of pipe */
2372 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2373 SvUPGRADE(sv,SVt_IV);
2375 PL_forkprocess = pid;
2376 /* If we managed to get status pipe check for exec fail */
2377 if (did_pipes && pid > 0) {
2382 while (n < sizeof(int)) {
2383 n1 = PerlLIO_read(pp[0],
2384 (void*)(((char*)&errkid)+n),
2390 PerlLIO_close(pp[0]);
2392 if (n) { /* Error */
2394 PerlLIO_close(p[This]);
2395 if (n != sizeof(int))
2396 Perl_croak(aTHX_ "panic: kid popen errno read");
2398 pid2 = wait4pid(pid, &status, 0);
2399 } while (pid2 == -1 && errno == EINTR);
2400 errno = errkid; /* Propagate errno from kid */
2405 PerlLIO_close(pp[0]);
2406 return PerlIO_fdopen(p[This], mode);
2408 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2409 return my_syspopen4(aTHX_ NULL, mode, n, args);
2411 Perl_croak(aTHX_ "List form of piped open not implemented");
2412 return (PerlIO *) NULL;
2417 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2418 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2420 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2424 register I32 This, that;
2427 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2431 PERL_ARGS_ASSERT_MY_POPEN;
2433 PERL_FLUSHALL_FOR_CHILD;
2436 return my_syspopen(aTHX_ cmd,mode);
2439 This = (*mode == 'w');
2441 if (doexec && PL_tainting) {
2443 taint_proper("Insecure %s%s", "EXEC");
2445 if (PerlProc_pipe(p) < 0)
2447 if (doexec && PerlProc_pipe(pp) >= 0)
2449 while ((pid = PerlProc_fork()) < 0) {
2450 if (errno != EAGAIN) {
2451 PerlLIO_close(p[This]);
2452 PerlLIO_close(p[that]);
2454 PerlLIO_close(pp[0]);
2455 PerlLIO_close(pp[1]);
2458 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2461 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2472 PerlLIO_close(pp[0]);
2473 #if defined(HAS_FCNTL) && defined(F_SETFD)
2474 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2477 if (p[THIS] != (*mode == 'r')) {
2478 PerlLIO_dup2(p[THIS], *mode == 'r');
2479 PerlLIO_close(p[THIS]);
2480 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2481 PerlLIO_close(p[THAT]);
2484 PerlLIO_close(p[THAT]);
2487 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2494 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2499 /* may or may not use the shell */
2500 do_exec3(cmd, pp[1], did_pipes);
2503 #endif /* defined OS2 */
2505 #ifdef PERLIO_USING_CRLF
2506 /* Since we circumvent IO layers when we manipulate low-level
2507 filedescriptors directly, need to manually switch to the
2508 default, binary, low-level mode; see PerlIOBuf_open(). */
2509 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2512 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2513 SvREADONLY_off(GvSV(tmpgv));
2514 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2515 SvREADONLY_on(GvSV(tmpgv));
2517 #ifdef THREADS_HAVE_PIDS
2518 PL_ppid = (IV)getppid();
2521 #ifdef PERL_USES_PL_PIDSTATUS
2522 hv_clear(PL_pidstatus); /* we have no children */
2528 do_execfree(); /* free any memory malloced by child on vfork */
2530 PerlLIO_close(pp[1]);
2531 if (p[that] < p[This]) {
2532 PerlLIO_dup2(p[This], p[that]);
2533 PerlLIO_close(p[This]);
2537 PerlLIO_close(p[that]);
2539 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2540 SvUPGRADE(sv,SVt_IV);
2542 PL_forkprocess = pid;
2543 if (did_pipes && pid > 0) {
2548 while (n < sizeof(int)) {
2549 n1 = PerlLIO_read(pp[0],
2550 (void*)(((char*)&errkid)+n),
2556 PerlLIO_close(pp[0]);
2558 if (n) { /* Error */
2560 PerlLIO_close(p[This]);
2561 if (n != sizeof(int))
2562 Perl_croak(aTHX_ "panic: kid popen errno read");
2564 pid2 = wait4pid(pid, &status, 0);
2565 } while (pid2 == -1 && errno == EINTR);
2566 errno = errkid; /* Propagate errno from kid */
2571 PerlLIO_close(pp[0]);
2572 return PerlIO_fdopen(p[This], mode);
2575 #if defined(atarist) || defined(EPOC)
2578 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2580 PERL_ARGS_ASSERT_MY_POPEN;
2581 PERL_FLUSHALL_FOR_CHILD;
2582 /* Call system's popen() to get a FILE *, then import it.
2583 used 0 for 2nd parameter to PerlIO_importFILE;
2586 return PerlIO_importFILE(popen(cmd, mode), 0);
2590 FILE *djgpp_popen();
2592 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2594 PERL_FLUSHALL_FOR_CHILD;
2595 /* Call system's popen() to get a FILE *, then import it.
2596 used 0 for 2nd parameter to PerlIO_importFILE;
2599 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2602 #if defined(__LIBCATAMOUNT__)
2604 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2612 #endif /* !DOSISH */
2614 /* this is called in parent before the fork() */
2616 Perl_atfork_lock(void)
2619 #if defined(USE_ITHREADS)
2620 /* locks must be held in locking order (if any) */
2622 MUTEX_LOCK(&PL_malloc_mutex);
2628 /* this is called in both parent and child after the fork() */
2630 Perl_atfork_unlock(void)
2633 #if defined(USE_ITHREADS)
2634 /* locks must be released in same order as in atfork_lock() */
2636 MUTEX_UNLOCK(&PL_malloc_mutex);
2645 #if defined(HAS_FORK)
2647 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2652 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2653 * handlers elsewhere in the code */
2658 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2659 Perl_croak_nocontext("fork() not available");
2661 #endif /* HAS_FORK */
2666 Perl_dump_fds(pTHX_ const char *const s)
2671 PERL_ARGS_ASSERT_DUMP_FDS;
2673 PerlIO_printf(Perl_debug_log,"%s", s);
2674 for (fd = 0; fd < 32; fd++) {
2675 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2676 PerlIO_printf(Perl_debug_log," %d",fd);
2678 PerlIO_printf(Perl_debug_log,"\n");
2681 #endif /* DUMP_FDS */
2685 dup2(int oldfd, int newfd)
2687 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2690 PerlLIO_close(newfd);
2691 return fcntl(oldfd, F_DUPFD, newfd);
2693 #define DUP2_MAX_FDS 256
2694 int fdtmp[DUP2_MAX_FDS];
2700 PerlLIO_close(newfd);
2701 /* good enough for low fd's... */
2702 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2703 if (fdx >= DUP2_MAX_FDS) {
2711 PerlLIO_close(fdtmp[--fdx]);
2718 #ifdef HAS_SIGACTION
2721 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2724 struct sigaction act, oact;
2727 /* only "parent" interpreter can diddle signals */
2728 if (PL_curinterp != aTHX)
2729 return (Sighandler_t) SIG_ERR;
2732 act.sa_handler = (void(*)(int))handler;
2733 sigemptyset(&act.sa_mask);
2736 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2737 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2739 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2740 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2741 act.sa_flags |= SA_NOCLDWAIT;
2743 if (sigaction(signo, &act, &oact) == -1)
2744 return (Sighandler_t) SIG_ERR;
2746 return (Sighandler_t) oact.sa_handler;
2750 Perl_rsignal_state(pTHX_ int signo)
2752 struct sigaction oact;
2753 PERL_UNUSED_CONTEXT;
2755 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2756 return (Sighandler_t) SIG_ERR;
2758 return (Sighandler_t) oact.sa_handler;
2762 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2765 struct sigaction act;
2767 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2770 /* only "parent" interpreter can diddle signals */
2771 if (PL_curinterp != aTHX)
2775 act.sa_handler = (void(*)(int))handler;
2776 sigemptyset(&act.sa_mask);
2779 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2780 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2782 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2783 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2784 act.sa_flags |= SA_NOCLDWAIT;
2786 return sigaction(signo, &act, save);
2790 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2794 /* only "parent" interpreter can diddle signals */
2795 if (PL_curinterp != aTHX)
2799 return sigaction(signo, save, (struct sigaction *)NULL);
2802 #else /* !HAS_SIGACTION */
2805 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2807 #if defined(USE_ITHREADS) && !defined(WIN32)
2808 /* only "parent" interpreter can diddle signals */
2809 if (PL_curinterp != aTHX)
2810 return (Sighandler_t) SIG_ERR;
2813 return PerlProc_signal(signo, handler);
2824 Perl_rsignal_state(pTHX_ int signo)
2827 Sighandler_t oldsig;
2829 #if defined(USE_ITHREADS) && !defined(WIN32)
2830 /* only "parent" interpreter can diddle signals */
2831 if (PL_curinterp != aTHX)
2832 return (Sighandler_t) SIG_ERR;
2836 oldsig = PerlProc_signal(signo, sig_trap);
2837 PerlProc_signal(signo, oldsig);
2839 PerlProc_kill(PerlProc_getpid(), signo);
2844 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2846 #if defined(USE_ITHREADS) && !defined(WIN32)
2847 /* only "parent" interpreter can diddle signals */
2848 if (PL_curinterp != aTHX)
2851 *save = PerlProc_signal(signo, handler);
2852 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2856 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2858 #if defined(USE_ITHREADS) && !defined(WIN32)
2859 /* only "parent" interpreter can diddle signals */
2860 if (PL_curinterp != aTHX)
2863 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2866 #endif /* !HAS_SIGACTION */
2867 #endif /* !PERL_MICRO */
2869 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2870 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2872 Perl_my_pclose(pTHX_ PerlIO *ptr)
2875 Sigsave_t hstat, istat, qstat;
2883 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2884 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2886 *svp = &PL_sv_undef;
2888 if (pid == -1) { /* Opened by popen. */
2889 return my_syspclose(ptr);
2892 close_failed = (PerlIO_close(ptr) == EOF);
2895 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2898 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2899 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2900 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2903 pid2 = wait4pid(pid, &status, 0);
2904 } while (pid2 == -1 && errno == EINTR);
2906 rsignal_restore(SIGHUP, &hstat);
2907 rsignal_restore(SIGINT, &istat);
2908 rsignal_restore(SIGQUIT, &qstat);
2914 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2917 #if defined(__LIBCATAMOUNT__)
2919 Perl_my_pclose(pTHX_ PerlIO *ptr)
2924 #endif /* !DOSISH */
2926 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2928 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2932 PERL_ARGS_ASSERT_WAIT4PID;
2935 #ifdef PERL_USES_PL_PIDSTATUS
2938 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2939 pid, rather than a string form. */
2940 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2941 if (svp && *svp != &PL_sv_undef) {
2942 *statusp = SvIVX(*svp);
2943 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2951 hv_iterinit(PL_pidstatus);
2952 if ((entry = hv_iternext(PL_pidstatus))) {
2953 SV * const sv = hv_iterval(PL_pidstatus,entry);
2955 const char * const spid = hv_iterkey(entry,&len);
2957 assert (len == sizeof(Pid_t));
2958 memcpy((char *)&pid, spid, len);
2959 *statusp = SvIVX(sv);
2960 /* The hash iterator is currently on this entry, so simply
2961 calling hv_delete would trigger the lazy delete, which on
2962 aggregate does more work, beacuse next call to hv_iterinit()
2963 would spot the flag, and have to call the delete routine,
2964 while in the meantime any new entries can't re-use that
2966 hv_iterinit(PL_pidstatus);
2967 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2974 # ifdef HAS_WAITPID_RUNTIME
2975 if (!HAS_WAITPID_RUNTIME)
2978 result = PerlProc_waitpid(pid,statusp,flags);
2981 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2982 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2985 #ifdef PERL_USES_PL_PIDSTATUS
2986 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2991 Perl_croak(aTHX_ "Can't do waitpid with flags");
2993 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2994 pidgone(result,*statusp);
3000 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3003 if (result < 0 && errno == EINTR) {
3005 errno = EINTR; /* reset in case a signal handler changed $! */
3009 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3011 #ifdef PERL_USES_PL_PIDSTATUS
3013 S_pidgone(pTHX_ Pid_t pid, int status)
3017 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3018 SvUPGRADE(sv,SVt_IV);
3019 SvIV_set(sv, status);
3024 #if defined(atarist) || defined(OS2) || defined(EPOC)
3027 int /* Cannot prototype with I32
3029 my_syspclose(PerlIO *ptr)
3032 Perl_my_pclose(pTHX_ PerlIO *ptr)
3035 /* Needs work for PerlIO ! */
3036 FILE * const f = PerlIO_findFILE(ptr);
3037 const I32 result = pclose(f);
3038 PerlIO_releaseFILE(ptr,f);
3046 Perl_my_pclose(pTHX_ PerlIO *ptr)
3048 /* Needs work for PerlIO ! */
3049 FILE * const f = PerlIO_findFILE(ptr);
3050 I32 result = djgpp_pclose(f);
3051 result = (result << 8) & 0xff00;
3052 PerlIO_releaseFILE(ptr,f);
3057 #define PERL_REPEATCPY_LINEAR 4
3059 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3061 PERL_ARGS_ASSERT_REPEATCPY;
3064 memset(to, *from, count);
3066 register char *p = to;
3067 I32 items, linear, half;
3069 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3070 for (items = 0; items < linear; ++items) {
3071 register const char *q = from;
3073 for (todo = len; todo > 0; todo--)
3078 while (items <= half) {
3079 I32 size = items * len;
3080 memcpy(p, to, size);
3086 memcpy(p, to, (count - items) * len);
3092 Perl_same_dirent(pTHX_ const char *a, const char *b)
3094 char *fa = strrchr(a,'/');
3095 char *fb = strrchr(b,'/');
3098 SV * const tmpsv = sv_newmortal();
3100 PERL_ARGS_ASSERT_SAME_DIRENT;
3113 sv_setpvs(tmpsv, ".");
3115 sv_setpvn(tmpsv, a, fa - a);
3116 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3119 sv_setpvs(tmpsv, ".");
3121 sv_setpvn(tmpsv, b, fb - b);
3122 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3124 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3125 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3127 #endif /* !HAS_RENAME */
3130 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3131 const char *const *const search_ext, I32 flags)
3134 const char *xfound = NULL;
3135 char *xfailed = NULL;
3136 char tmpbuf[MAXPATHLEN];
3141 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3142 # define SEARCH_EXTS ".bat", ".cmd", NULL
3143 # define MAX_EXT_LEN 4
3146 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3147 # define MAX_EXT_LEN 4
3150 # define SEARCH_EXTS ".pl", ".com", NULL
3151 # define MAX_EXT_LEN 4
3153 /* additional extensions to try in each dir if scriptname not found */
3155 static const char *const exts[] = { SEARCH_EXTS };
3156 const char *const *const ext = search_ext ? search_ext : exts;
3157 int extidx = 0, i = 0;
3158 const char *curext = NULL;
3160 PERL_UNUSED_ARG(search_ext);
3161 # define MAX_EXT_LEN 0
3164 PERL_ARGS_ASSERT_FIND_SCRIPT;
3167 * If dosearch is true and if scriptname does not contain path
3168 * delimiters, search the PATH for scriptname.
3170 * If SEARCH_EXTS is also defined, will look for each
3171 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3172 * while searching the PATH.
3174 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3175 * proceeds as follows:
3176 * If DOSISH or VMSISH:
3177 * + look for ./scriptname{,.foo,.bar}
3178 * + search the PATH for scriptname{,.foo,.bar}
3181 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3182 * this will not look in '.' if it's not in the PATH)
3187 # ifdef ALWAYS_DEFTYPES
3188 len = strlen(scriptname);
3189 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3190 int idx = 0, deftypes = 1;
3193 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3196 int idx = 0, deftypes = 1;
3199 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3201 /* The first time through, just add SEARCH_EXTS to whatever we
3202 * already have, so we can check for default file types. */
3204 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3210 if ((strlen(tmpbuf) + strlen(scriptname)
3211 + MAX_EXT_LEN) >= sizeof tmpbuf)
3212 continue; /* don't search dir with too-long name */
3213 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3217 if (strEQ(scriptname, "-"))
3219 if (dosearch) { /* Look in '.' first. */
3220 const char *cur = scriptname;
3222 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3224 if (strEQ(ext[i++],curext)) {
3225 extidx = -1; /* already has an ext */
3230 DEBUG_p(PerlIO_printf(Perl_debug_log,
3231 "Looking for %s\n",cur));
3232 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3233 && !S_ISDIR(PL_statbuf.st_mode)) {
3241 if (cur == scriptname) {
3242 len = strlen(scriptname);
3243 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3245 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3248 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3249 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3254 if (dosearch && !strchr(scriptname, '/')
3256 && !strchr(scriptname, '\\')
3258 && (s = PerlEnv_getenv("PATH")))
3262 bufend = s + strlen(s);
3263 while (s < bufend) {
3264 #if defined(atarist) || defined(DOSISH)
3269 && *s != ';'; len++, s++) {
3270 if (len < sizeof tmpbuf)
3273 if (len < sizeof tmpbuf)
3275 #else /* ! (atarist || DOSISH) */
3276 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3279 #endif /* ! (atarist || DOSISH) */
3282 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3283 continue; /* don't search dir with too-long name */
3285 # if defined(atarist) || defined(DOSISH)
3286 && tmpbuf[len - 1] != '/'
3287 && tmpbuf[len - 1] != '\\'
3290 tmpbuf[len++] = '/';
3291 if (len == 2 && tmpbuf[0] == '.')
3293 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3297 len = strlen(tmpbuf);
3298 if (extidx > 0) /* reset after previous loop */
3302 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3303 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3304 if (S_ISDIR(PL_statbuf.st_mode)) {
3308 } while ( retval < 0 /* not there */
3309 && extidx>=0 && ext[extidx] /* try an extension? */
3310 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3315 if (S_ISREG(PL_statbuf.st_mode)
3316 && cando(S_IRUSR,TRUE,&PL_statbuf)
3317 #if !defined(DOSISH)
3318 && cando(S_IXUSR,TRUE,&PL_statbuf)
3322 xfound = tmpbuf; /* bingo! */
3326 xfailed = savepv(tmpbuf);
3329 if (!xfound && !seen_dot && !xfailed &&
3330 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3331 || S_ISDIR(PL_statbuf.st_mode)))
3333 seen_dot = 1; /* Disable message. */
3335 if (flags & 1) { /* do or die? */
3336 Perl_croak(aTHX_ "Can't %s %s%s%s",
3337 (xfailed ? "execute" : "find"),
3338 (xfailed ? xfailed : scriptname),
3339 (xfailed ? "" : " on PATH"),
3340 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3345 scriptname = xfound;
3347 return (scriptname ? savepv(scriptname) : NULL);
3350 #ifndef PERL_GET_CONTEXT_DEFINED
3353 Perl_get_context(void)
3356 #if defined(USE_ITHREADS)
3357 # ifdef OLD_PTHREADS_API
3359 if (pthread_getspecific(PL_thr_key, &t))
3360 Perl_croak_nocontext("panic: pthread_getspecific");
3363 # ifdef I_MACH_CTHREADS
3364 return (void*)cthread_data(cthread_self());
3366 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3375 Perl_set_context(void *t)
3378 PERL_ARGS_ASSERT_SET_CONTEXT;
3379 #if defined(USE_ITHREADS)
3380 # ifdef I_MACH_CTHREADS
3381 cthread_set_data(cthread_self(), t);
3383 if (pthread_setspecific(PL_thr_key, t))
3384 Perl_croak_nocontext("panic: pthread_setspecific");
3391 #endif /* !PERL_GET_CONTEXT_DEFINED */
3393 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3402 Perl_get_op_names(pTHX)
3404 PERL_UNUSED_CONTEXT;
3405 return (char **)PL_op_name;
3409 Perl_get_op_descs(pTHX)
3411 PERL_UNUSED_CONTEXT;
3412 return (char **)PL_op_desc;
3416 Perl_get_no_modify(pTHX)
3418 PERL_UNUSED_CONTEXT;
3419 return PL_no_modify;
3423 Perl_get_opargs(pTHX)
3425 PERL_UNUSED_CONTEXT;
3426 return (U32 *)PL_opargs;
3430 Perl_get_ppaddr(pTHX)
3433 PERL_UNUSED_CONTEXT;
3434 return (PPADDR_t*)PL_ppaddr;
3437 #ifndef HAS_GETENV_LEN
3439 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3441 char * const env_trans = PerlEnv_getenv(env_elem);
3442 PERL_UNUSED_CONTEXT;
3443 PERL_ARGS_ASSERT_GETENV_LEN;
3445 *len = strlen(env_trans);
3452 Perl_get_vtbl(pTHX_ int vtbl_id)
3454 const MGVTBL* result;
3455 PERL_UNUSED_CONTEXT;
3459 result = &PL_vtbl_sv;
3462 result = &PL_vtbl_env;
3464 case want_vtbl_envelem:
3465 result = &PL_vtbl_envelem;
3468 result = &PL_vtbl_sig;
3470 case want_vtbl_sigelem:
3471 result = &PL_vtbl_sigelem;
3473 case want_vtbl_pack:
3474 result = &PL_vtbl_pack;
3476 case want_vtbl_packelem:
3477 result = &PL_vtbl_packelem;
3479 case want_vtbl_dbline:
3480 result = &PL_vtbl_dbline;
3483 result = &PL_vtbl_isa;
3485 case want_vtbl_isaelem:
3486 result = &PL_vtbl_isaelem;
3488 case want_vtbl_arylen:
3489 result = &PL_vtbl_arylen;
3491 case want_vtbl_mglob:
3492 result = &PL_vtbl_mglob;
3494 case want_vtbl_nkeys:
3495 result = &PL_vtbl_nkeys;
3497 case want_vtbl_taint:
3498 result = &PL_vtbl_taint;
3500 case want_vtbl_substr:
3501 result = &PL_vtbl_substr;
3504 result = &PL_vtbl_vec;
3507 result = &PL_vtbl_pos;
3510 result = &PL_vtbl_bm;
3513 result = &PL_vtbl_fm;
3515 case want_vtbl_uvar:
3516 result = &PL_vtbl_uvar;
3518 case want_vtbl_defelem:
3519 result = &PL_vtbl_defelem;
3521 case want_vtbl_regexp:
3522 result = &PL_vtbl_regexp;
3524 case want_vtbl_regdata:
3525 result = &PL_vtbl_regdata;
3527 case want_vtbl_regdatum:
3528 result = &PL_vtbl_regdatum;
3530 #ifdef USE_LOCALE_COLLATE
3531 case want_vtbl_collxfrm:
3532 result = &PL_vtbl_collxfrm;
3535 case want_vtbl_amagic:
3536 result = &PL_vtbl_amagic;
3538 case want_vtbl_amagicelem:
3539 result = &PL_vtbl_amagicelem;
3541 case want_vtbl_backref:
3542 result = &PL_vtbl_backref;
3544 case want_vtbl_utf8:
3545 result = &PL_vtbl_utf8;
3551 return (MGVTBL*)result;
3555 Perl_my_fflush_all(pTHX)
3557 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3558 return PerlIO_flush(NULL);
3560 # if defined(HAS__FWALK)
3561 extern int fflush(FILE *);
3562 /* undocumented, unprototyped, but very useful BSDism */
3563 extern void _fwalk(int (*)(FILE *));
3567 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3569 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3570 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3572 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3573 open_max = sysconf(_SC_OPEN_MAX);
3576 open_max = FOPEN_MAX;
3579 open_max = OPEN_MAX;
3590 for (i = 0; i < open_max; i++)
3591 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3592 STDIO_STREAM_ARRAY[i]._file < open_max &&
3593 STDIO_STREAM_ARRAY[i]._flag)
3594 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3598 SETERRNO(EBADF,RMS_IFI);
3605 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3607 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3609 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3610 if (ckWARN(WARN_IO)) {
3611 const char * const direction =
3612 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3614 Perl_warner(aTHX_ packWARN(WARN_IO),
3615 "Filehandle %s opened only for %sput",
3618 Perl_warner(aTHX_ packWARN(WARN_IO),
3619 "Filehandle opened only for %sput", direction);
3626 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3628 warn_type = WARN_CLOSED;
3632 warn_type = WARN_UNOPENED;
3635 if (ckWARN(warn_type)) {
3636 const char * const pars =
3637 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3638 const char * const func =
3640 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3641 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3642 op < 0 ? "" : /* handle phoney cases */
3644 const char * const type =
3646 (OP_IS_SOCKET(op) ||
3647 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3648 "socket" : "filehandle");
3649 if (name && *name) {
3650 Perl_warner(aTHX_ packWARN(warn_type),
3651 "%s%s on %s %s %s", func, pars, vile, type, name);
3652 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3654 aTHX_ packWARN(warn_type),
3655 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3660 Perl_warner(aTHX_ packWARN(warn_type),
3661 "%s%s on %s %s", func, pars, vile, type);
3662 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3664 aTHX_ packWARN(warn_type),
3665 "\t(Are you trying to call %s%s on dirhandle?)\n",
3674 /* in ASCII order, not that it matters */
3675 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3678 Perl_ebcdic_control(pTHX_ int ch)
3686 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3687 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3690 if (ctlp == controllablechars)
3691 return('\177'); /* DEL */
3693 return((unsigned char)(ctlp - controllablechars - 1));
3694 } else { /* Want uncontrol */
3695 if (ch == '\177' || ch == -1)
3697 else if (ch == '\157')
3699 else if (ch == '\174')
3701 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3703 else if (ch == '\155')
3705 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3706 return(controllablechars[ch+1]);
3708 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3713 /* To workaround core dumps from the uninitialised tm_zone we get the
3714 * system to give us a reasonable struct to copy. This fix means that
3715 * strftime uses the tm_zone and tm_gmtoff values returned by
3716 * localtime(time()). That should give the desired result most of the
3717 * time. But probably not always!
3719 * This does not address tzname aspects of NETaa14816.
3724 # ifndef STRUCT_TM_HASZONE
3725 # define STRUCT_TM_HASZONE
3729 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3730 # ifndef HAS_TM_TM_ZONE
3731 # define HAS_TM_TM_ZONE
3736 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3738 #ifdef HAS_TM_TM_ZONE
3740 const struct tm* my_tm;
3741 PERL_ARGS_ASSERT_INIT_TM;
3743 my_tm = localtime(&now);
3745 Copy(my_tm, ptm, 1, struct tm);
3747 PERL_ARGS_ASSERT_INIT_TM;
3748 PERL_UNUSED_ARG(ptm);
3753 * mini_mktime - normalise struct tm values without the localtime()
3754 * semantics (and overhead) of mktime().
3757 Perl_mini_mktime(pTHX_ struct tm *ptm)
3761 int month, mday, year, jday;
3762 int odd_cent, odd_year;
3763 PERL_UNUSED_CONTEXT;
3765 PERL_ARGS_ASSERT_MINI_MKTIME;
3767 #define DAYS_PER_YEAR 365
3768 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3769 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3770 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3771 #define SECS_PER_HOUR (60*60)
3772 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3773 /* parentheses deliberately absent on these two, otherwise they don't work */
3774 #define MONTH_TO_DAYS 153/5
3775 #define DAYS_TO_MONTH 5/153
3776 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3777 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3778 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3779 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3782 * Year/day algorithm notes:
3784 * With a suitable offset for numeric value of the month, one can find
3785 * an offset into the year by considering months to have 30.6 (153/5) days,
3786 * using integer arithmetic (i.e., with truncation). To avoid too much
3787 * messing about with leap days, we consider January and February to be
3788 * the 13th and 14th month of the previous year. After that transformation,
3789 * we need the month index we use to be high by 1 from 'normal human' usage,
3790 * so the month index values we use run from 4 through 15.
3792 * Given that, and the rules for the Gregorian calendar (leap years are those
3793 * divisible by 4 unless also divisible by 100, when they must be divisible
3794 * by 400 instead), we can simply calculate the number of days since some
3795 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3796 * the days we derive from our month index, and adding in the day of the
3797 * month. The value used here is not adjusted for the actual origin which
3798 * it normally would use (1 January A.D. 1), since we're not exposing it.
3799 * We're only building the value so we can turn around and get the
3800 * normalised values for the year, month, day-of-month, and day-of-year.
3802 * For going backward, we need to bias the value we're using so that we find
3803 * the right year value. (Basically, we don't want the contribution of
3804 * March 1st to the number to apply while deriving the year). Having done
3805 * that, we 'count up' the contribution to the year number by accounting for
3806 * full quadracenturies (400-year periods) with their extra leap days, plus
3807 * the contribution from full centuries (to avoid counting in the lost leap
3808 * days), plus the contribution from full quad-years (to count in the normal
3809 * leap days), plus the leftover contribution from any non-leap years.
3810 * At this point, if we were working with an actual leap day, we'll have 0
3811 * days left over. This is also true for March 1st, however. So, we have
3812 * to special-case that result, and (earlier) keep track of the 'odd'
3813 * century and year contributions. If we got 4 extra centuries in a qcent,
3814 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3815 * Otherwise, we add back in the earlier bias we removed (the 123 from
3816 * figuring in March 1st), find the month index (integer division by 30.6),
3817 * and the remainder is the day-of-month. We then have to convert back to
3818 * 'real' months (including fixing January and February from being 14/15 in
3819 * the previous year to being in the proper year). After that, to get
3820 * tm_yday, we work with the normalised year and get a new yearday value for
3821 * January 1st, which we subtract from the yearday value we had earlier,
3822 * representing the date we've re-built. This is done from January 1
3823 * because tm_yday is 0-origin.
3825 * Since POSIX time routines are only guaranteed to work for times since the
3826 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3827 * applies Gregorian calendar rules even to dates before the 16th century
3828 * doesn't bother me. Besides, you'd need cultural context for a given
3829 * date to know whether it was Julian or Gregorian calendar, and that's
3830 * outside the scope for this routine. Since we convert back based on the
3831 * same rules we used to build the yearday, you'll only get strange results
3832 * for input which needed normalising, or for the 'odd' century years which
3833 * were leap years in the Julian calander but not in the Gregorian one.
3834 * I can live with that.
3836 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3837 * that's still outside the scope for POSIX time manipulation, so I don't
3841 year = 1900 + ptm->tm_year;
3842 month = ptm->tm_mon;
3843 mday = ptm->tm_mday;
3844 /* allow given yday with no month & mday to dominate the result */
3845 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3848 jday = 1 + ptm->tm_yday;
3857 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3858 yearday += month*MONTH_TO_DAYS + mday + jday;
3860 * Note that we don't know when leap-seconds were or will be,
3861 * so we have to trust the user if we get something which looks
3862 * like a sensible leap-second. Wild values for seconds will
3863 * be rationalised, however.
3865 if ((unsigned) ptm->tm_sec <= 60) {
3872 secs += 60 * ptm->tm_min;
3873 secs += SECS_PER_HOUR * ptm->tm_hour;
3875 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3876 /* got negative remainder, but need positive time */
3877 /* back off an extra day to compensate */
3878 yearday += (secs/SECS_PER_DAY)-1;
3879 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3882 yearday += (secs/SECS_PER_DAY);
3883 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3886 else if (secs >= SECS_PER_DAY) {
3887 yearday += (secs/SECS_PER_DAY);
3888 secs %= SECS_PER_DAY;
3890 ptm->tm_hour = secs/SECS_PER_HOUR;
3891 secs %= SECS_PER_HOUR;
3892 ptm->tm_min = secs/60;
3894 ptm->tm_sec += secs;
3895 /* done with time of day effects */
3897 * The algorithm for yearday has (so far) left it high by 428.
3898 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3899 * bias it by 123 while trying to figure out what year it
3900 * really represents. Even with this tweak, the reverse
3901 * translation fails for years before A.D. 0001.
3902 * It would still fail for Feb 29, but we catch that one below.
3904 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3905 yearday -= YEAR_ADJUST;
3906 year = (yearday / DAYS_PER_QCENT) * 400;
3907 yearday %= DAYS_PER_QCENT;
3908 odd_cent = yearday / DAYS_PER_CENT;
3909 year += odd_cent * 100;
3910 yearday %= DAYS_PER_CENT;
3911 year += (yearday / DAYS_PER_QYEAR) * 4;
3912 yearday %= DAYS_PER_QYEAR;
3913 odd_year = yearday / DAYS_PER_YEAR;
3915 yearday %= DAYS_PER_YEAR;
3916 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3921 yearday += YEAR_ADJUST; /* recover March 1st crock */
3922 month = yearday*DAYS_TO_MONTH;
3923 yearday -= month*MONTH_TO_DAYS;
3924 /* recover other leap-year adjustment */
3933 ptm->tm_year = year - 1900;
3935 ptm->tm_mday = yearday;
3936 ptm->tm_mon = month;
3940 ptm->tm_mon = month - 1;
3942 /* re-build yearday based on Jan 1 to get tm_yday */
3944 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3945 yearday += 14*MONTH_TO_DAYS + 1;
3946 ptm->tm_yday = jday - yearday;
3947 /* fix tm_wday if not overridden by caller */
3948 if ((unsigned)ptm->tm_wday > 6)
3949 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3953 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)
3961 PERL_ARGS_ASSERT_MY_STRFTIME;
3963 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3966 mytm.tm_hour = hour;
3967 mytm.tm_mday = mday;
3969 mytm.tm_year = year;
3970 mytm.tm_wday = wday;
3971 mytm.tm_yday = yday;
3972 mytm.tm_isdst = isdst;
3974 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3975 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3980 #ifdef HAS_TM_TM_GMTOFF
3981 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3983 #ifdef HAS_TM_TM_ZONE
3984 mytm.tm_zone = mytm2.tm_zone;
3989 Newx(buf, buflen, char);
3990 len = strftime(buf, buflen, fmt, &mytm);
3992 ** The following is needed to handle to the situation where
3993 ** tmpbuf overflows. Basically we want to allocate a buffer
3994 ** and try repeatedly. The reason why it is so complicated
3995 ** is that getting a return value of 0 from strftime can indicate
3996 ** one of the following:
3997 ** 1. buffer overflowed,
3998 ** 2. illegal conversion specifier, or
3999 ** 3. the format string specifies nothing to be returned(not
4000 ** an error). This could be because format is an empty string
4001 ** or it specifies %p that yields an empty string in some locale.
4002 ** If there is a better way to make it portable, go ahead by
4005 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4008 /* Possibly buf overflowed - try again with a bigger buf */
4009 const int fmtlen = strlen(fmt);
4010 int bufsize = fmtlen + buflen;
4012 Newx(buf, bufsize, char);
4014 buflen = strftime(buf, bufsize, fmt, &mytm);
4015 if (buflen > 0 && buflen < bufsize)
4017 /* heuristic to prevent out-of-memory errors */
4018 if (bufsize > 100*fmtlen) {
4024 Renew(buf, bufsize, char);
4029 Perl_croak(aTHX_ "panic: no strftime");
4035 #define SV_CWD_RETURN_UNDEF \
4036 sv_setsv(sv, &PL_sv_undef); \
4039 #define SV_CWD_ISDOT(dp) \
4040 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4041 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4044 =head1 Miscellaneous Functions
4046 =for apidoc getcwd_sv
4048 Fill the sv with current working directory
4053 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4054 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4055 * getcwd(3) if available
4056 * Comments from the orignal:
4057 * This is a faster version of getcwd. It's also more dangerous
4058 * because you might chdir out of a directory that you can't chdir
4062 Perl_getcwd_sv(pTHX_ register SV *sv)
4066 #ifndef INCOMPLETE_TAINTS
4070 PERL_ARGS_ASSERT_GETCWD_SV;
4074 char buf[MAXPATHLEN];
4076 /* Some getcwd()s automatically allocate a buffer of the given
4077 * size from the heap if they are given a NULL buffer pointer.
4078 * The problem is that this behaviour is not portable. */
4079 if (getcwd(buf, sizeof(buf) - 1)) {
4084 sv_setsv(sv, &PL_sv_undef);
4092 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4096 SvUPGRADE(sv, SVt_PV);
4098 if (PerlLIO_lstat(".", &statbuf) < 0) {
4099 SV_CWD_RETURN_UNDEF;
4102 orig_cdev = statbuf.st_dev;
4103 orig_cino = statbuf.st_ino;
4113 if (PerlDir_chdir("..") < 0) {
4114 SV_CWD_RETURN_UNDEF;
4116 if (PerlLIO_stat(".", &statbuf) < 0) {
4117 SV_CWD_RETURN_UNDEF;
4120 cdev = statbuf.st_dev;
4121 cino = statbuf.st_ino;
4123 if (odev == cdev && oino == cino) {
4126 if (!(dir = PerlDir_open("."))) {
4127 SV_CWD_RETURN_UNDEF;
4130 while ((dp = PerlDir_read(dir)) != NULL) {
4132 namelen = dp->d_namlen;
4134 namelen = strlen(dp->d_name);
4137 if (SV_CWD_ISDOT(dp)) {
4141 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4142 SV_CWD_RETURN_UNDEF;
4145 tdev = statbuf.st_dev;
4146 tino = statbuf.st_ino;
4147 if (tino == oino && tdev == odev) {
4153 SV_CWD_RETURN_UNDEF;
4156 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4157 SV_CWD_RETURN_UNDEF;
4160 SvGROW(sv, pathlen + namelen + 1);
4164 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4167 /* prepend current directory to the front */
4169 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4170 pathlen += (namelen + 1);
4172 #ifdef VOID_CLOSEDIR
4175 if (PerlDir_close(dir) < 0) {
4176 SV_CWD_RETURN_UNDEF;
4182 SvCUR_set(sv, pathlen);
4186 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4187 SV_CWD_RETURN_UNDEF;
4190 if (PerlLIO_stat(".", &statbuf) < 0) {
4191 SV_CWD_RETURN_UNDEF;
4194 cdev = statbuf.st_dev;
4195 cino = statbuf.st_ino;
4197 if (cdev != orig_cdev || cino != orig_cino) {
4198 Perl_croak(aTHX_ "Unstable directory path, "
4199 "current directory changed unexpectedly");
4210 #define VERSION_MAX 0x7FFFFFFF
4212 =for apidoc scan_version
4214 Returns a pointer to the next character after the parsed
4215 version string, as well as upgrading the passed in SV to
4218 Function must be called with an already existing SV like
4221 s = scan_version(s, SV *sv, bool qv);
4223 Performs some preprocessing to the string to ensure that
4224 it has the correct characteristics of a version. Flags the
4225 object if it contains an underscore (which denotes this
4226 is an alpha version). The boolean qv denotes that the version
4227 should be interpreted as if it had multiple decimals, even if
4234 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4243 AV * const av = newAV();
4244 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4246 PERL_ARGS_ASSERT_SCAN_VERSION;
4248 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4250 while (isSPACE(*s)) /* leading whitespace is OK */
4256 s++; /* get past 'v' */
4257 qv = 1; /* force quoted version processing */
4262 /* pre-scan the input string to check for decimals/underbars */
4263 while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
4268 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4272 else if ( *pos == '_' )
4275 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4277 width = pos - last - 1; /* natural width of sub-version */
4279 else if ( *pos == ',' && isDIGIT(pos[1]) )
4288 if ( alpha && !saw_period )
4289 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4291 if ( alpha && saw_period && width == 0 )
4292 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4294 if ( saw_period > 1 )
4295 qv = 1; /* force quoted version processing */
4301 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4303 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4304 if ( !qv && width < 3 )
4305 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4307 while (isDIGIT(*pos))
4309 if (!isALPHA(*pos)) {
4315 /* this is atoi() that delimits on underscores */
4316 const char *end = pos;
4320 /* the following if() will only be true after the decimal
4321 * point of a version originally created with a bare
4322 * floating point number, i.e. not quoted in any way
4324 if ( !qv && s > start && saw_period == 1 ) {
4328 rev += (*s - '0') * mult;
4330 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4331 || (PERL_ABS(rev) > VERSION_MAX )) {
4332 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4333 "Integer overflow in version %d",VERSION_MAX);
4344 while (--end >= s) {
4346 rev += (*end - '0') * mult;
4348 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4349 || (PERL_ABS(rev) > VERSION_MAX )) {
4350 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4351 "Integer overflow in version");
4360 /* Append revision */
4361 av_push(av, newSViv(rev));
4366 else if ( *pos == '.' )
4368 else if ( *pos == '_' && isDIGIT(pos[1]) )
4370 else if ( *pos == ',' && isDIGIT(pos[1]) )
4372 else if ( isDIGIT(*pos) )
4379 while ( isDIGIT(*pos) )
4384 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4392 if ( qv ) { /* quoted versions always get at least three terms*/
4393 I32 len = av_len(av);
4394 /* This for loop appears to trigger a compiler bug on OS X, as it
4395 loops infinitely. Yes, len is negative. No, it makes no sense.
4396 Compiler in question is:
4397 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4398 for ( len = 2 - len; len > 0; len-- )
4399 av_push(MUTABLE_AV(sv), newSViv(0));
4403 av_push(av, newSViv(0));
4406 /* need to save off the current version string for later */
4408 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4409 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4410 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4412 else if ( s > start ) {
4413 SV * orig = newSVpvn(start,s-start);
4414 if ( qv && saw_period == 1 && *start != 'v' ) {
4415 /* need to insert a v to be consistent */
4416 sv_insert(orig, 0, 0, "v", 1);
4418 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4421 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4422 av_push(av, newSViv(0));
4425 /* And finally, store the AV in the hash */
4426 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4428 /* fix RT#19517 - special case 'undef' as string */
4429 if ( *s == 'u' && strEQ(s,"undef") ) {
4437 =for apidoc new_version
4439 Returns a new version object based on the passed in SV:
4441 SV *sv = new_version(SV *ver);
4443 Does not alter the passed in ver SV. See "upg_version" if you
4444 want to upgrade the SV.
4450 Perl_new_version(pTHX_ SV *ver)
4453 SV * const rv = newSV(0);
4454 PERL_ARGS_ASSERT_NEW_VERSION;
4455 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4458 AV * const av = newAV();
4460 /* This will get reblessed later if a derived class*/
4461 SV * const hv = newSVrv(rv, "version");
4462 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4467 /* Begin copying all of the elements */
4468 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4469 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4471 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4472 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4474 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4476 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4477 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4480 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4482 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4483 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4486 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4487 /* This will get reblessed later if a derived class*/
4488 for ( key = 0; key <= av_len(sav); key++ )
4490 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4491 av_push(av, newSViv(rev));
4494 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4499 const MAGIC* const mg = SvVSTRING_mg(ver);
4500 if ( mg ) { /* already a v-string */
4501 const STRLEN len = mg->mg_len;
4502 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4503 sv_setpvn(rv,version,len);
4504 /* this is for consistency with the pure Perl class */
4505 if ( *version != 'v' )
4506 sv_insert(rv, 0, 0, "v", 1);
4511 sv_setsv(rv,ver); /* make a duplicate */
4516 return upg_version(rv, FALSE);
4520 =for apidoc upg_version
4522 In-place upgrade of the supplied SV to a version object.
4524 SV *sv = upg_version(SV *sv, bool qv);
4526 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4527 to force this SV to be interpreted as an "extended" version.
4533 Perl_upg_version(pTHX_ SV *ver, bool qv)
4535 const char *version, *s;
4540 PERL_ARGS_ASSERT_UPG_VERSION;
4542 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4544 /* may get too much accuracy */
4546 #ifdef USE_LOCALE_NUMERIC
4547 char *loc = setlocale(LC_NUMERIC, "C");
4549 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4550 #ifdef USE_LOCALE_NUMERIC
4551 setlocale(LC_NUMERIC, loc);
4553 while (tbuf[len-1] == '0' && len > 0) len--;
4554 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4555 version = savepvn(tbuf, len);
4558 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4559 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4563 else /* must be a string or something like a string */
4566 version = savepv(SvPV(ver,len));
4568 # if PERL_VERSION > 5
4569 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4570 if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4571 /* may be a v-string */
4572 SV * const nsv = sv_newmortal();
4576 sv_setpvf(nsv,"v%vd",ver);
4577 pos = nver = savepv(SvPV_nolen(nsv));
4579 /* scan the resulting formatted string */
4580 pos++; /* skip the leading 'v' */
4581 while ( *pos == '.' || isDIGIT(*pos) ) {
4587 /* is definitely a v-string */
4588 if ( saw_period == 2 ) {
4597 s = scan_version(version, ver, qv);
4599 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4600 "Version string '%s' contains invalid data; "
4601 "ignoring: '%s'", version, s);
4609 Validates that the SV contains a valid version object.
4611 bool vverify(SV *vobj);
4613 Note that it only confirms the bare minimum structure (so as not to get
4614 confused by derived classes which may contain additional hash entries):
4618 =item * The SV contains a [reference to a] hash
4620 =item * The hash contains a "version" key
4622 =item * The "version" key has [a reference to] an AV as its value
4630 Perl_vverify(pTHX_ SV *vs)
4634 PERL_ARGS_ASSERT_VVERIFY;
4639 /* see if the appropriate elements exist */
4640 if ( SvTYPE(vs) == SVt_PVHV
4641 && hv_exists(MUTABLE_HV(vs), "version", 7)
4642 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4643 && SvTYPE(sv) == SVt_PVAV )
4652 Accepts a version object and returns the normalized floating
4653 point representation. Call like:
4657 NOTE: you can pass either the object directly or the SV
4658 contained within the RV.
4664 Perl_vnumify(pTHX_ SV *vs)
4669 SV * const sv = newSV(0);
4672 PERL_ARGS_ASSERT_VNUMIFY;
4678 Perl_croak(aTHX_ "Invalid version object");
4680 /* see if various flags exist */
4681 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4683 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4684 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4689 /* attempt to retrieve the version array */
4690 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4702 digit = SvIV(*av_fetch(av, 0, 0));
4703 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4704 for ( i = 1 ; i < len ; i++ )
4706 digit = SvIV(*av_fetch(av, i, 0));
4708 const int denom = (width == 2 ? 10 : 100);
4709 const div_t term = div((int)PERL_ABS(digit),denom);
4710 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4713 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4719 digit = SvIV(*av_fetch(av, len, 0));
4720 if ( alpha && width == 3 ) /* alpha version */
4722 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4726 sv_catpvs(sv, "000");
4734 Accepts a version object and returns the normalized string
4735 representation. Call like:
4739 NOTE: you can pass either the object directly or the SV
4740 contained within the RV.
4746 Perl_vnormal(pTHX_ SV *vs)
4750 SV * const sv = newSV(0);
4753 PERL_ARGS_ASSERT_VNORMAL;
4759 Perl_croak(aTHX_ "Invalid version object");
4761 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4763 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4771 digit = SvIV(*av_fetch(av, 0, 0));
4772 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4773 for ( i = 1 ; i < len ; i++ ) {
4774 digit = SvIV(*av_fetch(av, i, 0));
4775 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4780 /* handle last digit specially */
4781 digit = SvIV(*av_fetch(av, len, 0));
4783 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4785 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4788 if ( len <= 2 ) { /* short version, must be at least three */
4789 for ( len = 2 - len; len != 0; len-- )
4796 =for apidoc vstringify
4798 In order to maintain maximum compatibility with earlier versions
4799 of Perl, this function will return either the floating point
4800 notation or the multiple dotted notation, depending on whether
4801 the original version contained 1 or more dots, respectively
4807 Perl_vstringify(pTHX_ SV *vs)
4809 PERL_ARGS_ASSERT_VSTRINGIFY;
4815 Perl_croak(aTHX_ "Invalid version object");
4817 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
4819 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4823 return &PL_sv_undef;
4826 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4836 Version object aware cmp. Both operands must already have been
4837 converted into version objects.
4843 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4846 bool lalpha = FALSE;
4847 bool ralpha = FALSE;
4852 PERL_ARGS_ASSERT_VCMP;
4859 if ( !vverify(lhv) )
4860 Perl_croak(aTHX_ "Invalid version object");
4862 if ( !vverify(rhv) )
4863 Perl_croak(aTHX_ "Invalid version object");
4865 /* get the left hand term */
4866 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4867 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4870 /* and the right hand term */
4871 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4872 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4880 while ( i <= m && retval == 0 )
4882 left = SvIV(*av_fetch(lav,i,0));
4883 right = SvIV(*av_fetch(rav,i,0));
4891 /* tiebreaker for alpha with identical terms */
4892 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4894 if ( lalpha && !ralpha )
4898 else if ( ralpha && !lalpha)
4904 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4908 while ( i <= r && retval == 0 )
4910 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4911 retval = -1; /* not a match after all */
4917 while ( i <= l && retval == 0 )
4919 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4920 retval = +1; /* not a match after all */
4928 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4929 # define EMULATE_SOCKETPAIR_UDP
4932 #ifdef EMULATE_SOCKETPAIR_UDP
4934 S_socketpair_udp (int fd[2]) {
4936 /* Fake a datagram socketpair using UDP to localhost. */
4937 int sockets[2] = {-1, -1};
4938 struct sockaddr_in addresses[2];
4940 Sock_size_t size = sizeof(struct sockaddr_in);
4941 unsigned short port;
4944 memset(&addresses, 0, sizeof(addresses));
4947 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4948 if (sockets[i] == -1)
4949 goto tidy_up_and_fail;
4951 addresses[i].sin_family = AF_INET;
4952 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4953 addresses[i].sin_port = 0; /* kernel choses port. */
4954 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4955 sizeof(struct sockaddr_in)) == -1)
4956 goto tidy_up_and_fail;
4959 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4960 for each connect the other socket to it. */
4963 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4965 goto tidy_up_and_fail;
4966 if (size != sizeof(struct sockaddr_in))
4967 goto abort_tidy_up_and_fail;
4968 /* !1 is 0, !0 is 1 */
4969 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4970 sizeof(struct sockaddr_in)) == -1)
4971 goto tidy_up_and_fail;
4974 /* Now we have 2 sockets connected to each other. I don't trust some other
4975 process not to have already sent a packet to us (by random) so send
4976 a packet from each to the other. */
4979 /* I'm going to send my own port number. As a short.
4980 (Who knows if someone somewhere has sin_port as a bitfield and needs
4981 this routine. (I'm assuming crays have socketpair)) */
4982 port = addresses[i].sin_port;
4983 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4984 if (got != sizeof(port)) {
4986 goto tidy_up_and_fail;
4987 goto abort_tidy_up_and_fail;
4991 /* Packets sent. I don't trust them to have arrived though.
4992 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4993 connect to localhost will use a second kernel thread. In 2.6 the
4994 first thread running the connect() returns before the second completes,
4995 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4996 returns 0. Poor programs have tripped up. One poor program's authors'
4997 had a 50-1 reverse stock split. Not sure how connected these were.)
4998 So I don't trust someone not to have an unpredictable UDP stack.
5002 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5003 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5007 FD_SET((unsigned int)sockets[0], &rset);
5008 FD_SET((unsigned int)sockets[1], &rset);
5010 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5011 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5012 || !FD_ISSET(sockets[1], &rset)) {
5013 /* I hope this is portable and appropriate. */
5015 goto tidy_up_and_fail;
5016 goto abort_tidy_up_and_fail;
5020 /* And the paranoia department even now doesn't trust it to have arrive
5021 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5023 struct sockaddr_in readfrom;
5024 unsigned short buffer[2];
5029 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5030 sizeof(buffer), MSG_DONTWAIT,
5031 (struct sockaddr *) &readfrom, &size);
5033 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5035 (struct sockaddr *) &readfrom, &size);
5039 goto tidy_up_and_fail;
5040 if (got != sizeof(port)
5041 || size != sizeof(struct sockaddr_in)
5042 /* Check other socket sent us its port. */
5043 || buffer[0] != (unsigned short) addresses[!i].sin_port
5044 /* Check kernel says we got the datagram from that socket */
5045 || readfrom.sin_family != addresses[!i].sin_family
5046 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5047 || readfrom.sin_port != addresses[!i].sin_port)
5048 goto abort_tidy_up_and_fail;
5051 /* My caller (my_socketpair) has validated that this is non-NULL */
5054 /* I hereby declare this connection open. May God bless all who cross
5058 abort_tidy_up_and_fail:
5059 errno = ECONNABORTED;
5063 if (sockets[0] != -1)
5064 PerlLIO_close(sockets[0]);
5065 if (sockets[1] != -1)
5066 PerlLIO_close(sockets[1]);
5071 #endif /* EMULATE_SOCKETPAIR_UDP */
5073 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5075 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5076 /* Stevens says that family must be AF_LOCAL, protocol 0.
5077 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5082 struct sockaddr_in listen_addr;
5083 struct sockaddr_in connect_addr;
5088 || family != AF_UNIX
5091 errno = EAFNOSUPPORT;
5099 #ifdef EMULATE_SOCKETPAIR_UDP
5100 if (type == SOCK_DGRAM)
5101 return S_socketpair_udp(fd);
5104 listener = PerlSock_socket(AF_INET, type, 0);
5107 memset(&listen_addr, 0, sizeof(listen_addr));
5108 listen_addr.sin_family = AF_INET;
5109 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5110 listen_addr.sin_port = 0; /* kernel choses port. */
5111 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5112 sizeof(listen_addr)) == -1)
5113 goto tidy_up_and_fail;
5114 if (PerlSock_listen(listener, 1) == -1)
5115 goto tidy_up_and_fail;
5117 connector = PerlSock_socket(AF_INET, type, 0);
5118 if (connector == -1)
5119 goto tidy_up_and_fail;
5120 /* We want to find out the port number to connect to. */
5121 size = sizeof(connect_addr);
5122 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5124 goto tidy_up_and_fail;
5125 if (size != sizeof(connect_addr))
5126 goto abort_tidy_up_and_fail;
5127 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5128 sizeof(connect_addr)) == -1)
5129 goto tidy_up_and_fail;
5131 size = sizeof(listen_addr);
5132 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5135 goto tidy_up_and_fail;
5136 if (size != sizeof(listen_addr))
5137 goto abort_tidy_up_and_fail;
5138 PerlLIO_close(listener);
5139 /* Now check we are talking to ourself by matching port and host on the
5141 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5143 goto tidy_up_and_fail;
5144 if (size != sizeof(connect_addr)
5145 || listen_addr.sin_family != connect_addr.sin_family
5146 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5147 || listen_addr.sin_port != connect_addr.sin_port) {
5148 goto abort_tidy_up_and_fail;
5154 abort_tidy_up_and_fail:
5156 errno = ECONNABORTED; /* This would be the standard thing to do. */
5158 # ifdef ECONNREFUSED
5159 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5161 errno = ETIMEDOUT; /* Desperation time. */
5168 PerlLIO_close(listener);
5169 if (connector != -1)
5170 PerlLIO_close(connector);
5172 PerlLIO_close(acceptor);
5178 /* In any case have a stub so that there's code corresponding
5179 * to the my_socketpair in global.sym. */
5181 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5182 #ifdef HAS_SOCKETPAIR
5183 return socketpair(family, type, protocol, fd);
5192 =for apidoc sv_nosharing
5194 Dummy routine which "shares" an SV when there is no sharing module present.
5195 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5196 Exists to avoid test for a NULL function pointer and because it could
5197 potentially warn under some level of strict-ness.
5203 Perl_sv_nosharing(pTHX_ SV *sv)
5205 PERL_UNUSED_CONTEXT;
5206 PERL_UNUSED_ARG(sv);
5211 =for apidoc sv_destroyable
5213 Dummy routine which reports that object can be destroyed when there is no
5214 sharing module present. It ignores its single SV argument, and returns
5215 'true'. Exists to avoid test for a NULL function pointer and because it
5216 could potentially warn under some level of strict-ness.
5222 Perl_sv_destroyable(pTHX_ SV *sv)
5224 PERL_UNUSED_CONTEXT;
5225 PERL_UNUSED_ARG(sv);
5230 Perl_parse_unicode_opts(pTHX_ const char **popt)
5232 const char *p = *popt;
5235 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5239 opt = (U32) atoi(p);
5242 if (*p && *p != '\n' && *p != '\r')
5243 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5248 case PERL_UNICODE_STDIN:
5249 opt |= PERL_UNICODE_STDIN_FLAG; break;
5250 case PERL_UNICODE_STDOUT:
5251 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5252 case PERL_UNICODE_STDERR:
5253 opt |= PERL_UNICODE_STDERR_FLAG; break;
5254 case PERL_UNICODE_STD:
5255 opt |= PERL_UNICODE_STD_FLAG; break;
5256 case PERL_UNICODE_IN:
5257 opt |= PERL_UNICODE_IN_FLAG; break;
5258 case PERL_UNICODE_OUT:
5259 opt |= PERL_UNICODE_OUT_FLAG; break;
5260 case PERL_UNICODE_INOUT:
5261 opt |= PERL_UNICODE_INOUT_FLAG; break;
5262 case PERL_UNICODE_LOCALE:
5263 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5264 case PERL_UNICODE_ARGV:
5265 opt |= PERL_UNICODE_ARGV_FLAG; break;
5266 case PERL_UNICODE_UTF8CACHEASSERT:
5267 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5269 if (*p != '\n' && *p != '\r')
5271 "Unknown Unicode option letter '%c'", *p);
5277 opt = PERL_UNICODE_DEFAULT_FLAGS;
5279 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5280 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5281 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5293 * This is really just a quick hack which grabs various garbage
5294 * values. It really should be a real hash algorithm which
5295 * spreads the effect of every input bit onto every output bit,
5296 * if someone who knows about such things would bother to write it.
5297 * Might be a good idea to add that function to CORE as well.
5298 * No numbers below come from careful analysis or anything here,
5299 * except they are primes and SEED_C1 > 1E6 to get a full-width
5300 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5301 * probably be bigger too.
5304 # define SEED_C1 1000003
5305 #define SEED_C4 73819
5307 # define SEED_C1 25747
5308 #define SEED_C4 20639
5312 #define SEED_C5 26107
5314 #ifndef PERL_NO_DEV_RANDOM
5319 # include <starlet.h>
5320 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5321 * in 100-ns units, typically incremented ever 10 ms. */
5322 unsigned int when[2];
5324 # ifdef HAS_GETTIMEOFDAY
5325 struct timeval when;
5331 /* This test is an escape hatch, this symbol isn't set by Configure. */
5332 #ifndef PERL_NO_DEV_RANDOM
5333 #ifndef PERL_RANDOM_DEVICE
5334 /* /dev/random isn't used by default because reads from it will block
5335 * if there isn't enough entropy available. You can compile with
5336 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5337 * is enough real entropy to fill the seed. */
5338 # define PERL_RANDOM_DEVICE "/dev/urandom"
5340 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5342 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5351 _ckvmssts(sys$gettim(when));
5352 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5354 # ifdef HAS_GETTIMEOFDAY
5355 PerlProc_gettimeofday(&when,NULL);
5356 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5359 u = (U32)SEED_C1 * when;
5362 u += SEED_C3 * (U32)PerlProc_getpid();
5363 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5364 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5365 u += SEED_C5 * (U32)PTR2UV(&when);
5371 Perl_get_hash_seed(pTHX)
5374 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5380 if (s && isDIGIT(*s))
5381 myseed = (UV)Atoul(s);
5383 #ifdef USE_HASH_SEED_EXPLICIT
5387 /* Compute a random seed */
5388 (void)seedDrand01((Rand_seed_t)seed());
5389 myseed = (UV)(Drand01() * (NV)UV_MAX);
5390 #if RANDBITS < (UVSIZE * 8)
5391 /* Since there are not enough randbits to to reach all
5392 * the bits of a UV, the low bits might need extra
5393 * help. Sum in another random number that will
5394 * fill in the low bits. */
5396 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5397 #endif /* RANDBITS < (UVSIZE * 8) */
5398 if (myseed == 0) { /* Superparanoia. */
5399 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5401 Perl_croak(aTHX_ "Your random numbers are not that random");
5404 PL_rehash_seed_set = TRUE;
5411 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5413 const char * const stashpv = CopSTASHPV(c);
5414 const char * const name = HvNAME_get(hv);
5415 PERL_UNUSED_CONTEXT;
5416 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5418 if (stashpv == name)
5420 if (stashpv && name)
5421 if (strEQ(stashpv, name))
5428 #ifdef PERL_GLOBAL_STRUCT
5430 #define PERL_GLOBAL_STRUCT_INIT
5431 #include "opcode.h" /* the ppaddr and check */
5434 Perl_init_global_struct(pTHX)
5436 struct perl_vars *plvarsp = NULL;
5437 # ifdef PERL_GLOBAL_STRUCT
5438 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5439 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5440 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5441 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5442 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5446 plvarsp = PL_VarsPtr;
5447 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5453 # define PERLVAR(var,type) /**/
5454 # define PERLVARA(var,n,type) /**/
5455 # define PERLVARI(var,type,init) plvarsp->var = init;
5456 # define PERLVARIC(var,type,init) plvarsp->var = init;
5457 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5458 # include "perlvars.h"
5464 # ifdef PERL_GLOBAL_STRUCT
5467 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5468 if (!plvarsp->Gppaddr)
5472 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5473 if (!plvarsp->Gcheck)
5475 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5476 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5478 # ifdef PERL_SET_VARS
5479 PERL_SET_VARS(plvarsp);
5481 # undef PERL_GLOBAL_STRUCT_INIT
5486 #endif /* PERL_GLOBAL_STRUCT */
5488 #ifdef PERL_GLOBAL_STRUCT
5491 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5493 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5494 # ifdef PERL_GLOBAL_STRUCT
5495 # ifdef PERL_UNSET_VARS
5496 PERL_UNSET_VARS(plvarsp);
5498 free(plvarsp->Gppaddr);
5499 free(plvarsp->Gcheck);
5500 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5506 #endif /* PERL_GLOBAL_STRUCT */
5510 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5511 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5512 * given, and you supply your own implementation.
5514 * The default implementation reads a single env var, PERL_MEM_LOG,
5515 * expecting one or more of the following:
5517 * \d+ - fd fd to write to : must be 1st (atoi)
5518 * 'm' - memlog was PERL_MEM_LOG=1
5519 * 's' - svlog was PERL_SV_LOG=1
5520 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5522 * This makes the logger controllable enough that it can reasonably be
5523 * added to the system perl.
5526 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5527 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5529 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5531 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5532 * writes to. In the default logger, this is settable at runtime.
5534 #ifndef PERL_MEM_LOG_FD
5535 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5538 #ifndef PERL_MEM_LOG_NOIMPL
5540 # ifdef DEBUG_LEAKING_SCALARS
5541 # define SV_LOG_SERIAL_FMT " [%lu]"
5542 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5544 # define SV_LOG_SERIAL_FMT
5545 # define _SV_LOG_SERIAL_ARG(sv)
5549 S_mem_log_common(enum mem_log_type mlt, const UV n,
5550 const UV typesize, const char *type_name, const SV *sv,
5551 Malloc_t oldalloc, Malloc_t newalloc,
5552 const char *filename, const int linenumber,
5553 const char *funcname)
5557 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5559 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5562 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5564 /* We can't use SVs or PerlIO for obvious reasons,
5565 * so we'll use stdio and low-level IO instead. */
5566 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5568 # ifdef HAS_GETTIMEOFDAY
5569 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5570 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5572 gettimeofday(&tv, 0);
5574 # define MEM_LOG_TIME_FMT "%10d: "
5575 # define MEM_LOG_TIME_ARG (int)when
5579 /* If there are other OS specific ways of hires time than
5580 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5581 * probably that they would be used to fill in the struct
5585 int fd = atoi(pmlenv);
5587 fd = PERL_MEM_LOG_FD;
5589 if (strchr(pmlenv, 't')) {
5590 len = my_snprintf(buf, sizeof(buf),
5591 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5592 PerlLIO_write(fd, buf, len);
5596 len = my_snprintf(buf, sizeof(buf),
5597 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5598 " %s = %"IVdf": %"UVxf"\n",
5599 filename, linenumber, funcname, n, typesize,
5600 type_name, n * typesize, PTR2UV(newalloc));
5603 len = my_snprintf(buf, sizeof(buf),
5604 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5605 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5606 filename, linenumber, funcname, n, typesize,
5607 type_name, n * typesize, PTR2UV(oldalloc),
5611 len = my_snprintf(buf, sizeof(buf),
5612 "free: %s:%d:%s: %"UVxf"\n",
5613 filename, linenumber, funcname,
5618 len = my_snprintf(buf, sizeof(buf),
5619 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5620 mlt == MLT_NEW_SV ? "new" : "del",
5621 filename, linenumber, funcname,
5622 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5627 PerlLIO_write(fd, buf, len);
5631 #endif /* !PERL_MEM_LOG_NOIMPL */
5633 #ifndef PERL_MEM_LOG_NOIMPL
5635 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5636 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5638 /* this is suboptimal, but bug compatible. User is providing their
5639 own implemenation, but is getting these functions anyway, and they
5640 do nothing. But _NOIMPL users should be able to cope or fix */
5642 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5643 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5647 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5649 const char *filename, const int linenumber,
5650 const char *funcname)
5652 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5653 NULL, NULL, newalloc,
5654 filename, linenumber, funcname);
5659 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5660 Malloc_t oldalloc, Malloc_t newalloc,
5661 const char *filename, const int linenumber,
5662 const char *funcname)
5664 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5665 NULL, oldalloc, newalloc,
5666 filename, linenumber, funcname);
5671 Perl_mem_log_free(Malloc_t oldalloc,
5672 const char *filename, const int linenumber,
5673 const char *funcname)
5675 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5676 filename, linenumber, funcname);
5681 Perl_mem_log_new_sv(const SV *sv,
5682 const char *filename, const int linenumber,
5683 const char *funcname)
5685 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5686 filename, linenumber, funcname);
5690 Perl_mem_log_del_sv(const SV *sv,
5691 const char *filename, const int linenumber,
5692 const char *funcname)
5694 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5695 filename, linenumber, funcname);
5698 #endif /* PERL_MEM_LOG */
5701 =for apidoc my_sprintf
5703 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5704 the length of the string written to the buffer. Only rare pre-ANSI systems
5705 need the wrapper function - usually this is a direct call to C<sprintf>.
5709 #ifndef SPRINTF_RETURNS_STRLEN
5711 Perl_my_sprintf(char *buffer, const char* pat, ...)
5714 PERL_ARGS_ASSERT_MY_SPRINTF;
5715 va_start(args, pat);
5716 vsprintf(buffer, pat, args);
5718 return strlen(buffer);
5723 =for apidoc my_snprintf
5725 The C library C<snprintf> functionality, if available and
5726 standards-compliant (uses C<vsnprintf>, actually). However, if the
5727 C<vsnprintf> is not available, will unfortunately use the unsafe
5728 C<vsprintf> which can overrun the buffer (there is an overrun check,
5729 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5730 getting C<vsnprintf>.
5735 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5740 PERL_ARGS_ASSERT_MY_SNPRINTF;
5741 va_start(ap, format);
5742 #ifdef HAS_VSNPRINTF
5743 retval = vsnprintf(buffer, len, format, ap);
5745 retval = vsprintf(buffer, format, ap);
5748 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5749 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5750 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5755 =for apidoc my_vsnprintf
5757 The C library C<vsnprintf> if available and standards-compliant.
5758 However, if if the C<vsnprintf> is not available, will unfortunately
5759 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5760 overrun check, but that may be too late). Consider using
5761 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5766 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5773 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5775 Perl_va_copy(ap, apc);
5776 # ifdef HAS_VSNPRINTF
5777 retval = vsnprintf(buffer, len, format, apc);
5779 retval = vsprintf(buffer, format, apc);
5782 # ifdef HAS_VSNPRINTF
5783 retval = vsnprintf(buffer, len, format, ap);
5785 retval = vsprintf(buffer, format, ap);
5787 #endif /* #ifdef NEED_VA_COPY */
5788 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5789 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5790 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5795 Perl_my_clearenv(pTHX)
5798 #if ! defined(PERL_MICRO)
5799 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5801 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5802 # if defined(USE_ENVIRON_ARRAY)
5803 # if defined(USE_ITHREADS)
5804 /* only the parent thread can clobber the process environment */
5805 if (PL_curinterp == aTHX)
5806 # endif /* USE_ITHREADS */
5808 # if ! defined(PERL_USE_SAFE_PUTENV)
5809 if ( !PL_use_safe_putenv) {
5811 if (environ == PL_origenviron)
5812 environ = (char**)safesysmalloc(sizeof(char*));
5814 for (i = 0; environ[i]; i++)
5815 (void)safesysfree(environ[i]);
5818 # else /* PERL_USE_SAFE_PUTENV */
5819 # if defined(HAS_CLEARENV)
5821 # elif defined(HAS_UNSETENV)
5822 int bsiz = 80; /* Most envvar names will be shorter than this. */
5823 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5824 char *buf = (char*)safesysmalloc(bufsiz);
5825 while (*environ != NULL) {
5826 char *e = strchr(*environ, '=');
5827 int l = e ? e - *environ : (int)strlen(*environ);
5829 (void)safesysfree(buf);
5830 bsiz = l + 1; /* + 1 for the \0. */
5831 buf = (char*)safesysmalloc(bufsiz);
5833 memcpy(buf, *environ, l);
5835 (void)unsetenv(buf);
5837 (void)safesysfree(buf);
5838 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5839 /* Just null environ and accept the leakage. */
5841 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5842 # endif /* ! PERL_USE_SAFE_PUTENV */
5844 # endif /* USE_ENVIRON_ARRAY */
5845 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5846 #endif /* PERL_MICRO */
5849 #ifdef PERL_IMPLICIT_CONTEXT
5851 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5852 the global PL_my_cxt_index is incremented, and that value is assigned to
5853 that module's static my_cxt_index (who's address is passed as an arg).
5854 Then, for each interpreter this function is called for, it makes sure a
5855 void* slot is available to hang the static data off, by allocating or
5856 extending the interpreter's PL_my_cxt_list array */
5858 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5860 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5864 PERL_ARGS_ASSERT_MY_CXT_INIT;
5866 /* this module hasn't been allocated an index yet */
5867 MUTEX_LOCK(&PL_my_ctx_mutex);
5868 *index = PL_my_cxt_index++;
5869 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5872 /* make sure the array is big enough */
5873 if (PL_my_cxt_size <= *index) {
5874 if (PL_my_cxt_size) {
5875 while (PL_my_cxt_size <= *index)
5876 PL_my_cxt_size *= 2;
5877 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5880 PL_my_cxt_size = 16;
5881 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5884 /* newSV() allocates one more than needed */
5885 p = (void*)SvPVX(newSV(size-1));
5886 PL_my_cxt_list[*index] = p;
5887 Zero(p, size, char);
5891 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5894 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5899 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5901 for (index = 0; index < PL_my_cxt_index; index++) {
5902 const char *key = PL_my_cxt_keys[index];
5903 /* try direct pointer compare first - there are chances to success,
5904 * and it's much faster.
5906 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5913 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5919 PERL_ARGS_ASSERT_MY_CXT_INIT;
5921 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5923 /* this module hasn't been allocated an index yet */
5924 MUTEX_LOCK(&PL_my_ctx_mutex);
5925 index = PL_my_cxt_index++;
5926 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5929 /* make sure the array is big enough */
5930 if (PL_my_cxt_size <= index) {
5931 int old_size = PL_my_cxt_size;
5933 if (PL_my_cxt_size) {
5934 while (PL_my_cxt_size <= index)
5935 PL_my_cxt_size *= 2;
5936 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5937 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5940 PL_my_cxt_size = 16;
5941 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5942 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5944 for (i = old_size; i < PL_my_cxt_size; i++) {
5945 PL_my_cxt_keys[i] = 0;
5946 PL_my_cxt_list[i] = 0;
5949 PL_my_cxt_keys[index] = my_cxt_key;
5950 /* newSV() allocates one more than needed */
5951 p = (void*)SvPVX(newSV(size-1));
5952 PL_my_cxt_list[index] = p;
5953 Zero(p, size, char);
5956 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5957 #endif /* PERL_IMPLICIT_CONTEXT */
5961 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5963 Size_t used, length, copy;
5966 length = strlen(src);
5967 if (size > 0 && used < size - 1) {
5968 copy = (length >= size - used) ? size - used - 1 : length;
5969 memcpy(dst + used, src, copy);
5970 dst[used + copy] = '\0';
5972 return used + length;
5978 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5980 Size_t length, copy;
5982 length = strlen(src);
5984 copy = (length >= size) ? size - 1 : length;
5985 memcpy(dst, src, copy);
5992 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5993 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5994 long _ftol( double ); /* Defined by VC6 C libs. */
5995 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5999 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6002 SV * const dbsv = GvSVn(PL_DBsub);
6003 /* We do not care about using sv to call CV;
6004 * it's for informational purposes only.
6007 PERL_ARGS_ASSERT_GET_DB_SUB;
6010 if (!PERLDB_SUB_NN) {
6011 GV * const gv = CvGV(cv);
6013 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6014 || strEQ(GvNAME(gv), "END")
6015 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6016 !( (SvTYPE(*svp) == SVt_PVGV)
6017 && (GvCV((const GV *)*svp) == cv) )))) {
6018 /* Use GV from the stack as a fallback. */
6019 /* GV is potentially non-unique, or contain different CV. */
6020 SV * const tmp = newRV(MUTABLE_SV(cv));
6021 sv_setsv(dbsv, tmp);
6025 gv_efullname3(dbsv, gv, NULL);
6029 const int type = SvTYPE(dbsv);
6030 if (type < SVt_PVIV && type != SVt_IV)
6031 sv_upgrade(dbsv, SVt_PVIV);
6032 (void)SvIOK_on(dbsv);
6033 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6038 Perl_my_dirfd(pTHX_ DIR * dir) {
6040 /* Most dirfd implementations have problems when passed NULL. */
6045 #elif defined(HAS_DIR_DD_FD)
6048 Perl_die(aTHX_ PL_no_func, "dirfd");
6055 Perl_get_re_arg(pTHX_ SV *sv) {
6061 sv = MUTABLE_SV(SvRV(sv));
6062 if (SvTYPE(sv) == SVt_REGEXP)
6063 return (REGEXP*) sv;
6071 * c-indentation-style: bsd
6073 * indent-tabs-mode: t
6076 * ex: set ts=8 sts=4 sw=4 noet: