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;
1364 const int was_in_eval = PL_in_eval;
1368 message = vdie_croak_common(pat, args, &msglen, &utf8);
1370 PL_restartop = die_where(message, msglen);
1371 SvFLAGS(ERRSV) |= utf8;
1372 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1374 return PL_restartop;
1377 #if defined(PERL_IMPLICIT_CONTEXT)
1379 Perl_die_nocontext(const char* pat, ...)
1384 va_start(args, pat);
1385 o = vdie(pat, &args);
1389 #endif /* PERL_IMPLICIT_CONTEXT */
1392 Perl_die(pTHX_ const char* pat, ...)
1396 va_start(args, pat);
1397 o = vdie(pat, &args);
1403 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1406 const char *message;
1410 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1413 PL_restartop = die_where(message, msglen);
1414 SvFLAGS(ERRSV) |= utf8;
1418 message = SvPVx_const(ERRSV, msglen);
1420 write_to_stderr(message, msglen);
1424 #if defined(PERL_IMPLICIT_CONTEXT)
1426 Perl_croak_nocontext(const char *pat, ...)
1430 va_start(args, pat);
1435 #endif /* PERL_IMPLICIT_CONTEXT */
1438 =head1 Warning and Dieing
1442 This is the XSUB-writer's interface to Perl's C<die> function.
1443 Normally call this function the same way you call the C C<printf>
1444 function. Calling C<croak> returns control directly to Perl,
1445 sidestepping the normal C order of execution. See C<warn>.
1447 If you want to throw an exception object, assign the object to
1448 C<$@> and then pass C<NULL> to croak():
1450 errsv = get_sv("@", GV_ADD);
1451 sv_setsv(errsv, exception_object);
1458 Perl_croak(pTHX_ const char *pat, ...)
1461 va_start(args, pat);
1468 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1472 SV * const msv = vmess(pat, args);
1473 const I32 utf8 = SvUTF8(msv);
1474 const char * const message = SvPV_const(msv, msglen);
1476 PERL_ARGS_ASSERT_VWARN;
1479 if (vdie_common(message, msglen, utf8, TRUE))
1483 write_to_stderr(message, msglen);
1486 #if defined(PERL_IMPLICIT_CONTEXT)
1488 Perl_warn_nocontext(const char *pat, ...)
1492 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1493 va_start(args, pat);
1497 #endif /* PERL_IMPLICIT_CONTEXT */
1502 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1503 function the same way you call the C C<printf> function. See C<croak>.
1509 Perl_warn(pTHX_ const char *pat, ...)
1512 PERL_ARGS_ASSERT_WARN;
1513 va_start(args, pat);
1518 #if defined(PERL_IMPLICIT_CONTEXT)
1520 Perl_warner_nocontext(U32 err, const char *pat, ...)
1524 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1525 va_start(args, pat);
1526 vwarner(err, pat, &args);
1529 #endif /* PERL_IMPLICIT_CONTEXT */
1532 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1534 PERL_ARGS_ASSERT_CK_WARNER_D;
1536 if (Perl_ckwarn_d(aTHX_ err)) {
1538 va_start(args, pat);
1539 vwarner(err, pat, &args);
1545 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1547 PERL_ARGS_ASSERT_CK_WARNER;
1549 if (Perl_ckwarn(aTHX_ err)) {
1551 va_start(args, pat);
1552 vwarner(err, pat, &args);
1558 Perl_warner(pTHX_ U32 err, const char* pat,...)
1561 PERL_ARGS_ASSERT_WARNER;
1562 va_start(args, pat);
1563 vwarner(err, pat, &args);
1568 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1571 PERL_ARGS_ASSERT_VWARNER;
1572 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1573 SV * const msv = vmess(pat, args);
1575 const char * const message = SvPV_const(msv, msglen);
1576 const I32 utf8 = SvUTF8(msv);
1580 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1583 PL_restartop = die_where(message, msglen);
1584 SvFLAGS(ERRSV) |= utf8;
1587 write_to_stderr(message, msglen);
1591 Perl_vwarn(aTHX_ pat, args);
1595 /* implements the ckWARN? macros */
1598 Perl_ckwarn(pTHX_ U32 w)
1602 ? (PL_curcop->cop_warnings != pWARN_NONE
1604 PL_curcop->cop_warnings == pWARN_ALL
1605 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1606 || (unpackWARN2(w) &&
1607 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1608 || (unpackWARN3(w) &&
1609 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1610 || (unpackWARN4(w) &&
1611 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1614 : (PL_dowarn & G_WARN_ON);
1617 /* implements the ckWARN?_d macro */
1620 Perl_ckwarn_d(pTHX_ U32 w)
1625 || PL_curcop->cop_warnings == pWARN_ALL
1627 PL_curcop->cop_warnings != pWARN_NONE
1629 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1630 || (unpackWARN2(w) &&
1631 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1632 || (unpackWARN3(w) &&
1633 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1634 || (unpackWARN4(w) &&
1635 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1641 /* Set buffer=NULL to get a new one. */
1643 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1645 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1646 PERL_UNUSED_CONTEXT;
1647 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1650 (specialWARN(buffer) ?
1651 PerlMemShared_malloc(len_wanted) :
1652 PerlMemShared_realloc(buffer, len_wanted));
1654 Copy(bits, (buffer + 1), size, char);
1658 /* since we've already done strlen() for both nam and val
1659 * we can use that info to make things faster than
1660 * sprintf(s, "%s=%s", nam, val)
1662 #define my_setenv_format(s, nam, nlen, val, vlen) \
1663 Copy(nam, s, nlen, char); \
1665 Copy(val, s+(nlen+1), vlen, char); \
1666 *(s+(nlen+1+vlen)) = '\0'
1668 #ifdef USE_ENVIRON_ARRAY
1669 /* VMS' my_setenv() is in vms.c */
1670 #if !defined(WIN32) && !defined(NETWARE)
1672 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1676 /* only parent thread can modify process environment */
1677 if (PL_curinterp == aTHX)
1680 #ifndef PERL_USE_SAFE_PUTENV
1681 if (!PL_use_safe_putenv) {
1682 /* most putenv()s leak, so we manipulate environ directly */
1684 register const I32 len = strlen(nam);
1687 /* where does it go? */
1688 for (i = 0; environ[i]; i++) {
1689 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1693 if (environ == PL_origenviron) { /* need we copy environment? */
1699 while (environ[max])
1701 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1702 for (j=0; j<max; j++) { /* copy environment */
1703 const int len = strlen(environ[j]);
1704 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1705 Copy(environ[j], tmpenv[j], len+1, char);
1708 environ = tmpenv; /* tell exec where it is now */
1711 safesysfree(environ[i]);
1712 while (environ[i]) {
1713 environ[i] = environ[i+1];
1718 if (!environ[i]) { /* does not exist yet */
1719 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1720 environ[i+1] = NULL; /* make sure it's null terminated */
1723 safesysfree(environ[i]);
1727 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1728 /* all that work just for this */
1729 my_setenv_format(environ[i], nam, nlen, val, vlen);
1732 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1733 # if defined(HAS_UNSETENV)
1735 (void)unsetenv(nam);
1737 (void)setenv(nam, val, 1);
1739 # else /* ! HAS_UNSETENV */
1740 (void)setenv(nam, val, 1);
1741 # endif /* HAS_UNSETENV */
1743 # if defined(HAS_UNSETENV)
1745 (void)unsetenv(nam);
1747 const int nlen = strlen(nam);
1748 const int vlen = strlen(val);
1749 char * const new_env =
1750 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1751 my_setenv_format(new_env, nam, nlen, val, vlen);
1752 (void)putenv(new_env);
1754 # else /* ! HAS_UNSETENV */
1756 const int nlen = strlen(nam);
1762 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1763 /* all that work just for this */
1764 my_setenv_format(new_env, nam, nlen, val, vlen);
1765 (void)putenv(new_env);
1766 # endif /* HAS_UNSETENV */
1767 # endif /* __CYGWIN__ */
1768 #ifndef PERL_USE_SAFE_PUTENV
1774 #else /* WIN32 || NETWARE */
1777 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1780 register char *envstr;
1781 const int nlen = strlen(nam);
1788 Newx(envstr, nlen+vlen+2, char);
1789 my_setenv_format(envstr, nam, nlen, val, vlen);
1790 (void)PerlEnv_putenv(envstr);
1794 #endif /* WIN32 || NETWARE */
1796 #endif /* !VMS && !EPOC*/
1798 #ifdef UNLINK_ALL_VERSIONS
1800 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1804 PERL_ARGS_ASSERT_UNLNK;
1806 while (PerlLIO_unlink(f) >= 0)
1808 return retries ? 0 : -1;
1812 /* this is a drop-in replacement for bcopy() */
1813 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1815 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1817 char * const retval = to;
1819 PERL_ARGS_ASSERT_MY_BCOPY;
1821 if (from - to >= 0) {
1829 *(--to) = *(--from);
1835 /* this is a drop-in replacement for memset() */
1838 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1840 char * const retval = loc;
1842 PERL_ARGS_ASSERT_MY_MEMSET;
1850 /* this is a drop-in replacement for bzero() */
1851 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1853 Perl_my_bzero(register char *loc, register I32 len)
1855 char * const retval = loc;
1857 PERL_ARGS_ASSERT_MY_BZERO;
1865 /* this is a drop-in replacement for memcmp() */
1866 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1868 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1870 register const U8 *a = (const U8 *)s1;
1871 register const U8 *b = (const U8 *)s2;
1874 PERL_ARGS_ASSERT_MY_MEMCMP;
1877 if ((tmp = *a++ - *b++))
1882 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1885 /* This vsprintf replacement should generally never get used, since
1886 vsprintf was available in both System V and BSD 2.11. (There may
1887 be some cross-compilation or embedded set-ups where it is needed,
1890 If you encounter a problem in this function, it's probably a symptom
1891 that Configure failed to detect your system's vprintf() function.
1892 See the section on "item vsprintf" in the INSTALL file.
1894 This version may compile on systems with BSD-ish <stdio.h>,
1895 but probably won't on others.
1898 #ifdef USE_CHAR_VSPRINTF
1903 vsprintf(char *dest, const char *pat, void *args)
1907 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1908 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1909 FILE_cnt(&fakebuf) = 32767;
1911 /* These probably won't compile -- If you really need
1912 this, you'll have to figure out some other method. */
1913 fakebuf._ptr = dest;
1914 fakebuf._cnt = 32767;
1919 fakebuf._flag = _IOWRT|_IOSTRG;
1920 _doprnt(pat, args, &fakebuf); /* what a kludge */
1921 #if defined(STDIO_PTR_LVALUE)
1922 *(FILE_ptr(&fakebuf)++) = '\0';
1924 /* PerlIO has probably #defined away fputc, but we want it here. */
1926 # undef fputc /* XXX Should really restore it later */
1928 (void)fputc('\0', &fakebuf);
1930 #ifdef USE_CHAR_VSPRINTF
1933 return 0; /* perl doesn't use return value */
1937 #endif /* HAS_VPRINTF */
1940 #if BYTEORDER != 0x4321
1942 Perl_my_swap(pTHX_ short s)
1944 #if (BYTEORDER & 1) == 0
1947 result = ((s & 255) << 8) + ((s >> 8) & 255);
1955 Perl_my_htonl(pTHX_ long l)
1959 char c[sizeof(long)];
1962 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1963 #if BYTEORDER == 0x12345678
1966 u.c[0] = (l >> 24) & 255;
1967 u.c[1] = (l >> 16) & 255;
1968 u.c[2] = (l >> 8) & 255;
1972 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1973 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1978 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1979 u.c[o & 0xf] = (l >> s) & 255;
1987 Perl_my_ntohl(pTHX_ long l)
1991 char c[sizeof(long)];
1994 #if BYTEORDER == 0x1234
1995 u.c[0] = (l >> 24) & 255;
1996 u.c[1] = (l >> 16) & 255;
1997 u.c[2] = (l >> 8) & 255;
2001 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2002 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2009 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2010 l |= (u.c[o & 0xf] & 255) << s;
2017 #endif /* BYTEORDER != 0x4321 */
2021 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2022 * If these functions are defined,
2023 * the BYTEORDER is neither 0x1234 nor 0x4321.
2024 * However, this is not assumed.
2028 #define HTOLE(name,type) \
2030 name (register type n) \
2034 char c[sizeof(type)]; \
2037 register U32 s = 0; \
2038 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2039 u.c[i] = (n >> s) & 0xFF; \
2044 #define LETOH(name,type) \
2046 name (register type n) \
2050 char c[sizeof(type)]; \
2053 register U32 s = 0; \
2056 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2057 n |= ((type)(u.c[i] & 0xFF)) << s; \
2063 * Big-endian byte order functions.
2066 #define HTOBE(name,type) \
2068 name (register type n) \
2072 char c[sizeof(type)]; \
2075 register U32 s = 8*(sizeof(u.c)-1); \
2076 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2077 u.c[i] = (n >> s) & 0xFF; \
2082 #define BETOH(name,type) \
2084 name (register type n) \
2088 char c[sizeof(type)]; \
2091 register U32 s = 8*(sizeof(u.c)-1); \
2094 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2095 n |= ((type)(u.c[i] & 0xFF)) << s; \
2101 * If we just can't do it...
2104 #define NOT_AVAIL(name,type) \
2106 name (register type n) \
2108 Perl_croak_nocontext(#name "() not available"); \
2109 return n; /* not reached */ \
2113 #if defined(HAS_HTOVS) && !defined(htovs)
2116 #if defined(HAS_HTOVL) && !defined(htovl)
2119 #if defined(HAS_VTOHS) && !defined(vtohs)
2122 #if defined(HAS_VTOHL) && !defined(vtohl)
2126 #ifdef PERL_NEED_MY_HTOLE16
2128 HTOLE(Perl_my_htole16,U16)
2130 NOT_AVAIL(Perl_my_htole16,U16)
2133 #ifdef PERL_NEED_MY_LETOH16
2135 LETOH(Perl_my_letoh16,U16)
2137 NOT_AVAIL(Perl_my_letoh16,U16)
2140 #ifdef PERL_NEED_MY_HTOBE16
2142 HTOBE(Perl_my_htobe16,U16)
2144 NOT_AVAIL(Perl_my_htobe16,U16)
2147 #ifdef PERL_NEED_MY_BETOH16
2149 BETOH(Perl_my_betoh16,U16)
2151 NOT_AVAIL(Perl_my_betoh16,U16)
2155 #ifdef PERL_NEED_MY_HTOLE32
2157 HTOLE(Perl_my_htole32,U32)
2159 NOT_AVAIL(Perl_my_htole32,U32)
2162 #ifdef PERL_NEED_MY_LETOH32
2164 LETOH(Perl_my_letoh32,U32)
2166 NOT_AVAIL(Perl_my_letoh32,U32)
2169 #ifdef PERL_NEED_MY_HTOBE32
2171 HTOBE(Perl_my_htobe32,U32)
2173 NOT_AVAIL(Perl_my_htobe32,U32)
2176 #ifdef PERL_NEED_MY_BETOH32
2178 BETOH(Perl_my_betoh32,U32)
2180 NOT_AVAIL(Perl_my_betoh32,U32)
2184 #ifdef PERL_NEED_MY_HTOLE64
2186 HTOLE(Perl_my_htole64,U64)
2188 NOT_AVAIL(Perl_my_htole64,U64)
2191 #ifdef PERL_NEED_MY_LETOH64
2193 LETOH(Perl_my_letoh64,U64)
2195 NOT_AVAIL(Perl_my_letoh64,U64)
2198 #ifdef PERL_NEED_MY_HTOBE64
2200 HTOBE(Perl_my_htobe64,U64)
2202 NOT_AVAIL(Perl_my_htobe64,U64)
2205 #ifdef PERL_NEED_MY_BETOH64
2207 BETOH(Perl_my_betoh64,U64)
2209 NOT_AVAIL(Perl_my_betoh64,U64)
2213 #ifdef PERL_NEED_MY_HTOLES
2214 HTOLE(Perl_my_htoles,short)
2216 #ifdef PERL_NEED_MY_LETOHS
2217 LETOH(Perl_my_letohs,short)
2219 #ifdef PERL_NEED_MY_HTOBES
2220 HTOBE(Perl_my_htobes,short)
2222 #ifdef PERL_NEED_MY_BETOHS
2223 BETOH(Perl_my_betohs,short)
2226 #ifdef PERL_NEED_MY_HTOLEI
2227 HTOLE(Perl_my_htolei,int)
2229 #ifdef PERL_NEED_MY_LETOHI
2230 LETOH(Perl_my_letohi,int)
2232 #ifdef PERL_NEED_MY_HTOBEI
2233 HTOBE(Perl_my_htobei,int)
2235 #ifdef PERL_NEED_MY_BETOHI
2236 BETOH(Perl_my_betohi,int)
2239 #ifdef PERL_NEED_MY_HTOLEL
2240 HTOLE(Perl_my_htolel,long)
2242 #ifdef PERL_NEED_MY_LETOHL
2243 LETOH(Perl_my_letohl,long)
2245 #ifdef PERL_NEED_MY_HTOBEL
2246 HTOBE(Perl_my_htobel,long)
2248 #ifdef PERL_NEED_MY_BETOHL
2249 BETOH(Perl_my_betohl,long)
2253 Perl_my_swabn(void *ptr, int n)
2255 register char *s = (char *)ptr;
2256 register char *e = s + (n-1);
2259 PERL_ARGS_ASSERT_MY_SWABN;
2261 for (n /= 2; n > 0; s++, e--, n--) {
2269 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2271 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2274 register I32 This, that;
2280 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2282 PERL_FLUSHALL_FOR_CHILD;
2283 This = (*mode == 'w');
2287 taint_proper("Insecure %s%s", "EXEC");
2289 if (PerlProc_pipe(p) < 0)
2291 /* Try for another pipe pair for error return */
2292 if (PerlProc_pipe(pp) >= 0)
2294 while ((pid = PerlProc_fork()) < 0) {
2295 if (errno != EAGAIN) {
2296 PerlLIO_close(p[This]);
2297 PerlLIO_close(p[that]);
2299 PerlLIO_close(pp[0]);
2300 PerlLIO_close(pp[1]);
2304 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2313 /* Close parent's end of error status pipe (if any) */
2315 PerlLIO_close(pp[0]);
2316 #if defined(HAS_FCNTL) && defined(F_SETFD)
2317 /* Close error pipe automatically if exec works */
2318 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2321 /* Now dup our end of _the_ pipe to right position */
2322 if (p[THIS] != (*mode == 'r')) {
2323 PerlLIO_dup2(p[THIS], *mode == 'r');
2324 PerlLIO_close(p[THIS]);
2325 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2326 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2329 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2330 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2331 /* No automatic close - do it by hand */
2338 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2344 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2350 do_execfree(); /* free any memory malloced by child on fork */
2352 PerlLIO_close(pp[1]);
2353 /* Keep the lower of the two fd numbers */
2354 if (p[that] < p[This]) {
2355 PerlLIO_dup2(p[This], p[that]);
2356 PerlLIO_close(p[This]);
2360 PerlLIO_close(p[that]); /* close child's end of pipe */
2362 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2363 SvUPGRADE(sv,SVt_IV);
2365 PL_forkprocess = pid;
2366 /* If we managed to get status pipe check for exec fail */
2367 if (did_pipes && pid > 0) {
2372 while (n < sizeof(int)) {
2373 n1 = PerlLIO_read(pp[0],
2374 (void*)(((char*)&errkid)+n),
2380 PerlLIO_close(pp[0]);
2382 if (n) { /* Error */
2384 PerlLIO_close(p[This]);
2385 if (n != sizeof(int))
2386 Perl_croak(aTHX_ "panic: kid popen errno read");
2388 pid2 = wait4pid(pid, &status, 0);
2389 } while (pid2 == -1 && errno == EINTR);
2390 errno = errkid; /* Propagate errno from kid */
2395 PerlLIO_close(pp[0]);
2396 return PerlIO_fdopen(p[This], mode);
2398 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2399 return my_syspopen4(aTHX_ NULL, mode, n, args);
2401 Perl_croak(aTHX_ "List form of piped open not implemented");
2402 return (PerlIO *) NULL;
2407 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2408 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2410 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2414 register I32 This, that;
2417 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2421 PERL_ARGS_ASSERT_MY_POPEN;
2423 PERL_FLUSHALL_FOR_CHILD;
2426 return my_syspopen(aTHX_ cmd,mode);
2429 This = (*mode == 'w');
2431 if (doexec && PL_tainting) {
2433 taint_proper("Insecure %s%s", "EXEC");
2435 if (PerlProc_pipe(p) < 0)
2437 if (doexec && PerlProc_pipe(pp) >= 0)
2439 while ((pid = PerlProc_fork()) < 0) {
2440 if (errno != EAGAIN) {
2441 PerlLIO_close(p[This]);
2442 PerlLIO_close(p[that]);
2444 PerlLIO_close(pp[0]);
2445 PerlLIO_close(pp[1]);
2448 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2451 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2462 PerlLIO_close(pp[0]);
2463 #if defined(HAS_FCNTL) && defined(F_SETFD)
2464 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2467 if (p[THIS] != (*mode == 'r')) {
2468 PerlLIO_dup2(p[THIS], *mode == 'r');
2469 PerlLIO_close(p[THIS]);
2470 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2471 PerlLIO_close(p[THAT]);
2474 PerlLIO_close(p[THAT]);
2477 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2484 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2489 /* may or may not use the shell */
2490 do_exec3(cmd, pp[1], did_pipes);
2493 #endif /* defined OS2 */
2495 #ifdef PERLIO_USING_CRLF
2496 /* Since we circumvent IO layers when we manipulate low-level
2497 filedescriptors directly, need to manually switch to the
2498 default, binary, low-level mode; see PerlIOBuf_open(). */
2499 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2502 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2503 SvREADONLY_off(GvSV(tmpgv));
2504 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2505 SvREADONLY_on(GvSV(tmpgv));
2507 #ifdef THREADS_HAVE_PIDS
2508 PL_ppid = (IV)getppid();
2511 #ifdef PERL_USES_PL_PIDSTATUS
2512 hv_clear(PL_pidstatus); /* we have no children */
2518 do_execfree(); /* free any memory malloced by child on vfork */
2520 PerlLIO_close(pp[1]);
2521 if (p[that] < p[This]) {
2522 PerlLIO_dup2(p[This], p[that]);
2523 PerlLIO_close(p[This]);
2527 PerlLIO_close(p[that]);
2529 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2530 SvUPGRADE(sv,SVt_IV);
2532 PL_forkprocess = pid;
2533 if (did_pipes && pid > 0) {
2538 while (n < sizeof(int)) {
2539 n1 = PerlLIO_read(pp[0],
2540 (void*)(((char*)&errkid)+n),
2546 PerlLIO_close(pp[0]);
2548 if (n) { /* Error */
2550 PerlLIO_close(p[This]);
2551 if (n != sizeof(int))
2552 Perl_croak(aTHX_ "panic: kid popen errno read");
2554 pid2 = wait4pid(pid, &status, 0);
2555 } while (pid2 == -1 && errno == EINTR);
2556 errno = errkid; /* Propagate errno from kid */
2561 PerlLIO_close(pp[0]);
2562 return PerlIO_fdopen(p[This], mode);
2565 #if defined(atarist) || defined(EPOC)
2568 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2570 PERL_ARGS_ASSERT_MY_POPEN;
2571 PERL_FLUSHALL_FOR_CHILD;
2572 /* Call system's popen() to get a FILE *, then import it.
2573 used 0 for 2nd parameter to PerlIO_importFILE;
2576 return PerlIO_importFILE(popen(cmd, mode), 0);
2580 FILE *djgpp_popen();
2582 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2584 PERL_FLUSHALL_FOR_CHILD;
2585 /* Call system's popen() to get a FILE *, then import it.
2586 used 0 for 2nd parameter to PerlIO_importFILE;
2589 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2592 #if defined(__LIBCATAMOUNT__)
2594 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2602 #endif /* !DOSISH */
2604 /* this is called in parent before the fork() */
2606 Perl_atfork_lock(void)
2609 #if defined(USE_ITHREADS)
2610 /* locks must be held in locking order (if any) */
2612 MUTEX_LOCK(&PL_malloc_mutex);
2618 /* this is called in both parent and child after the fork() */
2620 Perl_atfork_unlock(void)
2623 #if defined(USE_ITHREADS)
2624 /* locks must be released in same order as in atfork_lock() */
2626 MUTEX_UNLOCK(&PL_malloc_mutex);
2635 #if defined(HAS_FORK)
2637 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2642 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2643 * handlers elsewhere in the code */
2648 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2649 Perl_croak_nocontext("fork() not available");
2651 #endif /* HAS_FORK */
2656 Perl_dump_fds(pTHX_ const char *const s)
2661 PERL_ARGS_ASSERT_DUMP_FDS;
2663 PerlIO_printf(Perl_debug_log,"%s", s);
2664 for (fd = 0; fd < 32; fd++) {
2665 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2666 PerlIO_printf(Perl_debug_log," %d",fd);
2668 PerlIO_printf(Perl_debug_log,"\n");
2671 #endif /* DUMP_FDS */
2675 dup2(int oldfd, int newfd)
2677 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2680 PerlLIO_close(newfd);
2681 return fcntl(oldfd, F_DUPFD, newfd);
2683 #define DUP2_MAX_FDS 256
2684 int fdtmp[DUP2_MAX_FDS];
2690 PerlLIO_close(newfd);
2691 /* good enough for low fd's... */
2692 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2693 if (fdx >= DUP2_MAX_FDS) {
2701 PerlLIO_close(fdtmp[--fdx]);
2708 #ifdef HAS_SIGACTION
2711 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2714 struct sigaction act, oact;
2717 /* only "parent" interpreter can diddle signals */
2718 if (PL_curinterp != aTHX)
2719 return (Sighandler_t) SIG_ERR;
2722 act.sa_handler = (void(*)(int))handler;
2723 sigemptyset(&act.sa_mask);
2726 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2727 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2729 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2730 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2731 act.sa_flags |= SA_NOCLDWAIT;
2733 if (sigaction(signo, &act, &oact) == -1)
2734 return (Sighandler_t) SIG_ERR;
2736 return (Sighandler_t) oact.sa_handler;
2740 Perl_rsignal_state(pTHX_ int signo)
2742 struct sigaction oact;
2743 PERL_UNUSED_CONTEXT;
2745 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2746 return (Sighandler_t) SIG_ERR;
2748 return (Sighandler_t) oact.sa_handler;
2752 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2755 struct sigaction act;
2757 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2760 /* only "parent" interpreter can diddle signals */
2761 if (PL_curinterp != aTHX)
2765 act.sa_handler = (void(*)(int))handler;
2766 sigemptyset(&act.sa_mask);
2769 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2770 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2772 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2773 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2774 act.sa_flags |= SA_NOCLDWAIT;
2776 return sigaction(signo, &act, save);
2780 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2784 /* only "parent" interpreter can diddle signals */
2785 if (PL_curinterp != aTHX)
2789 return sigaction(signo, save, (struct sigaction *)NULL);
2792 #else /* !HAS_SIGACTION */
2795 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2797 #if defined(USE_ITHREADS) && !defined(WIN32)
2798 /* only "parent" interpreter can diddle signals */
2799 if (PL_curinterp != aTHX)
2800 return (Sighandler_t) SIG_ERR;
2803 return PerlProc_signal(signo, handler);
2814 Perl_rsignal_state(pTHX_ int signo)
2817 Sighandler_t oldsig;
2819 #if defined(USE_ITHREADS) && !defined(WIN32)
2820 /* only "parent" interpreter can diddle signals */
2821 if (PL_curinterp != aTHX)
2822 return (Sighandler_t) SIG_ERR;
2826 oldsig = PerlProc_signal(signo, sig_trap);
2827 PerlProc_signal(signo, oldsig);
2829 PerlProc_kill(PerlProc_getpid(), signo);
2834 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2836 #if defined(USE_ITHREADS) && !defined(WIN32)
2837 /* only "parent" interpreter can diddle signals */
2838 if (PL_curinterp != aTHX)
2841 *save = PerlProc_signal(signo, handler);
2842 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2846 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2848 #if defined(USE_ITHREADS) && !defined(WIN32)
2849 /* only "parent" interpreter can diddle signals */
2850 if (PL_curinterp != aTHX)
2853 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2856 #endif /* !HAS_SIGACTION */
2857 #endif /* !PERL_MICRO */
2859 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2860 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2862 Perl_my_pclose(pTHX_ PerlIO *ptr)
2865 Sigsave_t hstat, istat, qstat;
2873 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2874 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2876 *svp = &PL_sv_undef;
2878 if (pid == -1) { /* Opened by popen. */
2879 return my_syspclose(ptr);
2882 close_failed = (PerlIO_close(ptr) == EOF);
2885 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2888 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2889 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2890 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2893 pid2 = wait4pid(pid, &status, 0);
2894 } while (pid2 == -1 && errno == EINTR);
2896 rsignal_restore(SIGHUP, &hstat);
2897 rsignal_restore(SIGINT, &istat);
2898 rsignal_restore(SIGQUIT, &qstat);
2904 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2907 #if defined(__LIBCATAMOUNT__)
2909 Perl_my_pclose(pTHX_ PerlIO *ptr)
2914 #endif /* !DOSISH */
2916 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2918 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2922 PERL_ARGS_ASSERT_WAIT4PID;
2925 #ifdef PERL_USES_PL_PIDSTATUS
2928 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2929 pid, rather than a string form. */
2930 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2931 if (svp && *svp != &PL_sv_undef) {
2932 *statusp = SvIVX(*svp);
2933 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2941 hv_iterinit(PL_pidstatus);
2942 if ((entry = hv_iternext(PL_pidstatus))) {
2943 SV * const sv = hv_iterval(PL_pidstatus,entry);
2945 const char * const spid = hv_iterkey(entry,&len);
2947 assert (len == sizeof(Pid_t));
2948 memcpy((char *)&pid, spid, len);
2949 *statusp = SvIVX(sv);
2950 /* The hash iterator is currently on this entry, so simply
2951 calling hv_delete would trigger the lazy delete, which on
2952 aggregate does more work, beacuse next call to hv_iterinit()
2953 would spot the flag, and have to call the delete routine,
2954 while in the meantime any new entries can't re-use that
2956 hv_iterinit(PL_pidstatus);
2957 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2964 # ifdef HAS_WAITPID_RUNTIME
2965 if (!HAS_WAITPID_RUNTIME)
2968 result = PerlProc_waitpid(pid,statusp,flags);
2971 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2972 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2975 #ifdef PERL_USES_PL_PIDSTATUS
2976 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2981 Perl_croak(aTHX_ "Can't do waitpid with flags");
2983 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2984 pidgone(result,*statusp);
2990 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2993 if (result < 0 && errno == EINTR) {
2995 errno = EINTR; /* reset in case a signal handler changed $! */
2999 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3001 #ifdef PERL_USES_PL_PIDSTATUS
3003 S_pidgone(pTHX_ Pid_t pid, int status)
3007 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3008 SvUPGRADE(sv,SVt_IV);
3009 SvIV_set(sv, status);
3014 #if defined(atarist) || defined(OS2) || defined(EPOC)
3017 int /* Cannot prototype with I32
3019 my_syspclose(PerlIO *ptr)
3022 Perl_my_pclose(pTHX_ PerlIO *ptr)
3025 /* Needs work for PerlIO ! */
3026 FILE * const f = PerlIO_findFILE(ptr);
3027 const I32 result = pclose(f);
3028 PerlIO_releaseFILE(ptr,f);
3036 Perl_my_pclose(pTHX_ PerlIO *ptr)
3038 /* Needs work for PerlIO ! */
3039 FILE * const f = PerlIO_findFILE(ptr);
3040 I32 result = djgpp_pclose(f);
3041 result = (result << 8) & 0xff00;
3042 PerlIO_releaseFILE(ptr,f);
3047 #define PERL_REPEATCPY_LINEAR 4
3049 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3051 PERL_ARGS_ASSERT_REPEATCPY;
3054 memset(to, *from, count);
3056 register char *p = to;
3057 I32 items, linear, half;
3059 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3060 for (items = 0; items < linear; ++items) {
3061 register const char *q = from;
3063 for (todo = len; todo > 0; todo--)
3068 while (items <= half) {
3069 I32 size = items * len;
3070 memcpy(p, to, size);
3076 memcpy(p, to, (count - items) * len);
3082 Perl_same_dirent(pTHX_ const char *a, const char *b)
3084 char *fa = strrchr(a,'/');
3085 char *fb = strrchr(b,'/');
3088 SV * const tmpsv = sv_newmortal();
3090 PERL_ARGS_ASSERT_SAME_DIRENT;
3103 sv_setpvs(tmpsv, ".");
3105 sv_setpvn(tmpsv, a, fa - a);
3106 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3109 sv_setpvs(tmpsv, ".");
3111 sv_setpvn(tmpsv, b, fb - b);
3112 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3114 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3115 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3117 #endif /* !HAS_RENAME */
3120 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3121 const char *const *const search_ext, I32 flags)
3124 const char *xfound = NULL;
3125 char *xfailed = NULL;
3126 char tmpbuf[MAXPATHLEN];
3131 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3132 # define SEARCH_EXTS ".bat", ".cmd", NULL
3133 # define MAX_EXT_LEN 4
3136 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3137 # define MAX_EXT_LEN 4
3140 # define SEARCH_EXTS ".pl", ".com", NULL
3141 # define MAX_EXT_LEN 4
3143 /* additional extensions to try in each dir if scriptname not found */
3145 static const char *const exts[] = { SEARCH_EXTS };
3146 const char *const *const ext = search_ext ? search_ext : exts;
3147 int extidx = 0, i = 0;
3148 const char *curext = NULL;
3150 PERL_UNUSED_ARG(search_ext);
3151 # define MAX_EXT_LEN 0
3154 PERL_ARGS_ASSERT_FIND_SCRIPT;
3157 * If dosearch is true and if scriptname does not contain path
3158 * delimiters, search the PATH for scriptname.
3160 * If SEARCH_EXTS is also defined, will look for each
3161 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3162 * while searching the PATH.
3164 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3165 * proceeds as follows:
3166 * If DOSISH or VMSISH:
3167 * + look for ./scriptname{,.foo,.bar}
3168 * + search the PATH for scriptname{,.foo,.bar}
3171 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3172 * this will not look in '.' if it's not in the PATH)
3177 # ifdef ALWAYS_DEFTYPES
3178 len = strlen(scriptname);
3179 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3180 int idx = 0, deftypes = 1;
3183 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3186 int idx = 0, deftypes = 1;
3189 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3191 /* The first time through, just add SEARCH_EXTS to whatever we
3192 * already have, so we can check for default file types. */
3194 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3200 if ((strlen(tmpbuf) + strlen(scriptname)
3201 + MAX_EXT_LEN) >= sizeof tmpbuf)
3202 continue; /* don't search dir with too-long name */
3203 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3207 if (strEQ(scriptname, "-"))
3209 if (dosearch) { /* Look in '.' first. */
3210 const char *cur = scriptname;
3212 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3214 if (strEQ(ext[i++],curext)) {
3215 extidx = -1; /* already has an ext */
3220 DEBUG_p(PerlIO_printf(Perl_debug_log,
3221 "Looking for %s\n",cur));
3222 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3223 && !S_ISDIR(PL_statbuf.st_mode)) {
3231 if (cur == scriptname) {
3232 len = strlen(scriptname);
3233 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3235 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3238 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3239 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3244 if (dosearch && !strchr(scriptname, '/')
3246 && !strchr(scriptname, '\\')
3248 && (s = PerlEnv_getenv("PATH")))
3252 bufend = s + strlen(s);
3253 while (s < bufend) {
3254 #if defined(atarist) || defined(DOSISH)
3259 && *s != ';'; len++, s++) {
3260 if (len < sizeof tmpbuf)
3263 if (len < sizeof tmpbuf)
3265 #else /* ! (atarist || DOSISH) */
3266 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3269 #endif /* ! (atarist || DOSISH) */
3272 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3273 continue; /* don't search dir with too-long name */
3275 # if defined(atarist) || defined(DOSISH)
3276 && tmpbuf[len - 1] != '/'
3277 && tmpbuf[len - 1] != '\\'
3280 tmpbuf[len++] = '/';
3281 if (len == 2 && tmpbuf[0] == '.')
3283 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3287 len = strlen(tmpbuf);
3288 if (extidx > 0) /* reset after previous loop */
3292 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3293 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3294 if (S_ISDIR(PL_statbuf.st_mode)) {
3298 } while ( retval < 0 /* not there */
3299 && extidx>=0 && ext[extidx] /* try an extension? */
3300 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3305 if (S_ISREG(PL_statbuf.st_mode)
3306 && cando(S_IRUSR,TRUE,&PL_statbuf)
3307 #if !defined(DOSISH)
3308 && cando(S_IXUSR,TRUE,&PL_statbuf)
3312 xfound = tmpbuf; /* bingo! */
3316 xfailed = savepv(tmpbuf);
3319 if (!xfound && !seen_dot && !xfailed &&
3320 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3321 || S_ISDIR(PL_statbuf.st_mode)))
3323 seen_dot = 1; /* Disable message. */
3325 if (flags & 1) { /* do or die? */
3326 Perl_croak(aTHX_ "Can't %s %s%s%s",
3327 (xfailed ? "execute" : "find"),
3328 (xfailed ? xfailed : scriptname),
3329 (xfailed ? "" : " on PATH"),
3330 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3335 scriptname = xfound;
3337 return (scriptname ? savepv(scriptname) : NULL);
3340 #ifndef PERL_GET_CONTEXT_DEFINED
3343 Perl_get_context(void)
3346 #if defined(USE_ITHREADS)
3347 # ifdef OLD_PTHREADS_API
3349 if (pthread_getspecific(PL_thr_key, &t))
3350 Perl_croak_nocontext("panic: pthread_getspecific");
3353 # ifdef I_MACH_CTHREADS
3354 return (void*)cthread_data(cthread_self());
3356 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3365 Perl_set_context(void *t)
3368 PERL_ARGS_ASSERT_SET_CONTEXT;
3369 #if defined(USE_ITHREADS)
3370 # ifdef I_MACH_CTHREADS
3371 cthread_set_data(cthread_self(), t);
3373 if (pthread_setspecific(PL_thr_key, t))
3374 Perl_croak_nocontext("panic: pthread_setspecific");
3381 #endif /* !PERL_GET_CONTEXT_DEFINED */
3383 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3392 Perl_get_op_names(pTHX)
3394 PERL_UNUSED_CONTEXT;
3395 return (char **)PL_op_name;
3399 Perl_get_op_descs(pTHX)
3401 PERL_UNUSED_CONTEXT;
3402 return (char **)PL_op_desc;
3406 Perl_get_no_modify(pTHX)
3408 PERL_UNUSED_CONTEXT;
3409 return PL_no_modify;
3413 Perl_get_opargs(pTHX)
3415 PERL_UNUSED_CONTEXT;
3416 return (U32 *)PL_opargs;
3420 Perl_get_ppaddr(pTHX)
3423 PERL_UNUSED_CONTEXT;
3424 return (PPADDR_t*)PL_ppaddr;
3427 #ifndef HAS_GETENV_LEN
3429 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3431 char * const env_trans = PerlEnv_getenv(env_elem);
3432 PERL_UNUSED_CONTEXT;
3433 PERL_ARGS_ASSERT_GETENV_LEN;
3435 *len = strlen(env_trans);
3442 Perl_get_vtbl(pTHX_ int vtbl_id)
3444 const MGVTBL* result;
3445 PERL_UNUSED_CONTEXT;
3449 result = &PL_vtbl_sv;
3452 result = &PL_vtbl_env;
3454 case want_vtbl_envelem:
3455 result = &PL_vtbl_envelem;
3458 result = &PL_vtbl_sig;
3460 case want_vtbl_sigelem:
3461 result = &PL_vtbl_sigelem;
3463 case want_vtbl_pack:
3464 result = &PL_vtbl_pack;
3466 case want_vtbl_packelem:
3467 result = &PL_vtbl_packelem;
3469 case want_vtbl_dbline:
3470 result = &PL_vtbl_dbline;
3473 result = &PL_vtbl_isa;
3475 case want_vtbl_isaelem:
3476 result = &PL_vtbl_isaelem;
3478 case want_vtbl_arylen:
3479 result = &PL_vtbl_arylen;
3481 case want_vtbl_mglob:
3482 result = &PL_vtbl_mglob;
3484 case want_vtbl_nkeys:
3485 result = &PL_vtbl_nkeys;
3487 case want_vtbl_taint:
3488 result = &PL_vtbl_taint;
3490 case want_vtbl_substr:
3491 result = &PL_vtbl_substr;
3494 result = &PL_vtbl_vec;
3497 result = &PL_vtbl_pos;
3500 result = &PL_vtbl_bm;
3503 result = &PL_vtbl_fm;
3505 case want_vtbl_uvar:
3506 result = &PL_vtbl_uvar;
3508 case want_vtbl_defelem:
3509 result = &PL_vtbl_defelem;
3511 case want_vtbl_regexp:
3512 result = &PL_vtbl_regexp;
3514 case want_vtbl_regdata:
3515 result = &PL_vtbl_regdata;
3517 case want_vtbl_regdatum:
3518 result = &PL_vtbl_regdatum;
3520 #ifdef USE_LOCALE_COLLATE
3521 case want_vtbl_collxfrm:
3522 result = &PL_vtbl_collxfrm;
3525 case want_vtbl_amagic:
3526 result = &PL_vtbl_amagic;
3528 case want_vtbl_amagicelem:
3529 result = &PL_vtbl_amagicelem;
3531 case want_vtbl_backref:
3532 result = &PL_vtbl_backref;
3534 case want_vtbl_utf8:
3535 result = &PL_vtbl_utf8;
3541 return (MGVTBL*)result;
3545 Perl_my_fflush_all(pTHX)
3547 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3548 return PerlIO_flush(NULL);
3550 # if defined(HAS__FWALK)
3551 extern int fflush(FILE *);
3552 /* undocumented, unprototyped, but very useful BSDism */
3553 extern void _fwalk(int (*)(FILE *));
3557 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3559 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3560 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3562 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3563 open_max = sysconf(_SC_OPEN_MAX);
3566 open_max = FOPEN_MAX;
3569 open_max = OPEN_MAX;
3580 for (i = 0; i < open_max; i++)
3581 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3582 STDIO_STREAM_ARRAY[i]._file < open_max &&
3583 STDIO_STREAM_ARRAY[i]._flag)
3584 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3588 SETERRNO(EBADF,RMS_IFI);
3595 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3597 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3599 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3600 if (ckWARN(WARN_IO)) {
3601 const char * const direction =
3602 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3604 Perl_warner(aTHX_ packWARN(WARN_IO),
3605 "Filehandle %s opened only for %sput",
3608 Perl_warner(aTHX_ packWARN(WARN_IO),
3609 "Filehandle opened only for %sput", direction);
3616 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3618 warn_type = WARN_CLOSED;
3622 warn_type = WARN_UNOPENED;
3625 if (ckWARN(warn_type)) {
3626 const char * const pars =
3627 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3628 const char * const func =
3630 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3631 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3632 op < 0 ? "" : /* handle phoney cases */
3634 const char * const type =
3636 (OP_IS_SOCKET(op) ||
3637 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3638 "socket" : "filehandle");
3639 if (name && *name) {
3640 Perl_warner(aTHX_ packWARN(warn_type),
3641 "%s%s on %s %s %s", func, pars, vile, type, name);
3642 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3644 aTHX_ packWARN(warn_type),
3645 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3650 Perl_warner(aTHX_ packWARN(warn_type),
3651 "%s%s on %s %s", func, pars, vile, type);
3652 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3654 aTHX_ packWARN(warn_type),
3655 "\t(Are you trying to call %s%s on dirhandle?)\n",
3664 /* in ASCII order, not that it matters */
3665 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3668 Perl_ebcdic_control(pTHX_ int ch)
3676 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3677 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3680 if (ctlp == controllablechars)
3681 return('\177'); /* DEL */
3683 return((unsigned char)(ctlp - controllablechars - 1));
3684 } else { /* Want uncontrol */
3685 if (ch == '\177' || ch == -1)
3687 else if (ch == '\157')
3689 else if (ch == '\174')
3691 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3693 else if (ch == '\155')
3695 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3696 return(controllablechars[ch+1]);
3698 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3703 /* To workaround core dumps from the uninitialised tm_zone we get the
3704 * system to give us a reasonable struct to copy. This fix means that
3705 * strftime uses the tm_zone and tm_gmtoff values returned by
3706 * localtime(time()). That should give the desired result most of the
3707 * time. But probably not always!
3709 * This does not address tzname aspects of NETaa14816.
3714 # ifndef STRUCT_TM_HASZONE
3715 # define STRUCT_TM_HASZONE
3719 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3720 # ifndef HAS_TM_TM_ZONE
3721 # define HAS_TM_TM_ZONE
3726 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3728 #ifdef HAS_TM_TM_ZONE
3730 const struct tm* my_tm;
3731 PERL_ARGS_ASSERT_INIT_TM;
3733 my_tm = localtime(&now);
3735 Copy(my_tm, ptm, 1, struct tm);
3737 PERL_ARGS_ASSERT_INIT_TM;
3738 PERL_UNUSED_ARG(ptm);
3743 * mini_mktime - normalise struct tm values without the localtime()
3744 * semantics (and overhead) of mktime().
3747 Perl_mini_mktime(pTHX_ struct tm *ptm)
3751 int month, mday, year, jday;
3752 int odd_cent, odd_year;
3753 PERL_UNUSED_CONTEXT;
3755 PERL_ARGS_ASSERT_MINI_MKTIME;
3757 #define DAYS_PER_YEAR 365
3758 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3759 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3760 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3761 #define SECS_PER_HOUR (60*60)
3762 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3763 /* parentheses deliberately absent on these two, otherwise they don't work */
3764 #define MONTH_TO_DAYS 153/5
3765 #define DAYS_TO_MONTH 5/153
3766 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3767 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3768 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3769 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3772 * Year/day algorithm notes:
3774 * With a suitable offset for numeric value of the month, one can find
3775 * an offset into the year by considering months to have 30.6 (153/5) days,
3776 * using integer arithmetic (i.e., with truncation). To avoid too much
3777 * messing about with leap days, we consider January and February to be
3778 * the 13th and 14th month of the previous year. After that transformation,
3779 * we need the month index we use to be high by 1 from 'normal human' usage,
3780 * so the month index values we use run from 4 through 15.
3782 * Given that, and the rules for the Gregorian calendar (leap years are those
3783 * divisible by 4 unless also divisible by 100, when they must be divisible
3784 * by 400 instead), we can simply calculate the number of days since some
3785 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3786 * the days we derive from our month index, and adding in the day of the
3787 * month. The value used here is not adjusted for the actual origin which
3788 * it normally would use (1 January A.D. 1), since we're not exposing it.
3789 * We're only building the value so we can turn around and get the
3790 * normalised values for the year, month, day-of-month, and day-of-year.
3792 * For going backward, we need to bias the value we're using so that we find
3793 * the right year value. (Basically, we don't want the contribution of
3794 * March 1st to the number to apply while deriving the year). Having done
3795 * that, we 'count up' the contribution to the year number by accounting for
3796 * full quadracenturies (400-year periods) with their extra leap days, plus
3797 * the contribution from full centuries (to avoid counting in the lost leap
3798 * days), plus the contribution from full quad-years (to count in the normal
3799 * leap days), plus the leftover contribution from any non-leap years.
3800 * At this point, if we were working with an actual leap day, we'll have 0
3801 * days left over. This is also true for March 1st, however. So, we have
3802 * to special-case that result, and (earlier) keep track of the 'odd'
3803 * century and year contributions. If we got 4 extra centuries in a qcent,
3804 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3805 * Otherwise, we add back in the earlier bias we removed (the 123 from
3806 * figuring in March 1st), find the month index (integer division by 30.6),
3807 * and the remainder is the day-of-month. We then have to convert back to
3808 * 'real' months (including fixing January and February from being 14/15 in
3809 * the previous year to being in the proper year). After that, to get
3810 * tm_yday, we work with the normalised year and get a new yearday value for
3811 * January 1st, which we subtract from the yearday value we had earlier,
3812 * representing the date we've re-built. This is done from January 1
3813 * because tm_yday is 0-origin.
3815 * Since POSIX time routines are only guaranteed to work for times since the
3816 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3817 * applies Gregorian calendar rules even to dates before the 16th century
3818 * doesn't bother me. Besides, you'd need cultural context for a given
3819 * date to know whether it was Julian or Gregorian calendar, and that's
3820 * outside the scope for this routine. Since we convert back based on the
3821 * same rules we used to build the yearday, you'll only get strange results
3822 * for input which needed normalising, or for the 'odd' century years which
3823 * were leap years in the Julian calander but not in the Gregorian one.
3824 * I can live with that.
3826 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3827 * that's still outside the scope for POSIX time manipulation, so I don't
3831 year = 1900 + ptm->tm_year;
3832 month = ptm->tm_mon;
3833 mday = ptm->tm_mday;
3834 /* allow given yday with no month & mday to dominate the result */
3835 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3838 jday = 1 + ptm->tm_yday;
3847 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3848 yearday += month*MONTH_TO_DAYS + mday + jday;
3850 * Note that we don't know when leap-seconds were or will be,
3851 * so we have to trust the user if we get something which looks
3852 * like a sensible leap-second. Wild values for seconds will
3853 * be rationalised, however.
3855 if ((unsigned) ptm->tm_sec <= 60) {
3862 secs += 60 * ptm->tm_min;
3863 secs += SECS_PER_HOUR * ptm->tm_hour;
3865 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3866 /* got negative remainder, but need positive time */
3867 /* back off an extra day to compensate */
3868 yearday += (secs/SECS_PER_DAY)-1;
3869 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3872 yearday += (secs/SECS_PER_DAY);
3873 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3876 else if (secs >= SECS_PER_DAY) {
3877 yearday += (secs/SECS_PER_DAY);
3878 secs %= SECS_PER_DAY;
3880 ptm->tm_hour = secs/SECS_PER_HOUR;
3881 secs %= SECS_PER_HOUR;
3882 ptm->tm_min = secs/60;
3884 ptm->tm_sec += secs;
3885 /* done with time of day effects */
3887 * The algorithm for yearday has (so far) left it high by 428.
3888 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3889 * bias it by 123 while trying to figure out what year it
3890 * really represents. Even with this tweak, the reverse
3891 * translation fails for years before A.D. 0001.
3892 * It would still fail for Feb 29, but we catch that one below.
3894 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3895 yearday -= YEAR_ADJUST;
3896 year = (yearday / DAYS_PER_QCENT) * 400;
3897 yearday %= DAYS_PER_QCENT;
3898 odd_cent = yearday / DAYS_PER_CENT;
3899 year += odd_cent * 100;
3900 yearday %= DAYS_PER_CENT;
3901 year += (yearday / DAYS_PER_QYEAR) * 4;
3902 yearday %= DAYS_PER_QYEAR;
3903 odd_year = yearday / DAYS_PER_YEAR;
3905 yearday %= DAYS_PER_YEAR;
3906 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3911 yearday += YEAR_ADJUST; /* recover March 1st crock */
3912 month = yearday*DAYS_TO_MONTH;
3913 yearday -= month*MONTH_TO_DAYS;
3914 /* recover other leap-year adjustment */
3923 ptm->tm_year = year - 1900;
3925 ptm->tm_mday = yearday;
3926 ptm->tm_mon = month;
3930 ptm->tm_mon = month - 1;
3932 /* re-build yearday based on Jan 1 to get tm_yday */
3934 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3935 yearday += 14*MONTH_TO_DAYS + 1;
3936 ptm->tm_yday = jday - yearday;
3937 /* fix tm_wday if not overridden by caller */
3938 if ((unsigned)ptm->tm_wday > 6)
3939 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3943 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)
3951 PERL_ARGS_ASSERT_MY_STRFTIME;
3953 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3956 mytm.tm_hour = hour;
3957 mytm.tm_mday = mday;
3959 mytm.tm_year = year;
3960 mytm.tm_wday = wday;
3961 mytm.tm_yday = yday;
3962 mytm.tm_isdst = isdst;
3964 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3965 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3970 #ifdef HAS_TM_TM_GMTOFF
3971 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3973 #ifdef HAS_TM_TM_ZONE
3974 mytm.tm_zone = mytm2.tm_zone;
3979 Newx(buf, buflen, char);
3980 len = strftime(buf, buflen, fmt, &mytm);
3982 ** The following is needed to handle to the situation where
3983 ** tmpbuf overflows. Basically we want to allocate a buffer
3984 ** and try repeatedly. The reason why it is so complicated
3985 ** is that getting a return value of 0 from strftime can indicate
3986 ** one of the following:
3987 ** 1. buffer overflowed,
3988 ** 2. illegal conversion specifier, or
3989 ** 3. the format string specifies nothing to be returned(not
3990 ** an error). This could be because format is an empty string
3991 ** or it specifies %p that yields an empty string in some locale.
3992 ** If there is a better way to make it portable, go ahead by
3995 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3998 /* Possibly buf overflowed - try again with a bigger buf */
3999 const int fmtlen = strlen(fmt);
4000 int bufsize = fmtlen + buflen;
4002 Newx(buf, bufsize, char);
4004 buflen = strftime(buf, bufsize, fmt, &mytm);
4005 if (buflen > 0 && buflen < bufsize)
4007 /* heuristic to prevent out-of-memory errors */
4008 if (bufsize > 100*fmtlen) {
4014 Renew(buf, bufsize, char);
4019 Perl_croak(aTHX_ "panic: no strftime");
4025 #define SV_CWD_RETURN_UNDEF \
4026 sv_setsv(sv, &PL_sv_undef); \
4029 #define SV_CWD_ISDOT(dp) \
4030 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4031 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4034 =head1 Miscellaneous Functions
4036 =for apidoc getcwd_sv
4038 Fill the sv with current working directory
4043 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4044 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4045 * getcwd(3) if available
4046 * Comments from the orignal:
4047 * This is a faster version of getcwd. It's also more dangerous
4048 * because you might chdir out of a directory that you can't chdir
4052 Perl_getcwd_sv(pTHX_ register SV *sv)
4056 #ifndef INCOMPLETE_TAINTS
4060 PERL_ARGS_ASSERT_GETCWD_SV;
4064 char buf[MAXPATHLEN];
4066 /* Some getcwd()s automatically allocate a buffer of the given
4067 * size from the heap if they are given a NULL buffer pointer.
4068 * The problem is that this behaviour is not portable. */
4069 if (getcwd(buf, sizeof(buf) - 1)) {
4074 sv_setsv(sv, &PL_sv_undef);
4082 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4086 SvUPGRADE(sv, SVt_PV);
4088 if (PerlLIO_lstat(".", &statbuf) < 0) {
4089 SV_CWD_RETURN_UNDEF;
4092 orig_cdev = statbuf.st_dev;
4093 orig_cino = statbuf.st_ino;
4103 if (PerlDir_chdir("..") < 0) {
4104 SV_CWD_RETURN_UNDEF;
4106 if (PerlLIO_stat(".", &statbuf) < 0) {
4107 SV_CWD_RETURN_UNDEF;
4110 cdev = statbuf.st_dev;
4111 cino = statbuf.st_ino;
4113 if (odev == cdev && oino == cino) {
4116 if (!(dir = PerlDir_open("."))) {
4117 SV_CWD_RETURN_UNDEF;
4120 while ((dp = PerlDir_read(dir)) != NULL) {
4122 namelen = dp->d_namlen;
4124 namelen = strlen(dp->d_name);
4127 if (SV_CWD_ISDOT(dp)) {
4131 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4132 SV_CWD_RETURN_UNDEF;
4135 tdev = statbuf.st_dev;
4136 tino = statbuf.st_ino;
4137 if (tino == oino && tdev == odev) {
4143 SV_CWD_RETURN_UNDEF;
4146 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4147 SV_CWD_RETURN_UNDEF;
4150 SvGROW(sv, pathlen + namelen + 1);
4154 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4157 /* prepend current directory to the front */
4159 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4160 pathlen += (namelen + 1);
4162 #ifdef VOID_CLOSEDIR
4165 if (PerlDir_close(dir) < 0) {
4166 SV_CWD_RETURN_UNDEF;
4172 SvCUR_set(sv, pathlen);
4176 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4177 SV_CWD_RETURN_UNDEF;
4180 if (PerlLIO_stat(".", &statbuf) < 0) {
4181 SV_CWD_RETURN_UNDEF;
4184 cdev = statbuf.st_dev;
4185 cino = statbuf.st_ino;
4187 if (cdev != orig_cdev || cino != orig_cino) {
4188 Perl_croak(aTHX_ "Unstable directory path, "
4189 "current directory changed unexpectedly");
4200 #define VERSION_MAX 0x7FFFFFFF
4202 =for apidoc scan_version
4204 Returns a pointer to the next character after the parsed
4205 version string, as well as upgrading the passed in SV to
4208 Function must be called with an already existing SV like
4211 s = scan_version(s, SV *sv, bool qv);
4213 Performs some preprocessing to the string to ensure that
4214 it has the correct characteristics of a version. Flags the
4215 object if it contains an underscore (which denotes this
4216 is an alpha version). The boolean qv denotes that the version
4217 should be interpreted as if it had multiple decimals, even if
4224 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4233 AV * const av = newAV();
4234 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4236 PERL_ARGS_ASSERT_SCAN_VERSION;
4238 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4240 while (isSPACE(*s)) /* leading whitespace is OK */
4246 s++; /* get past 'v' */
4247 qv = 1; /* force quoted version processing */
4252 /* pre-scan the input string to check for decimals/underbars */
4253 while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
4258 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4262 else if ( *pos == '_' )
4265 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4267 width = pos - last - 1; /* natural width of sub-version */
4269 else if ( *pos == ',' && isDIGIT(pos[1]) )
4278 if ( alpha && !saw_period )
4279 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4281 if ( alpha && saw_period && width == 0 )
4282 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4284 if ( saw_period > 1 )
4285 qv = 1; /* force quoted version processing */
4291 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4293 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4294 if ( !qv && width < 3 )
4295 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4297 while (isDIGIT(*pos))
4299 if (!isALPHA(*pos)) {
4305 /* this is atoi() that delimits on underscores */
4306 const char *end = pos;
4310 /* the following if() will only be true after the decimal
4311 * point of a version originally created with a bare
4312 * floating point number, i.e. not quoted in any way
4314 if ( !qv && s > start && saw_period == 1 ) {
4318 rev += (*s - '0') * mult;
4320 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4321 || (PERL_ABS(rev) > VERSION_MAX )) {
4322 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4323 "Integer overflow in version %d",VERSION_MAX);
4334 while (--end >= s) {
4336 rev += (*end - '0') * mult;
4338 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4339 || (PERL_ABS(rev) > VERSION_MAX )) {
4340 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4341 "Integer overflow in version");
4350 /* Append revision */
4351 av_push(av, newSViv(rev));
4356 else if ( *pos == '.' )
4358 else if ( *pos == '_' && isDIGIT(pos[1]) )
4360 else if ( *pos == ',' && isDIGIT(pos[1]) )
4362 else if ( isDIGIT(*pos) )
4369 while ( isDIGIT(*pos) )
4374 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4382 if ( qv ) { /* quoted versions always get at least three terms*/
4383 I32 len = av_len(av);
4384 /* This for loop appears to trigger a compiler bug on OS X, as it
4385 loops infinitely. Yes, len is negative. No, it makes no sense.
4386 Compiler in question is:
4387 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4388 for ( len = 2 - len; len > 0; len-- )
4389 av_push(MUTABLE_AV(sv), newSViv(0));
4393 av_push(av, newSViv(0));
4396 /* need to save off the current version string for later */
4398 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4399 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4400 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4402 else if ( s > start ) {
4403 SV * orig = newSVpvn(start,s-start);
4404 if ( qv && saw_period == 1 && *start != 'v' ) {
4405 /* need to insert a v to be consistent */
4406 sv_insert(orig, 0, 0, "v", 1);
4408 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4411 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4412 av_push(av, newSViv(0));
4415 /* And finally, store the AV in the hash */
4416 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4418 /* fix RT#19517 - special case 'undef' as string */
4419 if ( *s == 'u' && strEQ(s,"undef") ) {
4427 =for apidoc new_version
4429 Returns a new version object based on the passed in SV:
4431 SV *sv = new_version(SV *ver);
4433 Does not alter the passed in ver SV. See "upg_version" if you
4434 want to upgrade the SV.
4440 Perl_new_version(pTHX_ SV *ver)
4443 SV * const rv = newSV(0);
4444 PERL_ARGS_ASSERT_NEW_VERSION;
4445 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4448 AV * const av = newAV();
4450 /* This will get reblessed later if a derived class*/
4451 SV * const hv = newSVrv(rv, "version");
4452 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4457 /* Begin copying all of the elements */
4458 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4459 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4461 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4462 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4464 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4466 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4467 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4470 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4472 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4473 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4476 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4477 /* This will get reblessed later if a derived class*/
4478 for ( key = 0; key <= av_len(sav); key++ )
4480 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4481 av_push(av, newSViv(rev));
4484 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4489 const MAGIC* const mg = SvVSTRING_mg(ver);
4490 if ( mg ) { /* already a v-string */
4491 const STRLEN len = mg->mg_len;
4492 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4493 sv_setpvn(rv,version,len);
4494 /* this is for consistency with the pure Perl class */
4495 if ( *version != 'v' )
4496 sv_insert(rv, 0, 0, "v", 1);
4501 sv_setsv(rv,ver); /* make a duplicate */
4506 return upg_version(rv, FALSE);
4510 =for apidoc upg_version
4512 In-place upgrade of the supplied SV to a version object.
4514 SV *sv = upg_version(SV *sv, bool qv);
4516 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4517 to force this SV to be interpreted as an "extended" version.
4523 Perl_upg_version(pTHX_ SV *ver, bool qv)
4525 const char *version, *s;
4530 PERL_ARGS_ASSERT_UPG_VERSION;
4532 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4534 /* may get too much accuracy */
4536 #ifdef USE_LOCALE_NUMERIC
4537 char *loc = setlocale(LC_NUMERIC, "C");
4539 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4540 #ifdef USE_LOCALE_NUMERIC
4541 setlocale(LC_NUMERIC, loc);
4543 while (tbuf[len-1] == '0' && len > 0) len--;
4544 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4545 version = savepvn(tbuf, len);
4548 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4549 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4553 else /* must be a string or something like a string */
4556 version = savepv(SvPV(ver,len));
4558 # if PERL_VERSION > 5
4559 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4560 if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4561 /* may be a v-string */
4562 SV * const nsv = sv_newmortal();
4566 sv_setpvf(nsv,"v%vd",ver);
4567 pos = nver = savepv(SvPV_nolen(nsv));
4569 /* scan the resulting formatted string */
4570 pos++; /* skip the leading 'v' */
4571 while ( *pos == '.' || isDIGIT(*pos) ) {
4577 /* is definitely a v-string */
4578 if ( saw_period == 2 ) {
4587 s = scan_version(version, ver, qv);
4589 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4590 "Version string '%s' contains invalid data; "
4591 "ignoring: '%s'", version, s);
4599 Validates that the SV contains a valid version object.
4601 bool vverify(SV *vobj);
4603 Note that it only confirms the bare minimum structure (so as not to get
4604 confused by derived classes which may contain additional hash entries):
4608 =item * The SV contains a [reference to a] hash
4610 =item * The hash contains a "version" key
4612 =item * The "version" key has [a reference to] an AV as its value
4620 Perl_vverify(pTHX_ SV *vs)
4624 PERL_ARGS_ASSERT_VVERIFY;
4629 /* see if the appropriate elements exist */
4630 if ( SvTYPE(vs) == SVt_PVHV
4631 && hv_exists(MUTABLE_HV(vs), "version", 7)
4632 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4633 && SvTYPE(sv) == SVt_PVAV )
4642 Accepts a version object and returns the normalized floating
4643 point representation. Call like:
4647 NOTE: you can pass either the object directly or the SV
4648 contained within the RV.
4654 Perl_vnumify(pTHX_ SV *vs)
4659 SV * const sv = newSV(0);
4662 PERL_ARGS_ASSERT_VNUMIFY;
4668 Perl_croak(aTHX_ "Invalid version object");
4670 /* see if various flags exist */
4671 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4673 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4674 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4679 /* attempt to retrieve the version array */
4680 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4692 digit = SvIV(*av_fetch(av, 0, 0));
4693 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4694 for ( i = 1 ; i < len ; i++ )
4696 digit = SvIV(*av_fetch(av, i, 0));
4698 const int denom = (width == 2 ? 10 : 100);
4699 const div_t term = div((int)PERL_ABS(digit),denom);
4700 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4703 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4709 digit = SvIV(*av_fetch(av, len, 0));
4710 if ( alpha && width == 3 ) /* alpha version */
4712 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4716 sv_catpvs(sv, "000");
4724 Accepts a version object and returns the normalized string
4725 representation. Call like:
4729 NOTE: you can pass either the object directly or the SV
4730 contained within the RV.
4736 Perl_vnormal(pTHX_ SV *vs)
4740 SV * const sv = newSV(0);
4743 PERL_ARGS_ASSERT_VNORMAL;
4749 Perl_croak(aTHX_ "Invalid version object");
4751 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4753 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4761 digit = SvIV(*av_fetch(av, 0, 0));
4762 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4763 for ( i = 1 ; i < len ; i++ ) {
4764 digit = SvIV(*av_fetch(av, i, 0));
4765 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4770 /* handle last digit specially */
4771 digit = SvIV(*av_fetch(av, len, 0));
4773 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4775 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4778 if ( len <= 2 ) { /* short version, must be at least three */
4779 for ( len = 2 - len; len != 0; len-- )
4786 =for apidoc vstringify
4788 In order to maintain maximum compatibility with earlier versions
4789 of Perl, this function will return either the floating point
4790 notation or the multiple dotted notation, depending on whether
4791 the original version contained 1 or more dots, respectively
4797 Perl_vstringify(pTHX_ SV *vs)
4799 PERL_ARGS_ASSERT_VSTRINGIFY;
4805 Perl_croak(aTHX_ "Invalid version object");
4807 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
4809 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4813 return &PL_sv_undef;
4816 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4826 Version object aware cmp. Both operands must already have been
4827 converted into version objects.
4833 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4836 bool lalpha = FALSE;
4837 bool ralpha = FALSE;
4842 PERL_ARGS_ASSERT_VCMP;
4849 if ( !vverify(lhv) )
4850 Perl_croak(aTHX_ "Invalid version object");
4852 if ( !vverify(rhv) )
4853 Perl_croak(aTHX_ "Invalid version object");
4855 /* get the left hand term */
4856 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4857 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4860 /* and the right hand term */
4861 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4862 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4870 while ( i <= m && retval == 0 )
4872 left = SvIV(*av_fetch(lav,i,0));
4873 right = SvIV(*av_fetch(rav,i,0));
4881 /* tiebreaker for alpha with identical terms */
4882 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4884 if ( lalpha && !ralpha )
4888 else if ( ralpha && !lalpha)
4894 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4898 while ( i <= r && retval == 0 )
4900 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4901 retval = -1; /* not a match after all */
4907 while ( i <= l && retval == 0 )
4909 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4910 retval = +1; /* not a match after all */
4918 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4919 # define EMULATE_SOCKETPAIR_UDP
4922 #ifdef EMULATE_SOCKETPAIR_UDP
4924 S_socketpair_udp (int fd[2]) {
4926 /* Fake a datagram socketpair using UDP to localhost. */
4927 int sockets[2] = {-1, -1};
4928 struct sockaddr_in addresses[2];
4930 Sock_size_t size = sizeof(struct sockaddr_in);
4931 unsigned short port;
4934 memset(&addresses, 0, sizeof(addresses));
4937 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4938 if (sockets[i] == -1)
4939 goto tidy_up_and_fail;
4941 addresses[i].sin_family = AF_INET;
4942 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4943 addresses[i].sin_port = 0; /* kernel choses port. */
4944 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4945 sizeof(struct sockaddr_in)) == -1)
4946 goto tidy_up_and_fail;
4949 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4950 for each connect the other socket to it. */
4953 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4955 goto tidy_up_and_fail;
4956 if (size != sizeof(struct sockaddr_in))
4957 goto abort_tidy_up_and_fail;
4958 /* !1 is 0, !0 is 1 */
4959 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4960 sizeof(struct sockaddr_in)) == -1)
4961 goto tidy_up_and_fail;
4964 /* Now we have 2 sockets connected to each other. I don't trust some other
4965 process not to have already sent a packet to us (by random) so send
4966 a packet from each to the other. */
4969 /* I'm going to send my own port number. As a short.
4970 (Who knows if someone somewhere has sin_port as a bitfield and needs
4971 this routine. (I'm assuming crays have socketpair)) */
4972 port = addresses[i].sin_port;
4973 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4974 if (got != sizeof(port)) {
4976 goto tidy_up_and_fail;
4977 goto abort_tidy_up_and_fail;
4981 /* Packets sent. I don't trust them to have arrived though.
4982 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4983 connect to localhost will use a second kernel thread. In 2.6 the
4984 first thread running the connect() returns before the second completes,
4985 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4986 returns 0. Poor programs have tripped up. One poor program's authors'
4987 had a 50-1 reverse stock split. Not sure how connected these were.)
4988 So I don't trust someone not to have an unpredictable UDP stack.
4992 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4993 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4997 FD_SET((unsigned int)sockets[0], &rset);
4998 FD_SET((unsigned int)sockets[1], &rset);
5000 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5001 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5002 || !FD_ISSET(sockets[1], &rset)) {
5003 /* I hope this is portable and appropriate. */
5005 goto tidy_up_and_fail;
5006 goto abort_tidy_up_and_fail;
5010 /* And the paranoia department even now doesn't trust it to have arrive
5011 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5013 struct sockaddr_in readfrom;
5014 unsigned short buffer[2];
5019 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5020 sizeof(buffer), MSG_DONTWAIT,
5021 (struct sockaddr *) &readfrom, &size);
5023 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5025 (struct sockaddr *) &readfrom, &size);
5029 goto tidy_up_and_fail;
5030 if (got != sizeof(port)
5031 || size != sizeof(struct sockaddr_in)
5032 /* Check other socket sent us its port. */
5033 || buffer[0] != (unsigned short) addresses[!i].sin_port
5034 /* Check kernel says we got the datagram from that socket */
5035 || readfrom.sin_family != addresses[!i].sin_family
5036 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5037 || readfrom.sin_port != addresses[!i].sin_port)
5038 goto abort_tidy_up_and_fail;
5041 /* My caller (my_socketpair) has validated that this is non-NULL */
5044 /* I hereby declare this connection open. May God bless all who cross
5048 abort_tidy_up_and_fail:
5049 errno = ECONNABORTED;
5053 if (sockets[0] != -1)
5054 PerlLIO_close(sockets[0]);
5055 if (sockets[1] != -1)
5056 PerlLIO_close(sockets[1]);
5061 #endif /* EMULATE_SOCKETPAIR_UDP */
5063 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5065 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5066 /* Stevens says that family must be AF_LOCAL, protocol 0.
5067 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5072 struct sockaddr_in listen_addr;
5073 struct sockaddr_in connect_addr;
5078 || family != AF_UNIX
5081 errno = EAFNOSUPPORT;
5089 #ifdef EMULATE_SOCKETPAIR_UDP
5090 if (type == SOCK_DGRAM)
5091 return S_socketpair_udp(fd);
5094 listener = PerlSock_socket(AF_INET, type, 0);
5097 memset(&listen_addr, 0, sizeof(listen_addr));
5098 listen_addr.sin_family = AF_INET;
5099 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5100 listen_addr.sin_port = 0; /* kernel choses port. */
5101 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5102 sizeof(listen_addr)) == -1)
5103 goto tidy_up_and_fail;
5104 if (PerlSock_listen(listener, 1) == -1)
5105 goto tidy_up_and_fail;
5107 connector = PerlSock_socket(AF_INET, type, 0);
5108 if (connector == -1)
5109 goto tidy_up_and_fail;
5110 /* We want to find out the port number to connect to. */
5111 size = sizeof(connect_addr);
5112 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5114 goto tidy_up_and_fail;
5115 if (size != sizeof(connect_addr))
5116 goto abort_tidy_up_and_fail;
5117 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5118 sizeof(connect_addr)) == -1)
5119 goto tidy_up_and_fail;
5121 size = sizeof(listen_addr);
5122 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5125 goto tidy_up_and_fail;
5126 if (size != sizeof(listen_addr))
5127 goto abort_tidy_up_and_fail;
5128 PerlLIO_close(listener);
5129 /* Now check we are talking to ourself by matching port and host on the
5131 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5133 goto tidy_up_and_fail;
5134 if (size != sizeof(connect_addr)
5135 || listen_addr.sin_family != connect_addr.sin_family
5136 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5137 || listen_addr.sin_port != connect_addr.sin_port) {
5138 goto abort_tidy_up_and_fail;
5144 abort_tidy_up_and_fail:
5146 errno = ECONNABORTED; /* This would be the standard thing to do. */
5148 # ifdef ECONNREFUSED
5149 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5151 errno = ETIMEDOUT; /* Desperation time. */
5158 PerlLIO_close(listener);
5159 if (connector != -1)
5160 PerlLIO_close(connector);
5162 PerlLIO_close(acceptor);
5168 /* In any case have a stub so that there's code corresponding
5169 * to the my_socketpair in global.sym. */
5171 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5172 #ifdef HAS_SOCKETPAIR
5173 return socketpair(family, type, protocol, fd);
5182 =for apidoc sv_nosharing
5184 Dummy routine which "shares" an SV when there is no sharing module present.
5185 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5186 Exists to avoid test for a NULL function pointer and because it could
5187 potentially warn under some level of strict-ness.
5193 Perl_sv_nosharing(pTHX_ SV *sv)
5195 PERL_UNUSED_CONTEXT;
5196 PERL_UNUSED_ARG(sv);
5201 =for apidoc sv_destroyable
5203 Dummy routine which reports that object can be destroyed when there is no
5204 sharing module present. It ignores its single SV argument, and returns
5205 'true'. Exists to avoid test for a NULL function pointer and because it
5206 could potentially warn under some level of strict-ness.
5212 Perl_sv_destroyable(pTHX_ SV *sv)
5214 PERL_UNUSED_CONTEXT;
5215 PERL_UNUSED_ARG(sv);
5220 Perl_parse_unicode_opts(pTHX_ const char **popt)
5222 const char *p = *popt;
5225 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5229 opt = (U32) atoi(p);
5232 if (*p && *p != '\n' && *p != '\r')
5233 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5238 case PERL_UNICODE_STDIN:
5239 opt |= PERL_UNICODE_STDIN_FLAG; break;
5240 case PERL_UNICODE_STDOUT:
5241 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5242 case PERL_UNICODE_STDERR:
5243 opt |= PERL_UNICODE_STDERR_FLAG; break;
5244 case PERL_UNICODE_STD:
5245 opt |= PERL_UNICODE_STD_FLAG; break;
5246 case PERL_UNICODE_IN:
5247 opt |= PERL_UNICODE_IN_FLAG; break;
5248 case PERL_UNICODE_OUT:
5249 opt |= PERL_UNICODE_OUT_FLAG; break;
5250 case PERL_UNICODE_INOUT:
5251 opt |= PERL_UNICODE_INOUT_FLAG; break;
5252 case PERL_UNICODE_LOCALE:
5253 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5254 case PERL_UNICODE_ARGV:
5255 opt |= PERL_UNICODE_ARGV_FLAG; break;
5256 case PERL_UNICODE_UTF8CACHEASSERT:
5257 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5259 if (*p != '\n' && *p != '\r')
5261 "Unknown Unicode option letter '%c'", *p);
5267 opt = PERL_UNICODE_DEFAULT_FLAGS;
5269 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5270 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5271 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5283 * This is really just a quick hack which grabs various garbage
5284 * values. It really should be a real hash algorithm which
5285 * spreads the effect of every input bit onto every output bit,
5286 * if someone who knows about such things would bother to write it.
5287 * Might be a good idea to add that function to CORE as well.
5288 * No numbers below come from careful analysis or anything here,
5289 * except they are primes and SEED_C1 > 1E6 to get a full-width
5290 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5291 * probably be bigger too.
5294 # define SEED_C1 1000003
5295 #define SEED_C4 73819
5297 # define SEED_C1 25747
5298 #define SEED_C4 20639
5302 #define SEED_C5 26107
5304 #ifndef PERL_NO_DEV_RANDOM
5309 # include <starlet.h>
5310 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5311 * in 100-ns units, typically incremented ever 10 ms. */
5312 unsigned int when[2];
5314 # ifdef HAS_GETTIMEOFDAY
5315 struct timeval when;
5321 /* This test is an escape hatch, this symbol isn't set by Configure. */
5322 #ifndef PERL_NO_DEV_RANDOM
5323 #ifndef PERL_RANDOM_DEVICE
5324 /* /dev/random isn't used by default because reads from it will block
5325 * if there isn't enough entropy available. You can compile with
5326 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5327 * is enough real entropy to fill the seed. */
5328 # define PERL_RANDOM_DEVICE "/dev/urandom"
5330 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5332 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5341 _ckvmssts(sys$gettim(when));
5342 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5344 # ifdef HAS_GETTIMEOFDAY
5345 PerlProc_gettimeofday(&when,NULL);
5346 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5349 u = (U32)SEED_C1 * when;
5352 u += SEED_C3 * (U32)PerlProc_getpid();
5353 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5354 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5355 u += SEED_C5 * (U32)PTR2UV(&when);
5361 Perl_get_hash_seed(pTHX)
5364 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5370 if (s && isDIGIT(*s))
5371 myseed = (UV)Atoul(s);
5373 #ifdef USE_HASH_SEED_EXPLICIT
5377 /* Compute a random seed */
5378 (void)seedDrand01((Rand_seed_t)seed());
5379 myseed = (UV)(Drand01() * (NV)UV_MAX);
5380 #if RANDBITS < (UVSIZE * 8)
5381 /* Since there are not enough randbits to to reach all
5382 * the bits of a UV, the low bits might need extra
5383 * help. Sum in another random number that will
5384 * fill in the low bits. */
5386 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5387 #endif /* RANDBITS < (UVSIZE * 8) */
5388 if (myseed == 0) { /* Superparanoia. */
5389 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5391 Perl_croak(aTHX_ "Your random numbers are not that random");
5394 PL_rehash_seed_set = TRUE;
5401 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5403 const char * const stashpv = CopSTASHPV(c);
5404 const char * const name = HvNAME_get(hv);
5405 PERL_UNUSED_CONTEXT;
5406 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5408 if (stashpv == name)
5410 if (stashpv && name)
5411 if (strEQ(stashpv, name))
5418 #ifdef PERL_GLOBAL_STRUCT
5420 #define PERL_GLOBAL_STRUCT_INIT
5421 #include "opcode.h" /* the ppaddr and check */
5424 Perl_init_global_struct(pTHX)
5426 struct perl_vars *plvarsp = NULL;
5427 # ifdef PERL_GLOBAL_STRUCT
5428 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5429 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5430 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5431 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5432 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5436 plvarsp = PL_VarsPtr;
5437 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5443 # define PERLVAR(var,type) /**/
5444 # define PERLVARA(var,n,type) /**/
5445 # define PERLVARI(var,type,init) plvarsp->var = init;
5446 # define PERLVARIC(var,type,init) plvarsp->var = init;
5447 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5448 # include "perlvars.h"
5454 # ifdef PERL_GLOBAL_STRUCT
5457 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5458 if (!plvarsp->Gppaddr)
5462 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5463 if (!plvarsp->Gcheck)
5465 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5466 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5468 # ifdef PERL_SET_VARS
5469 PERL_SET_VARS(plvarsp);
5471 # undef PERL_GLOBAL_STRUCT_INIT
5476 #endif /* PERL_GLOBAL_STRUCT */
5478 #ifdef PERL_GLOBAL_STRUCT
5481 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5483 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5484 # ifdef PERL_GLOBAL_STRUCT
5485 # ifdef PERL_UNSET_VARS
5486 PERL_UNSET_VARS(plvarsp);
5488 free(plvarsp->Gppaddr);
5489 free(plvarsp->Gcheck);
5490 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5496 #endif /* PERL_GLOBAL_STRUCT */
5500 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5501 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5502 * given, and you supply your own implementation.
5504 * The default implementation reads a single env var, PERL_MEM_LOG,
5505 * expecting one or more of the following:
5507 * \d+ - fd fd to write to : must be 1st (atoi)
5508 * 'm' - memlog was PERL_MEM_LOG=1
5509 * 's' - svlog was PERL_SV_LOG=1
5510 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5512 * This makes the logger controllable enough that it can reasonably be
5513 * added to the system perl.
5516 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5517 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5519 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5521 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5522 * writes to. In the default logger, this is settable at runtime.
5524 #ifndef PERL_MEM_LOG_FD
5525 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5528 #ifndef PERL_MEM_LOG_NOIMPL
5530 # ifdef DEBUG_LEAKING_SCALARS
5531 # define SV_LOG_SERIAL_FMT " [%lu]"
5532 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5534 # define SV_LOG_SERIAL_FMT
5535 # define _SV_LOG_SERIAL_ARG(sv)
5539 S_mem_log_common(enum mem_log_type mlt, const UV n,
5540 const UV typesize, const char *type_name, const SV *sv,
5541 Malloc_t oldalloc, Malloc_t newalloc,
5542 const char *filename, const int linenumber,
5543 const char *funcname)
5547 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5549 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5552 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5554 /* We can't use SVs or PerlIO for obvious reasons,
5555 * so we'll use stdio and low-level IO instead. */
5556 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5558 # ifdef HAS_GETTIMEOFDAY
5559 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5560 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5562 gettimeofday(&tv, 0);
5564 # define MEM_LOG_TIME_FMT "%10d: "
5565 # define MEM_LOG_TIME_ARG (int)when
5569 /* If there are other OS specific ways of hires time than
5570 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5571 * probably that they would be used to fill in the struct
5575 int fd = atoi(pmlenv);
5577 fd = PERL_MEM_LOG_FD;
5579 if (strchr(pmlenv, 't')) {
5580 len = my_snprintf(buf, sizeof(buf),
5581 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5582 PerlLIO_write(fd, buf, len);
5586 len = my_snprintf(buf, sizeof(buf),
5587 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5588 " %s = %"IVdf": %"UVxf"\n",
5589 filename, linenumber, funcname, n, typesize,
5590 type_name, n * typesize, PTR2UV(newalloc));
5593 len = my_snprintf(buf, sizeof(buf),
5594 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5595 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5596 filename, linenumber, funcname, n, typesize,
5597 type_name, n * typesize, PTR2UV(oldalloc),
5601 len = my_snprintf(buf, sizeof(buf),
5602 "free: %s:%d:%s: %"UVxf"\n",
5603 filename, linenumber, funcname,
5608 len = my_snprintf(buf, sizeof(buf),
5609 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5610 mlt == MLT_NEW_SV ? "new" : "del",
5611 filename, linenumber, funcname,
5612 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5617 PerlLIO_write(fd, buf, len);
5621 #endif /* !PERL_MEM_LOG_NOIMPL */
5623 #ifndef PERL_MEM_LOG_NOIMPL
5625 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5626 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5628 /* this is suboptimal, but bug compatible. User is providing their
5629 own implemenation, but is getting these functions anyway, and they
5630 do nothing. But _NOIMPL users should be able to cope or fix */
5632 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5633 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5637 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5639 const char *filename, const int linenumber,
5640 const char *funcname)
5642 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5643 NULL, NULL, newalloc,
5644 filename, linenumber, funcname);
5649 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5650 Malloc_t oldalloc, Malloc_t newalloc,
5651 const char *filename, const int linenumber,
5652 const char *funcname)
5654 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5655 NULL, oldalloc, newalloc,
5656 filename, linenumber, funcname);
5661 Perl_mem_log_free(Malloc_t oldalloc,
5662 const char *filename, const int linenumber,
5663 const char *funcname)
5665 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5666 filename, linenumber, funcname);
5671 Perl_mem_log_new_sv(const SV *sv,
5672 const char *filename, const int linenumber,
5673 const char *funcname)
5675 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5676 filename, linenumber, funcname);
5680 Perl_mem_log_del_sv(const SV *sv,
5681 const char *filename, const int linenumber,
5682 const char *funcname)
5684 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5685 filename, linenumber, funcname);
5688 #endif /* PERL_MEM_LOG */
5691 =for apidoc my_sprintf
5693 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5694 the length of the string written to the buffer. Only rare pre-ANSI systems
5695 need the wrapper function - usually this is a direct call to C<sprintf>.
5699 #ifndef SPRINTF_RETURNS_STRLEN
5701 Perl_my_sprintf(char *buffer, const char* pat, ...)
5704 PERL_ARGS_ASSERT_MY_SPRINTF;
5705 va_start(args, pat);
5706 vsprintf(buffer, pat, args);
5708 return strlen(buffer);
5713 =for apidoc my_snprintf
5715 The C library C<snprintf> functionality, if available and
5716 standards-compliant (uses C<vsnprintf>, actually). However, if the
5717 C<vsnprintf> is not available, will unfortunately use the unsafe
5718 C<vsprintf> which can overrun the buffer (there is an overrun check,
5719 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5720 getting C<vsnprintf>.
5725 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5730 PERL_ARGS_ASSERT_MY_SNPRINTF;
5731 va_start(ap, format);
5732 #ifdef HAS_VSNPRINTF
5733 retval = vsnprintf(buffer, len, format, ap);
5735 retval = vsprintf(buffer, format, ap);
5738 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5739 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5740 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5745 =for apidoc my_vsnprintf
5747 The C library C<vsnprintf> if available and standards-compliant.
5748 However, if if the C<vsnprintf> is not available, will unfortunately
5749 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5750 overrun check, but that may be too late). Consider using
5751 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5756 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5763 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5765 Perl_va_copy(ap, apc);
5766 # ifdef HAS_VSNPRINTF
5767 retval = vsnprintf(buffer, len, format, apc);
5769 retval = vsprintf(buffer, format, apc);
5772 # ifdef HAS_VSNPRINTF
5773 retval = vsnprintf(buffer, len, format, ap);
5775 retval = vsprintf(buffer, format, ap);
5777 #endif /* #ifdef NEED_VA_COPY */
5778 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5779 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5780 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5785 Perl_my_clearenv(pTHX)
5788 #if ! defined(PERL_MICRO)
5789 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5791 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5792 # if defined(USE_ENVIRON_ARRAY)
5793 # if defined(USE_ITHREADS)
5794 /* only the parent thread can clobber the process environment */
5795 if (PL_curinterp == aTHX)
5796 # endif /* USE_ITHREADS */
5798 # if ! defined(PERL_USE_SAFE_PUTENV)
5799 if ( !PL_use_safe_putenv) {
5801 if (environ == PL_origenviron)
5802 environ = (char**)safesysmalloc(sizeof(char*));
5804 for (i = 0; environ[i]; i++)
5805 (void)safesysfree(environ[i]);
5808 # else /* PERL_USE_SAFE_PUTENV */
5809 # if defined(HAS_CLEARENV)
5811 # elif defined(HAS_UNSETENV)
5812 int bsiz = 80; /* Most envvar names will be shorter than this. */
5813 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5814 char *buf = (char*)safesysmalloc(bufsiz);
5815 while (*environ != NULL) {
5816 char *e = strchr(*environ, '=');
5817 int l = e ? e - *environ : (int)strlen(*environ);
5819 (void)safesysfree(buf);
5820 bsiz = l + 1; /* + 1 for the \0. */
5821 buf = (char*)safesysmalloc(bufsiz);
5823 memcpy(buf, *environ, l);
5825 (void)unsetenv(buf);
5827 (void)safesysfree(buf);
5828 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5829 /* Just null environ and accept the leakage. */
5831 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5832 # endif /* ! PERL_USE_SAFE_PUTENV */
5834 # endif /* USE_ENVIRON_ARRAY */
5835 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5836 #endif /* PERL_MICRO */
5839 #ifdef PERL_IMPLICIT_CONTEXT
5841 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5842 the global PL_my_cxt_index is incremented, and that value is assigned to
5843 that module's static my_cxt_index (who's address is passed as an arg).
5844 Then, for each interpreter this function is called for, it makes sure a
5845 void* slot is available to hang the static data off, by allocating or
5846 extending the interpreter's PL_my_cxt_list array */
5848 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5850 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5854 PERL_ARGS_ASSERT_MY_CXT_INIT;
5856 /* this module hasn't been allocated an index yet */
5857 MUTEX_LOCK(&PL_my_ctx_mutex);
5858 *index = PL_my_cxt_index++;
5859 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5862 /* make sure the array is big enough */
5863 if (PL_my_cxt_size <= *index) {
5864 if (PL_my_cxt_size) {
5865 while (PL_my_cxt_size <= *index)
5866 PL_my_cxt_size *= 2;
5867 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5870 PL_my_cxt_size = 16;
5871 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5874 /* newSV() allocates one more than needed */
5875 p = (void*)SvPVX(newSV(size-1));
5876 PL_my_cxt_list[*index] = p;
5877 Zero(p, size, char);
5881 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5884 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5889 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5891 for (index = 0; index < PL_my_cxt_index; index++) {
5892 const char *key = PL_my_cxt_keys[index];
5893 /* try direct pointer compare first - there are chances to success,
5894 * and it's much faster.
5896 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5903 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5909 PERL_ARGS_ASSERT_MY_CXT_INIT;
5911 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5913 /* this module hasn't been allocated an index yet */
5914 MUTEX_LOCK(&PL_my_ctx_mutex);
5915 index = PL_my_cxt_index++;
5916 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5919 /* make sure the array is big enough */
5920 if (PL_my_cxt_size <= index) {
5921 int old_size = PL_my_cxt_size;
5923 if (PL_my_cxt_size) {
5924 while (PL_my_cxt_size <= index)
5925 PL_my_cxt_size *= 2;
5926 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5927 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5930 PL_my_cxt_size = 16;
5931 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5932 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5934 for (i = old_size; i < PL_my_cxt_size; i++) {
5935 PL_my_cxt_keys[i] = 0;
5936 PL_my_cxt_list[i] = 0;
5939 PL_my_cxt_keys[index] = my_cxt_key;
5940 /* newSV() allocates one more than needed */
5941 p = (void*)SvPVX(newSV(size-1));
5942 PL_my_cxt_list[index] = p;
5943 Zero(p, size, char);
5946 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5947 #endif /* PERL_IMPLICIT_CONTEXT */
5951 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5953 Size_t used, length, copy;
5956 length = strlen(src);
5957 if (size > 0 && used < size - 1) {
5958 copy = (length >= size - used) ? size - used - 1 : length;
5959 memcpy(dst + used, src, copy);
5960 dst[used + copy] = '\0';
5962 return used + length;
5968 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5970 Size_t length, copy;
5972 length = strlen(src);
5974 copy = (length >= size) ? size - 1 : length;
5975 memcpy(dst, src, copy);
5982 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5983 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5984 long _ftol( double ); /* Defined by VC6 C libs. */
5985 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5989 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5992 SV * const dbsv = GvSVn(PL_DBsub);
5993 /* We do not care about using sv to call CV;
5994 * it's for informational purposes only.
5997 PERL_ARGS_ASSERT_GET_DB_SUB;
6000 if (!PERLDB_SUB_NN) {
6001 GV * const gv = CvGV(cv);
6003 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6004 || strEQ(GvNAME(gv), "END")
6005 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6006 !( (SvTYPE(*svp) == SVt_PVGV)
6007 && (GvCV((const GV *)*svp) == cv) )))) {
6008 /* Use GV from the stack as a fallback. */
6009 /* GV is potentially non-unique, or contain different CV. */
6010 SV * const tmp = newRV(MUTABLE_SV(cv));
6011 sv_setsv(dbsv, tmp);
6015 gv_efullname3(dbsv, gv, NULL);
6019 const int type = SvTYPE(dbsv);
6020 if (type < SVt_PVIV && type != SVt_IV)
6021 sv_upgrade(dbsv, SVt_PVIV);
6022 (void)SvIOK_on(dbsv);
6023 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6028 Perl_my_dirfd(pTHX_ DIR * dir) {
6030 /* Most dirfd implementations have problems when passed NULL. */
6035 #elif defined(HAS_DIR_DD_FD)
6038 Perl_die(aTHX_ PL_no_func, "dirfd");
6045 Perl_get_re_arg(pTHX_ SV *sv) {
6052 (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */
6053 SvTYPE(tmpsv) == SVt_REGEXP)
6055 return (REGEXP*) tmpsv;
6064 * c-indentation-style: bsd
6066 * indent-tabs-mode: t
6069 * ex: set ts=8 sts=4 sw=4 noet: