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 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
74 # define ALWAYS_NEED_THX
77 /* paranoid version of system's malloc() */
80 Perl_safesysmalloc(MEM_SIZE size)
82 #ifdef ALWAYS_NEED_THX
88 PerlIO_printf(Perl_error_log,
89 "Allocation too large: %lx\n", size) FLUSH;
92 #endif /* HAS_64K_LIMIT */
93 #ifdef PERL_TRACK_MEMPOOL
98 Perl_croak_nocontext("panic: malloc");
100 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
101 PERL_ALLOC_CHECK(ptr);
103 #ifdef PERL_TRACK_MEMPOOL
104 struct perl_memory_debug_header *const header
105 = (struct perl_memory_debug_header *)ptr;
109 PoisonNew(((char *)ptr), size, char);
112 #ifdef PERL_TRACK_MEMPOOL
113 header->interpreter = aTHX;
114 /* Link us into the list. */
115 header->prev = &PL_memory_debug_header;
116 header->next = PL_memory_debug_header.next;
117 PL_memory_debug_header.next = header;
118 header->next->prev = header;
122 ptr = (Malloc_t)((char*)ptr+sTHX);
124 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
128 #ifndef ALWAYS_NEED_THX
134 return write_no_mem();
140 /* paranoid version of system's realloc() */
143 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
145 #ifdef ALWAYS_NEED_THX
149 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
150 Malloc_t PerlMem_realloc();
151 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
155 PerlIO_printf(Perl_error_log,
156 "Reallocation too large: %lx\n", size) FLUSH;
159 #endif /* HAS_64K_LIMIT */
166 return safesysmalloc(size);
167 #ifdef PERL_TRACK_MEMPOOL
168 where = (Malloc_t)((char*)where-sTHX);
171 struct perl_memory_debug_header *const header
172 = (struct perl_memory_debug_header *)where;
174 if (header->interpreter != aTHX) {
175 Perl_croak_nocontext("panic: realloc from wrong pool");
177 assert(header->next->prev == header);
178 assert(header->prev->next == header);
180 if (header->size > size) {
181 const MEM_SIZE freed_up = header->size - size;
182 char *start_of_freed = ((char *)where) + size;
183 PoisonFree(start_of_freed, freed_up, char);
191 Perl_croak_nocontext("panic: realloc");
193 ptr = (Malloc_t)PerlMem_realloc(where,size);
194 PERL_ALLOC_CHECK(ptr);
196 /* MUST do this fixup first, before doing ANYTHING else, as anything else
197 might allocate memory/free/move memory, and until we do the fixup, it
198 may well be chasing (and writing to) free memory. */
199 #ifdef PERL_TRACK_MEMPOOL
201 struct perl_memory_debug_header *const header
202 = (struct perl_memory_debug_header *)ptr;
205 if (header->size < size) {
206 const MEM_SIZE fresh = size - header->size;
207 char *start_of_fresh = ((char *)ptr) + size;
208 PoisonNew(start_of_fresh, fresh, char);
212 header->next->prev = header;
213 header->prev->next = header;
215 ptr = (Malloc_t)((char*)ptr+sTHX);
219 /* In particular, must do that fixup above before logging anything via
220 *printf(), as it can reallocate memory, which can cause SEGVs. */
222 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
223 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
230 #ifndef ALWAYS_NEED_THX
236 return write_no_mem();
242 /* safe version of system's free() */
245 Perl_safesysfree(Malloc_t where)
247 #ifdef ALWAYS_NEED_THX
252 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
254 #ifdef PERL_TRACK_MEMPOOL
255 where = (Malloc_t)((char*)where-sTHX);
257 struct perl_memory_debug_header *const header
258 = (struct perl_memory_debug_header *)where;
260 if (header->interpreter != aTHX) {
261 Perl_croak_nocontext("panic: free from wrong pool");
264 Perl_croak_nocontext("panic: duplicate free");
266 if (!(header->next) || header->next->prev != header
267 || header->prev->next != header) {
268 Perl_croak_nocontext("panic: bad free");
270 /* Unlink us from the chain. */
271 header->next->prev = header->prev;
272 header->prev->next = header->next;
274 PoisonNew(where, header->size, char);
276 /* Trigger the duplicate free warning. */
284 /* safe version of system's calloc() */
287 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
289 #ifdef ALWAYS_NEED_THX
293 MEM_SIZE total_size = 0;
295 /* Even though calloc() for zero bytes is strange, be robust. */
296 if (size && (count <= MEM_SIZE_MAX / size))
297 total_size = size * count;
299 Perl_croak_nocontext("%s", PL_memory_wrap);
300 #ifdef PERL_TRACK_MEMPOOL
301 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
304 Perl_croak_nocontext("%s", PL_memory_wrap);
307 if (total_size > 0xffff) {
308 PerlIO_printf(Perl_error_log,
309 "Allocation too large: %lx\n", total_size) FLUSH;
312 #endif /* HAS_64K_LIMIT */
314 if ((long)size < 0 || (long)count < 0)
315 Perl_croak_nocontext("panic: calloc");
317 #ifdef PERL_TRACK_MEMPOOL
318 /* Have to use malloc() because we've added some space for our tracking
320 /* malloc(0) is non-portable. */
321 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
323 /* Use calloc() because it might save a memset() if the memory is fresh
324 and clean from the OS. */
326 ptr = (Malloc_t)PerlMem_calloc(count, size);
327 else /* calloc(0) is non-portable. */
328 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
330 PERL_ALLOC_CHECK(ptr);
331 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));
333 #ifdef PERL_TRACK_MEMPOOL
335 struct perl_memory_debug_header *const header
336 = (struct perl_memory_debug_header *)ptr;
338 memset((void*)ptr, 0, total_size);
339 header->interpreter = aTHX;
340 /* Link us into the list. */
341 header->prev = &PL_memory_debug_header;
342 header->next = PL_memory_debug_header.next;
343 PL_memory_debug_header.next = header;
344 header->next->prev = header;
346 header->size = total_size;
348 ptr = (Malloc_t)((char*)ptr+sTHX);
354 #ifndef ALWAYS_NEED_THX
359 return write_no_mem();
363 /* These must be defined when not using Perl's malloc for binary
368 Malloc_t Perl_malloc (MEM_SIZE nbytes)
371 return (Malloc_t)PerlMem_malloc(nbytes);
374 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
377 return (Malloc_t)PerlMem_calloc(elements, size);
380 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
383 return (Malloc_t)PerlMem_realloc(where, nbytes);
386 Free_t Perl_mfree (Malloc_t where)
394 /* copy a string up to some (non-backslashed) delimiter, if any */
397 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
401 PERL_ARGS_ASSERT_DELIMCPY;
403 for (tolen = 0; from < fromend; from++, tolen++) {
405 if (from[1] != delim) {
412 else if (*from == delim)
423 /* return ptr to little string in big string, NULL if not found */
424 /* This routine was donated by Corey Satten. */
427 Perl_instr(register const char *big, register const char *little)
431 PERL_ARGS_ASSERT_INSTR;
439 register const char *s, *x;
442 for (x=big,s=little; *s; /**/ ) {
453 return (char*)(big-1);
458 /* same as instr but allow embedded nulls */
461 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
463 PERL_ARGS_ASSERT_NINSTR;
467 const char first = *little;
469 bigend -= lend - little++;
471 while (big <= bigend) {
472 if (*big++ == first) {
473 for (x=big,s=little; s < lend; x++,s++) {
477 return (char*)(big-1);
484 /* reverse of the above--find last substring */
487 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
489 register const char *bigbeg;
490 register const I32 first = *little;
491 register const char * const littleend = lend;
493 PERL_ARGS_ASSERT_RNINSTR;
495 if (little >= littleend)
496 return (char*)bigend;
498 big = bigend - (littleend - little++);
499 while (big >= bigbeg) {
500 register const char *s, *x;
503 for (x=big+2,s=little; s < littleend; /**/ ) {
512 return (char*)(big+1);
517 /* As a space optimization, we do not compile tables for strings of length
518 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
519 special-cased in fbm_instr().
521 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
524 =head1 Miscellaneous Functions
526 =for apidoc fbm_compile
528 Analyses the string in order to make fast searches on it using fbm_instr()
529 -- the Boyer-Moore algorithm.
535 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
538 register const U8 *s;
544 PERL_ARGS_ASSERT_FBM_COMPILE;
546 if (flags & FBMcf_TAIL) {
547 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
548 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
549 if (mg && mg->mg_len >= 0)
552 s = (U8*)SvPV_force_mutable(sv, len);
553 if (len == 0) /* TAIL might be on a zero-length string. */
555 SvUPGRADE(sv, SVt_PVGV);
560 const unsigned char *sb;
561 const U8 mlen = (len>255) ? 255 : (U8)len;
564 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
566 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
567 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
568 memset((void*)table, mlen, 256);
570 sb = s - mlen + 1; /* first char (maybe) */
572 if (table[*s] == mlen)
577 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
579 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
581 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
582 for (i = 0; i < len; i++) {
583 if (PL_freq[s[i]] < frequency) {
585 frequency = PL_freq[s[i]];
588 BmFLAGS(sv) = (U8)flags;
589 BmRARE(sv) = s[rarest];
590 BmPREVIOUS(sv) = rarest;
591 BmUSEFUL(sv) = 100; /* Initial value */
592 if (flags & FBMcf_TAIL)
594 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
595 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
598 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
599 /* If SvTAIL is actually due to \Z or \z, this gives false positives
603 =for apidoc fbm_instr
605 Returns the location of the SV in the string delimited by C<str> and
606 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
607 does not have to be fbm_compiled, but the search will not be as fast
614 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
616 register unsigned char *s;
618 register const unsigned char *little
619 = (const unsigned char *)SvPV_const(littlestr,l);
620 register STRLEN littlelen = l;
621 register const I32 multiline = flags & FBMrf_MULTILINE;
623 PERL_ARGS_ASSERT_FBM_INSTR;
625 if ((STRLEN)(bigend - big) < littlelen) {
626 if ( SvTAIL(littlestr)
627 && ((STRLEN)(bigend - big) == littlelen - 1)
629 || (*big == *little &&
630 memEQ((char *)big, (char *)little, littlelen - 1))))
635 if (littlelen <= 2) { /* Special-cased */
637 if (littlelen == 1) {
638 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
639 /* Know that bigend != big. */
640 if (bigend[-1] == '\n')
641 return (char *)(bigend - 1);
642 return (char *) bigend;
650 if (SvTAIL(littlestr))
651 return (char *) bigend;
655 return (char*)big; /* Cannot be SvTAIL! */
658 if (SvTAIL(littlestr) && !multiline) {
659 if (bigend[-1] == '\n' && bigend[-2] == *little)
660 return (char*)bigend - 2;
661 if (bigend[-1] == *little)
662 return (char*)bigend - 1;
666 /* This should be better than FBM if c1 == c2, and almost
667 as good otherwise: maybe better since we do less indirection.
668 And we save a lot of memory by caching no table. */
669 const unsigned char c1 = little[0];
670 const unsigned char c2 = little[1];
675 while (s <= bigend) {
685 goto check_1char_anchor;
696 goto check_1char_anchor;
699 while (s <= bigend) {
704 goto check_1char_anchor;
713 check_1char_anchor: /* One char and anchor! */
714 if (SvTAIL(littlestr) && (*bigend == *little))
715 return (char *)bigend; /* bigend is already decremented. */
718 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
719 s = bigend - littlelen;
720 if (s >= big && bigend[-1] == '\n' && *s == *little
721 /* Automatically of length > 2 */
722 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
724 return (char*)s; /* how sweet it is */
727 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
729 return (char*)s + 1; /* how sweet it is */
733 if (!SvVALID(littlestr)) {
734 char * const b = ninstr((char*)big,(char*)bigend,
735 (char*)little, (char*)little + littlelen);
737 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
738 /* Chop \n from littlestr: */
739 s = bigend - littlelen + 1;
741 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
751 if (littlelen > (STRLEN)(bigend - big))
755 register const unsigned char * const table
756 = little + littlelen + PERL_FBM_TABLE_OFFSET;
757 register const unsigned char *oldlittle;
759 --littlelen; /* Last char found by table lookup */
762 little += littlelen; /* last char */
768 if ((tmp = table[*s])) {
769 if ((s += tmp) < bigend)
773 else { /* less expensive than calling strncmp() */
774 register unsigned char * const olds = s;
779 if (*--s == *--little)
781 s = olds + 1; /* here we pay the price for failure */
783 if (s < bigend) /* fake up continue to outer loop */
792 && (BmFLAGS(littlestr) & FBMcf_TAIL)
793 && memEQ((char *)(bigend - littlelen),
794 (char *)(oldlittle - littlelen), littlelen) )
795 return (char*)bigend - littlelen;
800 /* start_shift, end_shift are positive quantities which give offsets
801 of ends of some substring of bigstr.
802 If "last" we want the last occurrence.
803 old_posp is the way of communication between consequent calls if
804 the next call needs to find the .
805 The initial *old_posp should be -1.
807 Note that we take into account SvTAIL, so one can get extra
808 optimizations if _ALL flag is set.
811 /* If SvTAIL is actually due to \Z or \z, this gives false positives
812 if PL_multiline. In fact if !PL_multiline the authoritative answer
813 is not supported yet. */
816 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
819 register const unsigned char *big;
821 register I32 previous;
823 register const unsigned char *little;
824 register I32 stop_pos;
825 register const unsigned char *littleend;
828 PERL_ARGS_ASSERT_SCREAMINSTR;
830 assert(SvTYPE(littlestr) == SVt_PVGV);
831 assert(SvVALID(littlestr));
834 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
835 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
837 if ( BmRARE(littlestr) == '\n'
838 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
839 little = (const unsigned char *)(SvPVX_const(littlestr));
840 littleend = little + SvCUR(littlestr);
847 little = (const unsigned char *)(SvPVX_const(littlestr));
848 littleend = little + SvCUR(littlestr);
850 /* The value of pos we can start at: */
851 previous = BmPREVIOUS(littlestr);
852 big = (const unsigned char *)(SvPVX_const(bigstr));
853 /* The value of pos we can stop at: */
854 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
855 if (previous + start_shift > stop_pos) {
857 stop_pos does not include SvTAIL in the count, so this check is incorrect
858 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
861 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
866 while (pos < previous + start_shift) {
867 if (!(pos += PL_screamnext[pos]))
872 register const unsigned char *s, *x;
873 if (pos >= stop_pos) break;
874 if (big[pos] != first)
876 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
882 if (s == littleend) {
884 if (!last) return (char *)(big+pos);
887 } while ( pos += PL_screamnext[pos] );
889 return (char *)(big+(*old_posp));
891 if (!SvTAIL(littlestr) || (end_shift > 0))
893 /* Ignore the trailing "\n". This code is not microoptimized */
894 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
895 stop_pos = littleend - little; /* Actual littlestr len */
900 && ((stop_pos == 1) ||
901 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
909 Returns true if the leading len bytes of the strings s1 and s2 are the same
910 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
911 match themselves and their opposite case counterparts. Non-cased and non-ASCII
912 range bytes match only themselves.
919 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
921 register const U8 *a = (const U8 *)s1;
922 register const U8 *b = (const U8 *)s2;
924 PERL_ARGS_ASSERT_FOLDEQ;
927 if (*a != *b && *a != PL_fold[*b])
935 =for apidoc foldEQ_locale
937 Returns true if the leading len bytes of the strings s1 and s2 are the same
938 case-insensitively in the current locale; false otherwise.
944 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
947 register const U8 *a = (const U8 *)s1;
948 register const U8 *b = (const U8 *)s2;
950 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
953 if (*a != *b && *a != PL_fold_locale[*b])
960 /* copy a string to a safe spot */
963 =head1 Memory Management
967 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
968 string which is a duplicate of C<pv>. The size of the string is
969 determined by C<strlen()>. The memory allocated for the new string can
970 be freed with the C<Safefree()> function.
976 Perl_savepv(pTHX_ const char *pv)
983 const STRLEN pvlen = strlen(pv)+1;
984 Newx(newaddr, pvlen, char);
985 return (char*)memcpy(newaddr, pv, pvlen);
989 /* same thing but with a known length */
994 Perl's version of what C<strndup()> would be if it existed. Returns a
995 pointer to a newly allocated string which is a duplicate of the first
996 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
997 the new string can be freed with the C<Safefree()> function.
1003 Perl_savepvn(pTHX_ const char *pv, register I32 len)
1005 register char *newaddr;
1006 PERL_UNUSED_CONTEXT;
1008 Newx(newaddr,len+1,char);
1009 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1011 /* might not be null terminated */
1012 newaddr[len] = '\0';
1013 return (char *) CopyD(pv,newaddr,len,char);
1016 return (char *) ZeroD(newaddr,len+1,char);
1021 =for apidoc savesharedpv
1023 A version of C<savepv()> which allocates the duplicate string in memory
1024 which is shared between threads.
1029 Perl_savesharedpv(pTHX_ const char *pv)
1031 register char *newaddr;
1036 pvlen = strlen(pv)+1;
1037 newaddr = (char*)PerlMemShared_malloc(pvlen);
1039 return write_no_mem();
1041 return (char*)memcpy(newaddr, pv, pvlen);
1045 =for apidoc savesharedpvn
1047 A version of C<savepvn()> which allocates the duplicate string in memory
1048 which is shared between threads. (With the specific difference that a NULL
1049 pointer is not acceptable)
1054 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1056 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1058 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1061 return write_no_mem();
1063 newaddr[len] = '\0';
1064 return (char*)memcpy(newaddr, pv, len);
1068 =for apidoc savesvpv
1070 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1071 the passed in SV using C<SvPV()>
1077 Perl_savesvpv(pTHX_ SV *sv)
1080 const char * const pv = SvPV_const(sv, len);
1081 register char *newaddr;
1083 PERL_ARGS_ASSERT_SAVESVPV;
1086 Newx(newaddr,len,char);
1087 return (char *) CopyD(pv,newaddr,len,char);
1091 =for apidoc savesharedsvpv
1093 A version of C<savesharedpv()> which allocates the duplicate string in
1094 memory which is shared between threads.
1100 Perl_savesharedsvpv(pTHX_ SV *sv)
1103 const char * const pv = SvPV_const(sv, len);
1105 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1107 return savesharedpvn(pv, len);
1110 /* the SV for Perl_form() and mess() is not kept in an arena */
1120 return newSVpvs_flags("", SVs_TEMP);
1125 /* Create as PVMG now, to avoid any upgrading later */
1127 Newxz(any, 1, XPVMG);
1128 SvFLAGS(sv) = SVt_PVMG;
1129 SvANY(sv) = (void*)any;
1131 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1136 #if defined(PERL_IMPLICIT_CONTEXT)
1138 Perl_form_nocontext(const char* pat, ...)
1143 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1144 va_start(args, pat);
1145 retval = vform(pat, &args);
1149 #endif /* PERL_IMPLICIT_CONTEXT */
1152 =head1 Miscellaneous Functions
1155 Takes a sprintf-style format pattern and conventional
1156 (non-SV) arguments and returns the formatted string.
1158 (char *) Perl_form(pTHX_ const char* pat, ...)
1160 can be used any place a string (char *) is required:
1162 char * s = Perl_form("%d.%d",major,minor);
1164 Uses a single private buffer so if you want to format several strings you
1165 must explicitly copy the earlier strings away (and free the copies when you
1172 Perl_form(pTHX_ const char* pat, ...)
1176 PERL_ARGS_ASSERT_FORM;
1177 va_start(args, pat);
1178 retval = vform(pat, &args);
1184 Perl_vform(pTHX_ const char *pat, va_list *args)
1186 SV * const sv = mess_alloc();
1187 PERL_ARGS_ASSERT_VFORM;
1188 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1193 =for apidoc Am|SV *|mess|const char *pat|...
1195 Take a sprintf-style format pattern and argument list. These are used to
1196 generate a string message. If the message does not end with a newline,
1197 then it will be extended with some indication of the current location
1198 in the code, as described for L</mess_sv>.
1200 Normally, the resulting message is returned in a new mortal SV.
1201 During global destruction a single SV may be shared between uses of
1207 #if defined(PERL_IMPLICIT_CONTEXT)
1209 Perl_mess_nocontext(const char *pat, ...)
1214 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1215 va_start(args, pat);
1216 retval = vmess(pat, &args);
1220 #endif /* PERL_IMPLICIT_CONTEXT */
1223 Perl_mess(pTHX_ const char *pat, ...)
1227 PERL_ARGS_ASSERT_MESS;
1228 va_start(args, pat);
1229 retval = vmess(pat, &args);
1235 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1238 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1240 PERL_ARGS_ASSERT_CLOSEST_COP;
1242 if (!o || o == PL_op)
1245 if (o->op_flags & OPf_KIDS) {
1247 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1250 /* If the OP_NEXTSTATE has been optimised away we can still use it
1251 * the get the file and line number. */
1253 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1254 cop = (const COP *)kid;
1256 /* Keep searching, and return when we've found something. */
1258 new_cop = closest_cop(cop, kid);
1264 /* Nothing found. */
1270 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1272 Expands a message, intended for the user, to include an indication of
1273 the current location in the code, if the message does not already appear
1276 C<basemsg> is the initial message or object. If it is a reference, it
1277 will be used as-is and will be the result of this function. Otherwise it
1278 is used as a string, and if it already ends with a newline, it is taken
1279 to be complete, and the result of this function will be the same string.
1280 If the message does not end with a newline, then a segment such as C<at
1281 foo.pl line 37> will be appended, and possibly other clauses indicating
1282 the current state of execution. The resulting message will end with a
1285 Normally, the resulting message is returned in a new mortal SV.
1286 During global destruction a single SV may be shared between uses of this
1287 function. If C<consume> is true, then the function is permitted (but not
1288 required) to modify and return C<basemsg> instead of allocating a new SV.
1294 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1299 PERL_ARGS_ASSERT_MESS_SV;
1301 if (SvROK(basemsg)) {
1307 sv_setsv(sv, basemsg);
1312 if (SvPOK(basemsg) && consume) {
1317 sv_copypv(sv, basemsg);
1320 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1322 * Try and find the file and line for PL_op. This will usually be
1323 * PL_curcop, but it might be a cop that has been optimised away. We
1324 * can try to find such a cop by searching through the optree starting
1325 * from the sibling of PL_curcop.
1328 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1333 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1334 OutCopFILE(cop), (IV)CopLINE(cop));
1335 /* Seems that GvIO() can be untrustworthy during global destruction. */
1336 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1337 && IoLINES(GvIOp(PL_last_in_gv)))
1339 const bool line_mode = (RsSIMPLE(PL_rs) &&
1340 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1341 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1342 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1343 line_mode ? "line" : "chunk",
1344 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1347 sv_catpvs(sv, " during global destruction");
1348 sv_catpvs(sv, ".\n");
1354 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1356 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1357 argument list. These are used to generate a string message. If the
1358 message does not end with a newline, then it will be extended with
1359 some indication of the current location in the code, as described for
1362 Normally, the resulting message is returned in a new mortal SV.
1363 During global destruction a single SV may be shared between uses of
1370 Perl_vmess(pTHX_ const char *pat, va_list *args)
1373 SV * const sv = mess_alloc();
1375 PERL_ARGS_ASSERT_VMESS;
1377 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1378 return mess_sv(sv, 1);
1382 Perl_write_to_stderr(pTHX_ SV* msv)
1388 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1390 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1391 && (io = GvIO(PL_stderrgv))
1392 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1399 SAVESPTR(PL_stderrgv);
1402 PUSHSTACKi(PERLSI_MAGIC);
1406 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1409 call_method("PRINT", G_SCALAR);
1417 /* SFIO can really mess with your errno */
1420 PerlIO * const serr = Perl_error_log;
1422 do_print(msv, serr);
1423 (void)PerlIO_flush(serr);
1431 =head1 Warning and Dieing
1434 /* Common code used in dieing and warning */
1437 S_with_queued_errors(pTHX_ SV *ex)
1439 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1440 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1441 sv_catsv(PL_errors, ex);
1442 ex = sv_mortalcopy(PL_errors);
1443 SvCUR_set(PL_errors, 0);
1449 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1455 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1456 /* sv_2cv might call Perl_croak() or Perl_warner() */
1457 SV * const oldhook = *hook;
1465 cv = sv_2cv(oldhook, &stash, &gv, 0);
1467 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1477 exarg = newSVsv(ex);
1478 SvREADONLY_on(exarg);
1481 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1485 call_sv(MUTABLE_SV(cv), G_DISCARD);
1494 =for apidoc Am|OP *|die_sv|SV *baseex
1496 Behaves the same as L</croak_sv>, except for the return type.
1497 It should be used only where the C<OP *> return type is required.
1498 The function never actually returns.
1504 Perl_die_sv(pTHX_ SV *baseex)
1506 PERL_ARGS_ASSERT_DIE_SV;
1513 =for apidoc Am|OP *|die|const char *pat|...
1515 Behaves the same as L</croak>, except for the return type.
1516 It should be used only where the C<OP *> return type is required.
1517 The function never actually returns.
1522 #if defined(PERL_IMPLICIT_CONTEXT)
1524 Perl_die_nocontext(const char* pat, ...)
1528 va_start(args, pat);
1534 #endif /* PERL_IMPLICIT_CONTEXT */
1537 Perl_die(pTHX_ const char* pat, ...)
1540 va_start(args, pat);
1548 =for apidoc Am|void|croak_sv|SV *baseex
1550 This is an XS interface to Perl's C<die> function.
1552 C<baseex> is the error message or object. If it is a reference, it
1553 will be used as-is. Otherwise it is used as a string, and if it does
1554 not end with a newline then it will be extended with some indication of
1555 the current location in the code, as described for L</mess_sv>.
1557 The error message or object will be used as an exception, by default
1558 returning control to the nearest enclosing C<eval>, but subject to
1559 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1560 function never returns normally.
1562 To die with a simple string message, the L</croak> function may be
1569 Perl_croak_sv(pTHX_ SV *baseex)
1571 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1572 PERL_ARGS_ASSERT_CROAK_SV;
1573 invoke_exception_hook(ex, FALSE);
1578 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1580 This is an XS interface to Perl's C<die> function.
1582 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1583 argument list. These are used to generate a string message. If the
1584 message does not end with a newline, then it will be extended with
1585 some indication of the current location in the code, as described for
1588 The error message will be used as an exception, by default
1589 returning control to the nearest enclosing C<eval>, but subject to
1590 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1591 function never returns normally.
1593 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1594 (C<$@>) will be used as an error message or object instead of building an
1595 error message from arguments. If you want to throw a non-string object,
1596 or build an error message in an SV yourself, it is preferable to use
1597 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1603 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1605 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1606 invoke_exception_hook(ex, FALSE);
1611 =for apidoc Am|void|croak|const char *pat|...
1613 This is an XS interface to Perl's C<die> function.
1615 Take a sprintf-style format pattern and argument list. These are used to
1616 generate a string message. If the message does not end with a newline,
1617 then it will be extended with some indication of the current location
1618 in the code, as described for L</mess_sv>.
1620 The error message will be used as an exception, by default
1621 returning control to the nearest enclosing C<eval>, but subject to
1622 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1623 function never returns normally.
1625 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1626 (C<$@>) will be used as an error message or object instead of building an
1627 error message from arguments. If you want to throw a non-string object,
1628 or build an error message in an SV yourself, it is preferable to use
1629 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1634 #if defined(PERL_IMPLICIT_CONTEXT)
1636 Perl_croak_nocontext(const char *pat, ...)
1640 va_start(args, pat);
1645 #endif /* PERL_IMPLICIT_CONTEXT */
1648 Perl_croak(pTHX_ const char *pat, ...)
1651 va_start(args, pat);
1658 =for apidoc Am|void|croak_no_modify
1660 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1661 terser object code than using C<Perl_croak>. Less code used on exception code
1662 paths reduces CPU cache pressure.
1668 Perl_croak_no_modify(pTHX)
1670 Perl_croak(aTHX_ "%s", PL_no_modify);
1674 =for apidoc Am|void|warn_sv|SV *baseex
1676 This is an XS interface to Perl's C<warn> function.
1678 C<baseex> is the error message or object. If it is a reference, it
1679 will be used as-is. Otherwise it is used as a string, and if it does
1680 not end with a newline then it will be extended with some indication of
1681 the current location in the code, as described for L</mess_sv>.
1683 The error message or object will by default be written to standard error,
1684 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1686 To warn with a simple string message, the L</warn> function may be
1693 Perl_warn_sv(pTHX_ SV *baseex)
1695 SV *ex = mess_sv(baseex, 0);
1696 PERL_ARGS_ASSERT_WARN_SV;
1697 if (!invoke_exception_hook(ex, TRUE))
1698 write_to_stderr(ex);
1702 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1704 This is an XS interface to Perl's C<warn> function.
1706 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1707 argument list. These are used to generate a string message. If the
1708 message does not end with a newline, then it will be extended with
1709 some indication of the current location in the code, as described for
1712 The error message or object will by default be written to standard error,
1713 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1715 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1721 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1723 SV *ex = vmess(pat, args);
1724 PERL_ARGS_ASSERT_VWARN;
1725 if (!invoke_exception_hook(ex, TRUE))
1726 write_to_stderr(ex);
1730 =for apidoc Am|void|warn|const char *pat|...
1732 This is an XS interface to Perl's C<warn> function.
1734 Take a sprintf-style format pattern and argument list. These are used to
1735 generate a string message. If the message does not end with a newline,
1736 then it will be extended with some indication of the current location
1737 in the code, as described for L</mess_sv>.
1739 The error message or object will by default be written to standard error,
1740 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1742 Unlike with L</croak>, C<pat> is not permitted to be null.
1747 #if defined(PERL_IMPLICIT_CONTEXT)
1749 Perl_warn_nocontext(const char *pat, ...)
1753 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1754 va_start(args, pat);
1758 #endif /* PERL_IMPLICIT_CONTEXT */
1761 Perl_warn(pTHX_ const char *pat, ...)
1764 PERL_ARGS_ASSERT_WARN;
1765 va_start(args, pat);
1770 #if defined(PERL_IMPLICIT_CONTEXT)
1772 Perl_warner_nocontext(U32 err, const char *pat, ...)
1776 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1777 va_start(args, pat);
1778 vwarner(err, pat, &args);
1781 #endif /* PERL_IMPLICIT_CONTEXT */
1784 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1786 PERL_ARGS_ASSERT_CK_WARNER_D;
1788 if (Perl_ckwarn_d(aTHX_ err)) {
1790 va_start(args, pat);
1791 vwarner(err, pat, &args);
1797 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1799 PERL_ARGS_ASSERT_CK_WARNER;
1801 if (Perl_ckwarn(aTHX_ err)) {
1803 va_start(args, pat);
1804 vwarner(err, pat, &args);
1810 Perl_warner(pTHX_ U32 err, const char* pat,...)
1813 PERL_ARGS_ASSERT_WARNER;
1814 va_start(args, pat);
1815 vwarner(err, pat, &args);
1820 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1823 PERL_ARGS_ASSERT_VWARNER;
1824 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1825 SV * const msv = vmess(pat, args);
1827 invoke_exception_hook(msv, FALSE);
1831 Perl_vwarn(aTHX_ pat, args);
1835 /* implements the ckWARN? macros */
1838 Perl_ckwarn(pTHX_ U32 w)
1841 /* If lexical warnings have not been set, use $^W. */
1843 return PL_dowarn & G_WARN_ON;
1845 return ckwarn_common(w);
1848 /* implements the ckWARN?_d macro */
1851 Perl_ckwarn_d(pTHX_ U32 w)
1854 /* If lexical warnings have not been set then default classes warn. */
1858 return ckwarn_common(w);
1862 S_ckwarn_common(pTHX_ U32 w)
1864 if (PL_curcop->cop_warnings == pWARN_ALL)
1867 if (PL_curcop->cop_warnings == pWARN_NONE)
1870 /* Check the assumption that at least the first slot is non-zero. */
1871 assert(unpackWARN1(w));
1873 /* Check the assumption that it is valid to stop as soon as a zero slot is
1875 if (!unpackWARN2(w)) {
1876 assert(!unpackWARN3(w));
1877 assert(!unpackWARN4(w));
1878 } else if (!unpackWARN3(w)) {
1879 assert(!unpackWARN4(w));
1882 /* Right, dealt with all the special cases, which are implemented as non-
1883 pointers, so there is a pointer to a real warnings mask. */
1885 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1887 } while (w >>= WARNshift);
1892 /* Set buffer=NULL to get a new one. */
1894 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1896 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1897 PERL_UNUSED_CONTEXT;
1898 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1901 (specialWARN(buffer) ?
1902 PerlMemShared_malloc(len_wanted) :
1903 PerlMemShared_realloc(buffer, len_wanted));
1905 Copy(bits, (buffer + 1), size, char);
1909 /* since we've already done strlen() for both nam and val
1910 * we can use that info to make things faster than
1911 * sprintf(s, "%s=%s", nam, val)
1913 #define my_setenv_format(s, nam, nlen, val, vlen) \
1914 Copy(nam, s, nlen, char); \
1916 Copy(val, s+(nlen+1), vlen, char); \
1917 *(s+(nlen+1+vlen)) = '\0'
1919 #ifdef USE_ENVIRON_ARRAY
1920 /* VMS' my_setenv() is in vms.c */
1921 #if !defined(WIN32) && !defined(NETWARE)
1923 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1927 /* only parent thread can modify process environment */
1928 if (PL_curinterp == aTHX)
1931 #ifndef PERL_USE_SAFE_PUTENV
1932 if (!PL_use_safe_putenv) {
1933 /* most putenv()s leak, so we manipulate environ directly */
1935 register const I32 len = strlen(nam);
1938 /* where does it go? */
1939 for (i = 0; environ[i]; i++) {
1940 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1944 if (environ == PL_origenviron) { /* need we copy environment? */
1950 while (environ[max])
1952 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1953 for (j=0; j<max; j++) { /* copy environment */
1954 const int len = strlen(environ[j]);
1955 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1956 Copy(environ[j], tmpenv[j], len+1, char);
1959 environ = tmpenv; /* tell exec where it is now */
1962 safesysfree(environ[i]);
1963 while (environ[i]) {
1964 environ[i] = environ[i+1];
1969 if (!environ[i]) { /* does not exist yet */
1970 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1971 environ[i+1] = NULL; /* make sure it's null terminated */
1974 safesysfree(environ[i]);
1978 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1979 /* all that work just for this */
1980 my_setenv_format(environ[i], nam, nlen, val, vlen);
1983 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1984 # if defined(HAS_UNSETENV)
1986 (void)unsetenv(nam);
1988 (void)setenv(nam, val, 1);
1990 # else /* ! HAS_UNSETENV */
1991 (void)setenv(nam, val, 1);
1992 # endif /* HAS_UNSETENV */
1994 # if defined(HAS_UNSETENV)
1996 (void)unsetenv(nam);
1998 const int nlen = strlen(nam);
1999 const int vlen = strlen(val);
2000 char * const new_env =
2001 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2002 my_setenv_format(new_env, nam, nlen, val, vlen);
2003 (void)putenv(new_env);
2005 # else /* ! HAS_UNSETENV */
2007 const int nlen = strlen(nam);
2013 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2014 /* all that work just for this */
2015 my_setenv_format(new_env, nam, nlen, val, vlen);
2016 (void)putenv(new_env);
2017 # endif /* HAS_UNSETENV */
2018 # endif /* __CYGWIN__ */
2019 #ifndef PERL_USE_SAFE_PUTENV
2025 #else /* WIN32 || NETWARE */
2028 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2031 register char *envstr;
2032 const int nlen = strlen(nam);
2039 Newx(envstr, nlen+vlen+2, char);
2040 my_setenv_format(envstr, nam, nlen, val, vlen);
2041 (void)PerlEnv_putenv(envstr);
2045 #endif /* WIN32 || NETWARE */
2047 #endif /* !VMS && !EPOC*/
2049 #ifdef UNLINK_ALL_VERSIONS
2051 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2055 PERL_ARGS_ASSERT_UNLNK;
2057 while (PerlLIO_unlink(f) >= 0)
2059 return retries ? 0 : -1;
2063 /* this is a drop-in replacement for bcopy() */
2064 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2066 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2068 char * const retval = to;
2070 PERL_ARGS_ASSERT_MY_BCOPY;
2072 if (from - to >= 0) {
2080 *(--to) = *(--from);
2086 /* this is a drop-in replacement for memset() */
2089 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2091 char * const retval = loc;
2093 PERL_ARGS_ASSERT_MY_MEMSET;
2101 /* this is a drop-in replacement for bzero() */
2102 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2104 Perl_my_bzero(register char *loc, register I32 len)
2106 char * const retval = loc;
2108 PERL_ARGS_ASSERT_MY_BZERO;
2116 /* this is a drop-in replacement for memcmp() */
2117 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2119 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2121 register const U8 *a = (const U8 *)s1;
2122 register const U8 *b = (const U8 *)s2;
2125 PERL_ARGS_ASSERT_MY_MEMCMP;
2128 if ((tmp = *a++ - *b++))
2133 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2136 /* This vsprintf replacement should generally never get used, since
2137 vsprintf was available in both System V and BSD 2.11. (There may
2138 be some cross-compilation or embedded set-ups where it is needed,
2141 If you encounter a problem in this function, it's probably a symptom
2142 that Configure failed to detect your system's vprintf() function.
2143 See the section on "item vsprintf" in the INSTALL file.
2145 This version may compile on systems with BSD-ish <stdio.h>,
2146 but probably won't on others.
2149 #ifdef USE_CHAR_VSPRINTF
2154 vsprintf(char *dest, const char *pat, void *args)
2158 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2159 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2160 FILE_cnt(&fakebuf) = 32767;
2162 /* These probably won't compile -- If you really need
2163 this, you'll have to figure out some other method. */
2164 fakebuf._ptr = dest;
2165 fakebuf._cnt = 32767;
2170 fakebuf._flag = _IOWRT|_IOSTRG;
2171 _doprnt(pat, args, &fakebuf); /* what a kludge */
2172 #if defined(STDIO_PTR_LVALUE)
2173 *(FILE_ptr(&fakebuf)++) = '\0';
2175 /* PerlIO has probably #defined away fputc, but we want it here. */
2177 # undef fputc /* XXX Should really restore it later */
2179 (void)fputc('\0', &fakebuf);
2181 #ifdef USE_CHAR_VSPRINTF
2184 return 0; /* perl doesn't use return value */
2188 #endif /* HAS_VPRINTF */
2191 #if BYTEORDER != 0x4321
2193 Perl_my_swap(pTHX_ short s)
2195 #if (BYTEORDER & 1) == 0
2198 result = ((s & 255) << 8) + ((s >> 8) & 255);
2206 Perl_my_htonl(pTHX_ long l)
2210 char c[sizeof(long)];
2213 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2214 #if BYTEORDER == 0x12345678
2217 u.c[0] = (l >> 24) & 255;
2218 u.c[1] = (l >> 16) & 255;
2219 u.c[2] = (l >> 8) & 255;
2223 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2224 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2229 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2230 u.c[o & 0xf] = (l >> s) & 255;
2238 Perl_my_ntohl(pTHX_ long l)
2242 char c[sizeof(long)];
2245 #if BYTEORDER == 0x1234
2246 u.c[0] = (l >> 24) & 255;
2247 u.c[1] = (l >> 16) & 255;
2248 u.c[2] = (l >> 8) & 255;
2252 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2253 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2260 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2261 l |= (u.c[o & 0xf] & 255) << s;
2268 #endif /* BYTEORDER != 0x4321 */
2272 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2273 * If these functions are defined,
2274 * the BYTEORDER is neither 0x1234 nor 0x4321.
2275 * However, this is not assumed.
2279 #define HTOLE(name,type) \
2281 name (register type n) \
2285 char c[sizeof(type)]; \
2288 register U32 s = 0; \
2289 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2290 u.c[i] = (n >> s) & 0xFF; \
2295 #define LETOH(name,type) \
2297 name (register type n) \
2301 char c[sizeof(type)]; \
2304 register U32 s = 0; \
2307 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2308 n |= ((type)(u.c[i] & 0xFF)) << s; \
2314 * Big-endian byte order functions.
2317 #define HTOBE(name,type) \
2319 name (register type n) \
2323 char c[sizeof(type)]; \
2326 register U32 s = 8*(sizeof(u.c)-1); \
2327 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2328 u.c[i] = (n >> s) & 0xFF; \
2333 #define BETOH(name,type) \
2335 name (register type n) \
2339 char c[sizeof(type)]; \
2342 register U32 s = 8*(sizeof(u.c)-1); \
2345 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2346 n |= ((type)(u.c[i] & 0xFF)) << s; \
2352 * If we just can't do it...
2355 #define NOT_AVAIL(name,type) \
2357 name (register type n) \
2359 Perl_croak_nocontext(#name "() not available"); \
2360 return n; /* not reached */ \
2364 #if defined(HAS_HTOVS) && !defined(htovs)
2367 #if defined(HAS_HTOVL) && !defined(htovl)
2370 #if defined(HAS_VTOHS) && !defined(vtohs)
2373 #if defined(HAS_VTOHL) && !defined(vtohl)
2377 #ifdef PERL_NEED_MY_HTOLE16
2379 HTOLE(Perl_my_htole16,U16)
2381 NOT_AVAIL(Perl_my_htole16,U16)
2384 #ifdef PERL_NEED_MY_LETOH16
2386 LETOH(Perl_my_letoh16,U16)
2388 NOT_AVAIL(Perl_my_letoh16,U16)
2391 #ifdef PERL_NEED_MY_HTOBE16
2393 HTOBE(Perl_my_htobe16,U16)
2395 NOT_AVAIL(Perl_my_htobe16,U16)
2398 #ifdef PERL_NEED_MY_BETOH16
2400 BETOH(Perl_my_betoh16,U16)
2402 NOT_AVAIL(Perl_my_betoh16,U16)
2406 #ifdef PERL_NEED_MY_HTOLE32
2408 HTOLE(Perl_my_htole32,U32)
2410 NOT_AVAIL(Perl_my_htole32,U32)
2413 #ifdef PERL_NEED_MY_LETOH32
2415 LETOH(Perl_my_letoh32,U32)
2417 NOT_AVAIL(Perl_my_letoh32,U32)
2420 #ifdef PERL_NEED_MY_HTOBE32
2422 HTOBE(Perl_my_htobe32,U32)
2424 NOT_AVAIL(Perl_my_htobe32,U32)
2427 #ifdef PERL_NEED_MY_BETOH32
2429 BETOH(Perl_my_betoh32,U32)
2431 NOT_AVAIL(Perl_my_betoh32,U32)
2435 #ifdef PERL_NEED_MY_HTOLE64
2437 HTOLE(Perl_my_htole64,U64)
2439 NOT_AVAIL(Perl_my_htole64,U64)
2442 #ifdef PERL_NEED_MY_LETOH64
2444 LETOH(Perl_my_letoh64,U64)
2446 NOT_AVAIL(Perl_my_letoh64,U64)
2449 #ifdef PERL_NEED_MY_HTOBE64
2451 HTOBE(Perl_my_htobe64,U64)
2453 NOT_AVAIL(Perl_my_htobe64,U64)
2456 #ifdef PERL_NEED_MY_BETOH64
2458 BETOH(Perl_my_betoh64,U64)
2460 NOT_AVAIL(Perl_my_betoh64,U64)
2464 #ifdef PERL_NEED_MY_HTOLES
2465 HTOLE(Perl_my_htoles,short)
2467 #ifdef PERL_NEED_MY_LETOHS
2468 LETOH(Perl_my_letohs,short)
2470 #ifdef PERL_NEED_MY_HTOBES
2471 HTOBE(Perl_my_htobes,short)
2473 #ifdef PERL_NEED_MY_BETOHS
2474 BETOH(Perl_my_betohs,short)
2477 #ifdef PERL_NEED_MY_HTOLEI
2478 HTOLE(Perl_my_htolei,int)
2480 #ifdef PERL_NEED_MY_LETOHI
2481 LETOH(Perl_my_letohi,int)
2483 #ifdef PERL_NEED_MY_HTOBEI
2484 HTOBE(Perl_my_htobei,int)
2486 #ifdef PERL_NEED_MY_BETOHI
2487 BETOH(Perl_my_betohi,int)
2490 #ifdef PERL_NEED_MY_HTOLEL
2491 HTOLE(Perl_my_htolel,long)
2493 #ifdef PERL_NEED_MY_LETOHL
2494 LETOH(Perl_my_letohl,long)
2496 #ifdef PERL_NEED_MY_HTOBEL
2497 HTOBE(Perl_my_htobel,long)
2499 #ifdef PERL_NEED_MY_BETOHL
2500 BETOH(Perl_my_betohl,long)
2504 Perl_my_swabn(void *ptr, int n)
2506 register char *s = (char *)ptr;
2507 register char *e = s + (n-1);
2510 PERL_ARGS_ASSERT_MY_SWABN;
2512 for (n /= 2; n > 0; s++, e--, n--) {
2520 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2522 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2525 register I32 This, that;
2531 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2533 PERL_FLUSHALL_FOR_CHILD;
2534 This = (*mode == 'w');
2538 taint_proper("Insecure %s%s", "EXEC");
2540 if (PerlProc_pipe(p) < 0)
2542 /* Try for another pipe pair for error return */
2543 if (PerlProc_pipe(pp) >= 0)
2545 while ((pid = PerlProc_fork()) < 0) {
2546 if (errno != EAGAIN) {
2547 PerlLIO_close(p[This]);
2548 PerlLIO_close(p[that]);
2550 PerlLIO_close(pp[0]);
2551 PerlLIO_close(pp[1]);
2555 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2564 /* Close parent's end of error status pipe (if any) */
2566 PerlLIO_close(pp[0]);
2567 #if defined(HAS_FCNTL) && defined(F_SETFD)
2568 /* Close error pipe automatically if exec works */
2569 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2572 /* Now dup our end of _the_ pipe to right position */
2573 if (p[THIS] != (*mode == 'r')) {
2574 PerlLIO_dup2(p[THIS], *mode == 'r');
2575 PerlLIO_close(p[THIS]);
2576 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2577 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2580 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2581 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2582 /* No automatic close - do it by hand */
2589 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2595 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2601 do_execfree(); /* free any memory malloced by child on fork */
2603 PerlLIO_close(pp[1]);
2604 /* Keep the lower of the two fd numbers */
2605 if (p[that] < p[This]) {
2606 PerlLIO_dup2(p[This], p[that]);
2607 PerlLIO_close(p[This]);
2611 PerlLIO_close(p[that]); /* close child's end of pipe */
2613 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2614 SvUPGRADE(sv,SVt_IV);
2616 PL_forkprocess = pid;
2617 /* If we managed to get status pipe check for exec fail */
2618 if (did_pipes && pid > 0) {
2623 while (n < sizeof(int)) {
2624 n1 = PerlLIO_read(pp[0],
2625 (void*)(((char*)&errkid)+n),
2631 PerlLIO_close(pp[0]);
2633 if (n) { /* Error */
2635 PerlLIO_close(p[This]);
2636 if (n != sizeof(int))
2637 Perl_croak(aTHX_ "panic: kid popen errno read");
2639 pid2 = wait4pid(pid, &status, 0);
2640 } while (pid2 == -1 && errno == EINTR);
2641 errno = errkid; /* Propagate errno from kid */
2646 PerlLIO_close(pp[0]);
2647 return PerlIO_fdopen(p[This], mode);
2649 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2650 return my_syspopen4(aTHX_ NULL, mode, n, args);
2652 Perl_croak(aTHX_ "List form of piped open not implemented");
2653 return (PerlIO *) NULL;
2658 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2659 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2661 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2665 register I32 This, that;
2668 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2672 PERL_ARGS_ASSERT_MY_POPEN;
2674 PERL_FLUSHALL_FOR_CHILD;
2677 return my_syspopen(aTHX_ cmd,mode);
2680 This = (*mode == 'w');
2682 if (doexec && PL_tainting) {
2684 taint_proper("Insecure %s%s", "EXEC");
2686 if (PerlProc_pipe(p) < 0)
2688 if (doexec && PerlProc_pipe(pp) >= 0)
2690 while ((pid = PerlProc_fork()) < 0) {
2691 if (errno != EAGAIN) {
2692 PerlLIO_close(p[This]);
2693 PerlLIO_close(p[that]);
2695 PerlLIO_close(pp[0]);
2696 PerlLIO_close(pp[1]);
2699 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2702 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2713 PerlLIO_close(pp[0]);
2714 #if defined(HAS_FCNTL) && defined(F_SETFD)
2715 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2718 if (p[THIS] != (*mode == 'r')) {
2719 PerlLIO_dup2(p[THIS], *mode == 'r');
2720 PerlLIO_close(p[THIS]);
2721 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2722 PerlLIO_close(p[THAT]);
2725 PerlLIO_close(p[THAT]);
2728 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2735 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2740 /* may or may not use the shell */
2741 do_exec3(cmd, pp[1], did_pipes);
2744 #endif /* defined OS2 */
2746 #ifdef PERLIO_USING_CRLF
2747 /* Since we circumvent IO layers when we manipulate low-level
2748 filedescriptors directly, need to manually switch to the
2749 default, binary, low-level mode; see PerlIOBuf_open(). */
2750 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2753 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2754 SvREADONLY_off(GvSV(tmpgv));
2755 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2756 SvREADONLY_on(GvSV(tmpgv));
2758 #ifdef THREADS_HAVE_PIDS
2759 PL_ppid = (IV)getppid();
2762 #ifdef PERL_USES_PL_PIDSTATUS
2763 hv_clear(PL_pidstatus); /* we have no children */
2769 do_execfree(); /* free any memory malloced by child on vfork */
2771 PerlLIO_close(pp[1]);
2772 if (p[that] < p[This]) {
2773 PerlLIO_dup2(p[This], p[that]);
2774 PerlLIO_close(p[This]);
2778 PerlLIO_close(p[that]);
2780 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2781 SvUPGRADE(sv,SVt_IV);
2783 PL_forkprocess = pid;
2784 if (did_pipes && pid > 0) {
2789 while (n < sizeof(int)) {
2790 n1 = PerlLIO_read(pp[0],
2791 (void*)(((char*)&errkid)+n),
2797 PerlLIO_close(pp[0]);
2799 if (n) { /* Error */
2801 PerlLIO_close(p[This]);
2802 if (n != sizeof(int))
2803 Perl_croak(aTHX_ "panic: kid popen errno read");
2805 pid2 = wait4pid(pid, &status, 0);
2806 } while (pid2 == -1 && errno == EINTR);
2807 errno = errkid; /* Propagate errno from kid */
2812 PerlLIO_close(pp[0]);
2813 return PerlIO_fdopen(p[This], mode);
2816 #if defined(atarist) || defined(EPOC)
2819 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2821 PERL_ARGS_ASSERT_MY_POPEN;
2822 PERL_FLUSHALL_FOR_CHILD;
2823 /* Call system's popen() to get a FILE *, then import it.
2824 used 0 for 2nd parameter to PerlIO_importFILE;
2827 return PerlIO_importFILE(popen(cmd, mode), 0);
2831 FILE *djgpp_popen();
2833 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2835 PERL_FLUSHALL_FOR_CHILD;
2836 /* Call system's popen() to get a FILE *, then import it.
2837 used 0 for 2nd parameter to PerlIO_importFILE;
2840 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2843 #if defined(__LIBCATAMOUNT__)
2845 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2853 #endif /* !DOSISH */
2855 /* this is called in parent before the fork() */
2857 Perl_atfork_lock(void)
2860 #if defined(USE_ITHREADS)
2861 /* locks must be held in locking order (if any) */
2863 MUTEX_LOCK(&PL_malloc_mutex);
2869 /* this is called in both parent and child after the fork() */
2871 Perl_atfork_unlock(void)
2874 #if defined(USE_ITHREADS)
2875 /* locks must be released in same order as in atfork_lock() */
2877 MUTEX_UNLOCK(&PL_malloc_mutex);
2886 #if defined(HAS_FORK)
2888 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2893 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2894 * handlers elsewhere in the code */
2899 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2900 Perl_croak_nocontext("fork() not available");
2902 #endif /* HAS_FORK */
2907 Perl_dump_fds(pTHX_ const char *const s)
2912 PERL_ARGS_ASSERT_DUMP_FDS;
2914 PerlIO_printf(Perl_debug_log,"%s", s);
2915 for (fd = 0; fd < 32; fd++) {
2916 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2917 PerlIO_printf(Perl_debug_log," %d",fd);
2919 PerlIO_printf(Perl_debug_log,"\n");
2922 #endif /* DUMP_FDS */
2926 dup2(int oldfd, int newfd)
2928 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2931 PerlLIO_close(newfd);
2932 return fcntl(oldfd, F_DUPFD, newfd);
2934 #define DUP2_MAX_FDS 256
2935 int fdtmp[DUP2_MAX_FDS];
2941 PerlLIO_close(newfd);
2942 /* good enough for low fd's... */
2943 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2944 if (fdx >= DUP2_MAX_FDS) {
2952 PerlLIO_close(fdtmp[--fdx]);
2959 #ifdef HAS_SIGACTION
2962 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2965 struct sigaction act, oact;
2968 /* only "parent" interpreter can diddle signals */
2969 if (PL_curinterp != aTHX)
2970 return (Sighandler_t) SIG_ERR;
2973 act.sa_handler = (void(*)(int))handler;
2974 sigemptyset(&act.sa_mask);
2977 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2978 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2980 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2981 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2982 act.sa_flags |= SA_NOCLDWAIT;
2984 if (sigaction(signo, &act, &oact) == -1)
2985 return (Sighandler_t) SIG_ERR;
2987 return (Sighandler_t) oact.sa_handler;
2991 Perl_rsignal_state(pTHX_ int signo)
2993 struct sigaction oact;
2994 PERL_UNUSED_CONTEXT;
2996 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2997 return (Sighandler_t) SIG_ERR;
2999 return (Sighandler_t) oact.sa_handler;
3003 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3006 struct sigaction act;
3008 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3011 /* only "parent" interpreter can diddle signals */
3012 if (PL_curinterp != aTHX)
3016 act.sa_handler = (void(*)(int))handler;
3017 sigemptyset(&act.sa_mask);
3020 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3021 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3023 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3024 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3025 act.sa_flags |= SA_NOCLDWAIT;
3027 return sigaction(signo, &act, save);
3031 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3035 /* only "parent" interpreter can diddle signals */
3036 if (PL_curinterp != aTHX)
3040 return sigaction(signo, save, (struct sigaction *)NULL);
3043 #else /* !HAS_SIGACTION */
3046 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3048 #if defined(USE_ITHREADS) && !defined(WIN32)
3049 /* only "parent" interpreter can diddle signals */
3050 if (PL_curinterp != aTHX)
3051 return (Sighandler_t) SIG_ERR;
3054 return PerlProc_signal(signo, handler);
3065 Perl_rsignal_state(pTHX_ int signo)
3068 Sighandler_t oldsig;
3070 #if defined(USE_ITHREADS) && !defined(WIN32)
3071 /* only "parent" interpreter can diddle signals */
3072 if (PL_curinterp != aTHX)
3073 return (Sighandler_t) SIG_ERR;
3077 oldsig = PerlProc_signal(signo, sig_trap);
3078 PerlProc_signal(signo, oldsig);
3080 PerlProc_kill(PerlProc_getpid(), signo);
3085 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3087 #if defined(USE_ITHREADS) && !defined(WIN32)
3088 /* only "parent" interpreter can diddle signals */
3089 if (PL_curinterp != aTHX)
3092 *save = PerlProc_signal(signo, handler);
3093 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3097 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3099 #if defined(USE_ITHREADS) && !defined(WIN32)
3100 /* only "parent" interpreter can diddle signals */
3101 if (PL_curinterp != aTHX)
3104 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3107 #endif /* !HAS_SIGACTION */
3108 #endif /* !PERL_MICRO */
3110 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3111 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3113 Perl_my_pclose(pTHX_ PerlIO *ptr)
3116 Sigsave_t hstat, istat, qstat;
3124 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
3125 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3127 *svp = &PL_sv_undef;
3129 if (pid == -1) { /* Opened by popen. */
3130 return my_syspclose(ptr);
3133 close_failed = (PerlIO_close(ptr) == EOF);
3136 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
3139 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3140 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3141 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3144 pid2 = wait4pid(pid, &status, 0);
3145 } while (pid2 == -1 && errno == EINTR);
3147 rsignal_restore(SIGHUP, &hstat);
3148 rsignal_restore(SIGINT, &istat);
3149 rsignal_restore(SIGQUIT, &qstat);
3155 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
3158 #if defined(__LIBCATAMOUNT__)
3160 Perl_my_pclose(pTHX_ PerlIO *ptr)
3165 #endif /* !DOSISH */
3167 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3169 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3173 PERL_ARGS_ASSERT_WAIT4PID;
3176 #ifdef PERL_USES_PL_PIDSTATUS
3179 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3180 pid, rather than a string form. */
3181 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3182 if (svp && *svp != &PL_sv_undef) {
3183 *statusp = SvIVX(*svp);
3184 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3192 hv_iterinit(PL_pidstatus);
3193 if ((entry = hv_iternext(PL_pidstatus))) {
3194 SV * const sv = hv_iterval(PL_pidstatus,entry);
3196 const char * const spid = hv_iterkey(entry,&len);
3198 assert (len == sizeof(Pid_t));
3199 memcpy((char *)&pid, spid, len);
3200 *statusp = SvIVX(sv);
3201 /* The hash iterator is currently on this entry, so simply
3202 calling hv_delete would trigger the lazy delete, which on
3203 aggregate does more work, beacuse next call to hv_iterinit()
3204 would spot the flag, and have to call the delete routine,
3205 while in the meantime any new entries can't re-use that
3207 hv_iterinit(PL_pidstatus);
3208 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3215 # ifdef HAS_WAITPID_RUNTIME
3216 if (!HAS_WAITPID_RUNTIME)
3219 result = PerlProc_waitpid(pid,statusp,flags);
3222 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3223 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3226 #ifdef PERL_USES_PL_PIDSTATUS
3227 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3232 Perl_croak(aTHX_ "Can't do waitpid with flags");
3234 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3235 pidgone(result,*statusp);
3241 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3244 if (result < 0 && errno == EINTR) {
3246 errno = EINTR; /* reset in case a signal handler changed $! */
3250 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3252 #ifdef PERL_USES_PL_PIDSTATUS
3254 S_pidgone(pTHX_ Pid_t pid, int status)
3258 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3259 SvUPGRADE(sv,SVt_IV);
3260 SvIV_set(sv, status);
3265 #if defined(atarist) || defined(OS2) || defined(EPOC)
3268 int /* Cannot prototype with I32
3270 my_syspclose(PerlIO *ptr)
3273 Perl_my_pclose(pTHX_ PerlIO *ptr)
3276 /* Needs work for PerlIO ! */
3277 FILE * const f = PerlIO_findFILE(ptr);
3278 const I32 result = pclose(f);
3279 PerlIO_releaseFILE(ptr,f);
3287 Perl_my_pclose(pTHX_ PerlIO *ptr)
3289 /* Needs work for PerlIO ! */
3290 FILE * const f = PerlIO_findFILE(ptr);
3291 I32 result = djgpp_pclose(f);
3292 result = (result << 8) & 0xff00;
3293 PerlIO_releaseFILE(ptr,f);
3298 #define PERL_REPEATCPY_LINEAR 4
3300 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3302 PERL_ARGS_ASSERT_REPEATCPY;
3305 memset(to, *from, count);
3307 register char *p = to;
3308 I32 items, linear, half;
3310 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3311 for (items = 0; items < linear; ++items) {
3312 register const char *q = from;
3314 for (todo = len; todo > 0; todo--)
3319 while (items <= half) {
3320 I32 size = items * len;
3321 memcpy(p, to, size);
3327 memcpy(p, to, (count - items) * len);
3333 Perl_same_dirent(pTHX_ const char *a, const char *b)
3335 char *fa = strrchr(a,'/');
3336 char *fb = strrchr(b,'/');
3339 SV * const tmpsv = sv_newmortal();
3341 PERL_ARGS_ASSERT_SAME_DIRENT;
3354 sv_setpvs(tmpsv, ".");
3356 sv_setpvn(tmpsv, a, fa - a);
3357 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3360 sv_setpvs(tmpsv, ".");
3362 sv_setpvn(tmpsv, b, fb - b);
3363 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3365 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3366 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3368 #endif /* !HAS_RENAME */
3371 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3372 const char *const *const search_ext, I32 flags)
3375 const char *xfound = NULL;
3376 char *xfailed = NULL;
3377 char tmpbuf[MAXPATHLEN];
3382 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3383 # define SEARCH_EXTS ".bat", ".cmd", NULL
3384 # define MAX_EXT_LEN 4
3387 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3388 # define MAX_EXT_LEN 4
3391 # define SEARCH_EXTS ".pl", ".com", NULL
3392 # define MAX_EXT_LEN 4
3394 /* additional extensions to try in each dir if scriptname not found */
3396 static const char *const exts[] = { SEARCH_EXTS };
3397 const char *const *const ext = search_ext ? search_ext : exts;
3398 int extidx = 0, i = 0;
3399 const char *curext = NULL;
3401 PERL_UNUSED_ARG(search_ext);
3402 # define MAX_EXT_LEN 0
3405 PERL_ARGS_ASSERT_FIND_SCRIPT;
3408 * If dosearch is true and if scriptname does not contain path
3409 * delimiters, search the PATH for scriptname.
3411 * If SEARCH_EXTS is also defined, will look for each
3412 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3413 * while searching the PATH.
3415 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3416 * proceeds as follows:
3417 * If DOSISH or VMSISH:
3418 * + look for ./scriptname{,.foo,.bar}
3419 * + search the PATH for scriptname{,.foo,.bar}
3422 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3423 * this will not look in '.' if it's not in the PATH)
3428 # ifdef ALWAYS_DEFTYPES
3429 len = strlen(scriptname);
3430 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3431 int idx = 0, deftypes = 1;
3434 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3437 int idx = 0, deftypes = 1;
3440 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3442 /* The first time through, just add SEARCH_EXTS to whatever we
3443 * already have, so we can check for default file types. */
3445 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3451 if ((strlen(tmpbuf) + strlen(scriptname)
3452 + MAX_EXT_LEN) >= sizeof tmpbuf)
3453 continue; /* don't search dir with too-long name */
3454 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3458 if (strEQ(scriptname, "-"))
3460 if (dosearch) { /* Look in '.' first. */
3461 const char *cur = scriptname;
3463 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3465 if (strEQ(ext[i++],curext)) {
3466 extidx = -1; /* already has an ext */
3471 DEBUG_p(PerlIO_printf(Perl_debug_log,
3472 "Looking for %s\n",cur));
3473 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3474 && !S_ISDIR(PL_statbuf.st_mode)) {
3482 if (cur == scriptname) {
3483 len = strlen(scriptname);
3484 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3486 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3489 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3490 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3495 if (dosearch && !strchr(scriptname, '/')
3497 && !strchr(scriptname, '\\')
3499 && (s = PerlEnv_getenv("PATH")))
3503 bufend = s + strlen(s);
3504 while (s < bufend) {
3505 #if defined(atarist) || defined(DOSISH)
3510 && *s != ';'; len++, s++) {
3511 if (len < sizeof tmpbuf)
3514 if (len < sizeof tmpbuf)
3516 #else /* ! (atarist || DOSISH) */
3517 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3520 #endif /* ! (atarist || DOSISH) */
3523 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3524 continue; /* don't search dir with too-long name */
3526 # if defined(atarist) || defined(DOSISH)
3527 && tmpbuf[len - 1] != '/'
3528 && tmpbuf[len - 1] != '\\'
3531 tmpbuf[len++] = '/';
3532 if (len == 2 && tmpbuf[0] == '.')
3534 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3538 len = strlen(tmpbuf);
3539 if (extidx > 0) /* reset after previous loop */
3543 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3544 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3545 if (S_ISDIR(PL_statbuf.st_mode)) {
3549 } while ( retval < 0 /* not there */
3550 && extidx>=0 && ext[extidx] /* try an extension? */
3551 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3556 if (S_ISREG(PL_statbuf.st_mode)
3557 && cando(S_IRUSR,TRUE,&PL_statbuf)
3558 #if !defined(DOSISH)
3559 && cando(S_IXUSR,TRUE,&PL_statbuf)
3563 xfound = tmpbuf; /* bingo! */
3567 xfailed = savepv(tmpbuf);
3570 if (!xfound && !seen_dot && !xfailed &&
3571 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3572 || S_ISDIR(PL_statbuf.st_mode)))
3574 seen_dot = 1; /* Disable message. */
3576 if (flags & 1) { /* do or die? */
3577 Perl_croak(aTHX_ "Can't %s %s%s%s",
3578 (xfailed ? "execute" : "find"),
3579 (xfailed ? xfailed : scriptname),
3580 (xfailed ? "" : " on PATH"),
3581 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3586 scriptname = xfound;
3588 return (scriptname ? savepv(scriptname) : NULL);
3591 #ifndef PERL_GET_CONTEXT_DEFINED
3594 Perl_get_context(void)
3597 #if defined(USE_ITHREADS)
3598 # ifdef OLD_PTHREADS_API
3600 if (pthread_getspecific(PL_thr_key, &t))
3601 Perl_croak_nocontext("panic: pthread_getspecific");
3604 # ifdef I_MACH_CTHREADS
3605 return (void*)cthread_data(cthread_self());
3607 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3616 Perl_set_context(void *t)
3619 PERL_ARGS_ASSERT_SET_CONTEXT;
3620 #if defined(USE_ITHREADS)
3621 # ifdef I_MACH_CTHREADS
3622 cthread_set_data(cthread_self(), t);
3624 if (pthread_setspecific(PL_thr_key, t))
3625 Perl_croak_nocontext("panic: pthread_setspecific");
3632 #endif /* !PERL_GET_CONTEXT_DEFINED */
3634 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3643 Perl_get_op_names(pTHX)
3645 PERL_UNUSED_CONTEXT;
3646 return (char **)PL_op_name;
3650 Perl_get_op_descs(pTHX)
3652 PERL_UNUSED_CONTEXT;
3653 return (char **)PL_op_desc;
3657 Perl_get_no_modify(pTHX)
3659 PERL_UNUSED_CONTEXT;
3660 return PL_no_modify;
3664 Perl_get_opargs(pTHX)
3666 PERL_UNUSED_CONTEXT;
3667 return (U32 *)PL_opargs;
3671 Perl_get_ppaddr(pTHX)
3674 PERL_UNUSED_CONTEXT;
3675 return (PPADDR_t*)PL_ppaddr;
3678 #ifndef HAS_GETENV_LEN
3680 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3682 char * const env_trans = PerlEnv_getenv(env_elem);
3683 PERL_UNUSED_CONTEXT;
3684 PERL_ARGS_ASSERT_GETENV_LEN;
3686 *len = strlen(env_trans);
3693 Perl_get_vtbl(pTHX_ int vtbl_id)
3695 const MGVTBL* result;
3696 PERL_UNUSED_CONTEXT;
3700 result = &PL_vtbl_sv;
3703 result = &PL_vtbl_env;
3705 case want_vtbl_envelem:
3706 result = &PL_vtbl_envelem;
3709 result = &PL_vtbl_sig;
3711 case want_vtbl_sigelem:
3712 result = &PL_vtbl_sigelem;
3714 case want_vtbl_pack:
3715 result = &PL_vtbl_pack;
3717 case want_vtbl_packelem:
3718 result = &PL_vtbl_packelem;
3720 case want_vtbl_dbline:
3721 result = &PL_vtbl_dbline;
3724 result = &PL_vtbl_isa;
3726 case want_vtbl_isaelem:
3727 result = &PL_vtbl_isaelem;
3729 case want_vtbl_arylen:
3730 result = &PL_vtbl_arylen;
3732 case want_vtbl_mglob:
3733 result = &PL_vtbl_mglob;
3735 case want_vtbl_nkeys:
3736 result = &PL_vtbl_nkeys;
3738 case want_vtbl_taint:
3739 result = &PL_vtbl_taint;
3741 case want_vtbl_substr:
3742 result = &PL_vtbl_substr;
3745 result = &PL_vtbl_vec;
3748 result = &PL_vtbl_pos;
3751 result = &PL_vtbl_bm;
3754 result = &PL_vtbl_fm;
3756 case want_vtbl_uvar:
3757 result = &PL_vtbl_uvar;
3759 case want_vtbl_defelem:
3760 result = &PL_vtbl_defelem;
3762 case want_vtbl_regexp:
3763 result = &PL_vtbl_regexp;
3765 case want_vtbl_regdata:
3766 result = &PL_vtbl_regdata;
3768 case want_vtbl_regdatum:
3769 result = &PL_vtbl_regdatum;
3771 #ifdef USE_LOCALE_COLLATE
3772 case want_vtbl_collxfrm:
3773 result = &PL_vtbl_collxfrm;
3776 case want_vtbl_amagic:
3777 result = &PL_vtbl_amagic;
3779 case want_vtbl_amagicelem:
3780 result = &PL_vtbl_amagicelem;
3782 case want_vtbl_backref:
3783 result = &PL_vtbl_backref;
3785 case want_vtbl_utf8:
3786 result = &PL_vtbl_utf8;
3792 return (MGVTBL*)result;
3796 Perl_my_fflush_all(pTHX)
3798 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3799 return PerlIO_flush(NULL);
3801 # if defined(HAS__FWALK)
3802 extern int fflush(FILE *);
3803 /* undocumented, unprototyped, but very useful BSDism */
3804 extern void _fwalk(int (*)(FILE *));
3808 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3810 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3811 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3813 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3814 open_max = sysconf(_SC_OPEN_MAX);
3817 open_max = FOPEN_MAX;
3820 open_max = OPEN_MAX;
3831 for (i = 0; i < open_max; i++)
3832 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3833 STDIO_STREAM_ARRAY[i]._file < open_max &&
3834 STDIO_STREAM_ARRAY[i]._flag)
3835 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3839 SETERRNO(EBADF,RMS_IFI);
3846 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3848 const char * const name
3849 = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3851 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3852 if (ckWARN(WARN_IO)) {
3853 const char * const direction =
3854 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3856 Perl_warner(aTHX_ packWARN(WARN_IO),
3857 "Filehandle %s opened only for %sput",
3860 Perl_warner(aTHX_ packWARN(WARN_IO),
3861 "Filehandle opened only for %sput", direction);
3868 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3870 warn_type = WARN_CLOSED;
3874 warn_type = WARN_UNOPENED;
3877 if (ckWARN(warn_type)) {
3878 const char * const pars =
3879 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3880 const char * const func =
3882 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3883 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3884 op < 0 ? "" : /* handle phoney cases */
3886 const char * const type =
3888 (OP_IS_SOCKET(op) ||
3889 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3890 "socket" : "filehandle");
3891 if (name && *name) {
3892 Perl_warner(aTHX_ packWARN(warn_type),
3893 "%s%s on %s %s %s", func, pars, vile, type, name);
3894 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3896 aTHX_ packWARN(warn_type),
3897 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3902 Perl_warner(aTHX_ packWARN(warn_type),
3903 "%s%s on %s %s", func, pars, vile, type);
3904 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3906 aTHX_ packWARN(warn_type),
3907 "\t(Are you trying to call %s%s on dirhandle?)\n",
3915 /* XXX Add documentation after final interface and behavior is decided */
3916 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
3917 U8 source = *current;
3919 May want to add eg, WARN_REGEX
3923 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
3928 if (! isASCII(source)) {
3929 Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
3932 result = toCTRL(source);
3933 if (! isCNTRL(result)) {
3934 if (source == '{') {
3935 Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
3937 else if (output_warning) {
3940 if (! isALNUM(result)) {
3941 clearer[i++] = '\\';
3943 clearer[i++] = result;
3944 clearer[i++] = '\0';
3946 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
3947 "\"\\c%c\" more clearly written simply as \"%s\"",
3957 Perl_grok_bslash_o(pTHX_ const char *s,
3960 const char** error_msg,
3961 const bool output_warning)
3964 /* Documentation to be supplied when interface nailed down finally
3965 * This returns FALSE if there is an error which the caller need not recover
3966 * from; , otherwise TRUE. In either case the caller should look at *len
3968 * s points to a string that begins with 'o', and the previous character
3970 * uv points to a UV that will hold the output value, valid only if the
3971 * return from the function is TRUE
3972 * len on success will point to the next character in the string past the
3973 * end of this construct.
3974 * on failure, it will point to the failure
3975 * error_msg is a pointer that will be set to an internal buffer giving an
3976 * error message upon failure (the return is FALSE). Untouched if
3978 * output_warning says whether to output any warning messages, or suppress
3983 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3984 | PERL_SCAN_DISALLOW_PREFIX
3985 /* XXX Until the message is improved in grok_oct, handle errors
3987 | PERL_SCAN_SILENT_ILLDIGIT;
3989 PERL_ARGS_ASSERT_GROK_BSLASH_O;
3996 *len = 1; /* Move past the o */
3997 *error_msg = "Missing braces on \\o{}";
4003 *len = 2; /* Move past the o{ */
4004 *error_msg = "Missing right brace on \\o{";
4008 /* Return past the '}' no matter what is inside the braces */
4009 *len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */
4011 s++; /* Point to first digit */
4013 numbers_len = e - s;
4014 if (numbers_len == 0) {
4015 *error_msg = "Number with no digits";
4019 *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
4020 /* Note that if has non-octal, will ignore everything starting with that up
4023 if (output_warning && numbers_len != (STRLEN) (e - s)) {
4024 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
4025 /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
4026 "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
4035 /* To workaround core dumps from the uninitialised tm_zone we get the
4036 * system to give us a reasonable struct to copy. This fix means that
4037 * strftime uses the tm_zone and tm_gmtoff values returned by
4038 * localtime(time()). That should give the desired result most of the
4039 * time. But probably not always!
4041 * This does not address tzname aspects of NETaa14816.
4046 # ifndef STRUCT_TM_HASZONE
4047 # define STRUCT_TM_HASZONE
4051 #ifdef STRUCT_TM_HASZONE /* Backward compat */
4052 # ifndef HAS_TM_TM_ZONE
4053 # define HAS_TM_TM_ZONE
4058 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
4060 #ifdef HAS_TM_TM_ZONE
4062 const struct tm* my_tm;
4063 PERL_ARGS_ASSERT_INIT_TM;
4065 my_tm = localtime(&now);
4067 Copy(my_tm, ptm, 1, struct tm);
4069 PERL_ARGS_ASSERT_INIT_TM;
4070 PERL_UNUSED_ARG(ptm);
4075 * mini_mktime - normalise struct tm values without the localtime()
4076 * semantics (and overhead) of mktime().
4079 Perl_mini_mktime(pTHX_ struct tm *ptm)
4083 int month, mday, year, jday;
4084 int odd_cent, odd_year;
4085 PERL_UNUSED_CONTEXT;
4087 PERL_ARGS_ASSERT_MINI_MKTIME;
4089 #define DAYS_PER_YEAR 365
4090 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
4091 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
4092 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
4093 #define SECS_PER_HOUR (60*60)
4094 #define SECS_PER_DAY (24*SECS_PER_HOUR)
4095 /* parentheses deliberately absent on these two, otherwise they don't work */
4096 #define MONTH_TO_DAYS 153/5
4097 #define DAYS_TO_MONTH 5/153
4098 /* offset to bias by March (month 4) 1st between month/mday & year finding */
4099 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
4100 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
4101 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
4104 * Year/day algorithm notes:
4106 * With a suitable offset for numeric value of the month, one can find
4107 * an offset into the year by considering months to have 30.6 (153/5) days,
4108 * using integer arithmetic (i.e., with truncation). To avoid too much
4109 * messing about with leap days, we consider January and February to be
4110 * the 13th and 14th month of the previous year. After that transformation,
4111 * we need the month index we use to be high by 1 from 'normal human' usage,
4112 * so the month index values we use run from 4 through 15.
4114 * Given that, and the rules for the Gregorian calendar (leap years are those
4115 * divisible by 4 unless also divisible by 100, when they must be divisible
4116 * by 400 instead), we can simply calculate the number of days since some
4117 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4118 * the days we derive from our month index, and adding in the day of the
4119 * month. The value used here is not adjusted for the actual origin which
4120 * it normally would use (1 January A.D. 1), since we're not exposing it.
4121 * We're only building the value so we can turn around and get the
4122 * normalised values for the year, month, day-of-month, and day-of-year.
4124 * For going backward, we need to bias the value we're using so that we find
4125 * the right year value. (Basically, we don't want the contribution of
4126 * March 1st to the number to apply while deriving the year). Having done
4127 * that, we 'count up' the contribution to the year number by accounting for
4128 * full quadracenturies (400-year periods) with their extra leap days, plus
4129 * the contribution from full centuries (to avoid counting in the lost leap
4130 * days), plus the contribution from full quad-years (to count in the normal
4131 * leap days), plus the leftover contribution from any non-leap years.
4132 * At this point, if we were working with an actual leap day, we'll have 0
4133 * days left over. This is also true for March 1st, however. So, we have
4134 * to special-case that result, and (earlier) keep track of the 'odd'
4135 * century and year contributions. If we got 4 extra centuries in a qcent,
4136 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4137 * Otherwise, we add back in the earlier bias we removed (the 123 from
4138 * figuring in March 1st), find the month index (integer division by 30.6),
4139 * and the remainder is the day-of-month. We then have to convert back to
4140 * 'real' months (including fixing January and February from being 14/15 in
4141 * the previous year to being in the proper year). After that, to get
4142 * tm_yday, we work with the normalised year and get a new yearday value for
4143 * January 1st, which we subtract from the yearday value we had earlier,
4144 * representing the date we've re-built. This is done from January 1
4145 * because tm_yday is 0-origin.
4147 * Since POSIX time routines are only guaranteed to work for times since the
4148 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4149 * applies Gregorian calendar rules even to dates before the 16th century
4150 * doesn't bother me. Besides, you'd need cultural context for a given
4151 * date to know whether it was Julian or Gregorian calendar, and that's
4152 * outside the scope for this routine. Since we convert back based on the
4153 * same rules we used to build the yearday, you'll only get strange results
4154 * for input which needed normalising, or for the 'odd' century years which
4155 * were leap years in the Julian calander but not in the Gregorian one.
4156 * I can live with that.
4158 * This algorithm also fails to handle years before A.D. 1 gracefully, but
4159 * that's still outside the scope for POSIX time manipulation, so I don't
4163 year = 1900 + ptm->tm_year;
4164 month = ptm->tm_mon;
4165 mday = ptm->tm_mday;
4166 /* allow given yday with no month & mday to dominate the result */
4167 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4170 jday = 1 + ptm->tm_yday;
4179 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4180 yearday += month*MONTH_TO_DAYS + mday + jday;
4182 * Note that we don't know when leap-seconds were or will be,
4183 * so we have to trust the user if we get something which looks
4184 * like a sensible leap-second. Wild values for seconds will
4185 * be rationalised, however.
4187 if ((unsigned) ptm->tm_sec <= 60) {
4194 secs += 60 * ptm->tm_min;
4195 secs += SECS_PER_HOUR * ptm->tm_hour;
4197 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4198 /* got negative remainder, but need positive time */
4199 /* back off an extra day to compensate */
4200 yearday += (secs/SECS_PER_DAY)-1;
4201 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4204 yearday += (secs/SECS_PER_DAY);
4205 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4208 else if (secs >= SECS_PER_DAY) {
4209 yearday += (secs/SECS_PER_DAY);
4210 secs %= SECS_PER_DAY;
4212 ptm->tm_hour = secs/SECS_PER_HOUR;
4213 secs %= SECS_PER_HOUR;
4214 ptm->tm_min = secs/60;
4216 ptm->tm_sec += secs;
4217 /* done with time of day effects */
4219 * The algorithm for yearday has (so far) left it high by 428.
4220 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4221 * bias it by 123 while trying to figure out what year it
4222 * really represents. Even with this tweak, the reverse
4223 * translation fails for years before A.D. 0001.
4224 * It would still fail for Feb 29, but we catch that one below.
4226 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
4227 yearday -= YEAR_ADJUST;
4228 year = (yearday / DAYS_PER_QCENT) * 400;
4229 yearday %= DAYS_PER_QCENT;
4230 odd_cent = yearday / DAYS_PER_CENT;
4231 year += odd_cent * 100;
4232 yearday %= DAYS_PER_CENT;
4233 year += (yearday / DAYS_PER_QYEAR) * 4;
4234 yearday %= DAYS_PER_QYEAR;
4235 odd_year = yearday / DAYS_PER_YEAR;
4237 yearday %= DAYS_PER_YEAR;
4238 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4243 yearday += YEAR_ADJUST; /* recover March 1st crock */
4244 month = yearday*DAYS_TO_MONTH;
4245 yearday -= month*MONTH_TO_DAYS;
4246 /* recover other leap-year adjustment */
4255 ptm->tm_year = year - 1900;
4257 ptm->tm_mday = yearday;
4258 ptm->tm_mon = month;
4262 ptm->tm_mon = month - 1;
4264 /* re-build yearday based on Jan 1 to get tm_yday */
4266 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4267 yearday += 14*MONTH_TO_DAYS + 1;
4268 ptm->tm_yday = jday - yearday;
4269 /* fix tm_wday if not overridden by caller */
4270 if ((unsigned)ptm->tm_wday > 6)
4271 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4275 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)
4283 PERL_ARGS_ASSERT_MY_STRFTIME;
4285 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4288 mytm.tm_hour = hour;
4289 mytm.tm_mday = mday;
4291 mytm.tm_year = year;
4292 mytm.tm_wday = wday;
4293 mytm.tm_yday = yday;
4294 mytm.tm_isdst = isdst;
4296 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4297 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4302 #ifdef HAS_TM_TM_GMTOFF
4303 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4305 #ifdef HAS_TM_TM_ZONE
4306 mytm.tm_zone = mytm2.tm_zone;
4311 Newx(buf, buflen, char);
4312 len = strftime(buf, buflen, fmt, &mytm);
4314 ** The following is needed to handle to the situation where
4315 ** tmpbuf overflows. Basically we want to allocate a buffer
4316 ** and try repeatedly. The reason why it is so complicated
4317 ** is that getting a return value of 0 from strftime can indicate
4318 ** one of the following:
4319 ** 1. buffer overflowed,
4320 ** 2. illegal conversion specifier, or
4321 ** 3. the format string specifies nothing to be returned(not
4322 ** an error). This could be because format is an empty string
4323 ** or it specifies %p that yields an empty string in some locale.
4324 ** If there is a better way to make it portable, go ahead by
4327 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4330 /* Possibly buf overflowed - try again with a bigger buf */
4331 const int fmtlen = strlen(fmt);
4332 int bufsize = fmtlen + buflen;
4334 Renew(buf, bufsize, char);
4336 buflen = strftime(buf, bufsize, fmt, &mytm);
4337 if (buflen > 0 && buflen < bufsize)
4339 /* heuristic to prevent out-of-memory errors */
4340 if (bufsize > 100*fmtlen) {
4346 Renew(buf, bufsize, char);
4351 Perl_croak(aTHX_ "panic: no strftime");
4357 #define SV_CWD_RETURN_UNDEF \
4358 sv_setsv(sv, &PL_sv_undef); \
4361 #define SV_CWD_ISDOT(dp) \
4362 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4363 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4366 =head1 Miscellaneous Functions
4368 =for apidoc getcwd_sv
4370 Fill the sv with current working directory
4375 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4376 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4377 * getcwd(3) if available
4378 * Comments from the orignal:
4379 * This is a faster version of getcwd. It's also more dangerous
4380 * because you might chdir out of a directory that you can't chdir
4384 Perl_getcwd_sv(pTHX_ register SV *sv)
4388 #ifndef INCOMPLETE_TAINTS
4392 PERL_ARGS_ASSERT_GETCWD_SV;
4396 char buf[MAXPATHLEN];
4398 /* Some getcwd()s automatically allocate a buffer of the given
4399 * size from the heap if they are given a NULL buffer pointer.
4400 * The problem is that this behaviour is not portable. */
4401 if (getcwd(buf, sizeof(buf) - 1)) {
4406 sv_setsv(sv, &PL_sv_undef);
4414 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4418 SvUPGRADE(sv, SVt_PV);
4420 if (PerlLIO_lstat(".", &statbuf) < 0) {
4421 SV_CWD_RETURN_UNDEF;
4424 orig_cdev = statbuf.st_dev;
4425 orig_cino = statbuf.st_ino;
4435 if (PerlDir_chdir("..") < 0) {
4436 SV_CWD_RETURN_UNDEF;
4438 if (PerlLIO_stat(".", &statbuf) < 0) {
4439 SV_CWD_RETURN_UNDEF;
4442 cdev = statbuf.st_dev;
4443 cino = statbuf.st_ino;
4445 if (odev == cdev && oino == cino) {
4448 if (!(dir = PerlDir_open("."))) {
4449 SV_CWD_RETURN_UNDEF;
4452 while ((dp = PerlDir_read(dir)) != NULL) {
4454 namelen = dp->d_namlen;
4456 namelen = strlen(dp->d_name);
4459 if (SV_CWD_ISDOT(dp)) {
4463 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4464 SV_CWD_RETURN_UNDEF;
4467 tdev = statbuf.st_dev;
4468 tino = statbuf.st_ino;
4469 if (tino == oino && tdev == odev) {
4475 SV_CWD_RETURN_UNDEF;
4478 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4479 SV_CWD_RETURN_UNDEF;
4482 SvGROW(sv, pathlen + namelen + 1);
4486 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4489 /* prepend current directory to the front */
4491 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4492 pathlen += (namelen + 1);
4494 #ifdef VOID_CLOSEDIR
4497 if (PerlDir_close(dir) < 0) {
4498 SV_CWD_RETURN_UNDEF;
4504 SvCUR_set(sv, pathlen);
4508 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4509 SV_CWD_RETURN_UNDEF;
4512 if (PerlLIO_stat(".", &statbuf) < 0) {
4513 SV_CWD_RETURN_UNDEF;
4516 cdev = statbuf.st_dev;
4517 cino = statbuf.st_ino;
4519 if (cdev != orig_cdev || cino != orig_cino) {
4520 Perl_croak(aTHX_ "Unstable directory path, "
4521 "current directory changed unexpectedly");
4532 #define VERSION_MAX 0x7FFFFFFF
4535 =for apidoc prescan_version
4540 Perl_prescan_version(pTHX_ const char *s, bool strict,
4541 const char **errstr,
4542 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4543 bool qv = (sqv ? *sqv : FALSE);
4545 int saw_decimal = 0;
4549 PERL_ARGS_ASSERT_PRESCAN_VERSION;
4551 if (qv && isDIGIT(*d))
4552 goto dotted_decimal_version;
4554 if (*d == 'v') { /* explicit v-string */
4559 else { /* degenerate v-string */
4560 /* requires v1.2.3 */
4561 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4564 dotted_decimal_version:
4565 if (strict && d[0] == '0' && isDIGIT(d[1])) {
4566 /* no leading zeros allowed */
4567 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4570 while (isDIGIT(*d)) /* integer part */
4576 d++; /* decimal point */
4581 /* require v1.2.3 */
4582 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4585 goto version_prescan_finish;
4592 while (isDIGIT(*d)) { /* just keep reading */
4594 while (isDIGIT(*d)) {
4596 /* maximum 3 digits between decimal */
4597 if (strict && j > 3) {
4598 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4603 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4606 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4611 else if (*d == '.') {
4613 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4618 else if (!isDIGIT(*d)) {
4624 if (strict && i < 2) {
4625 /* requires v1.2.3 */
4626 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4629 } /* end if dotted-decimal */
4631 { /* decimal versions */
4632 /* special strict case for leading '.' or '0' */
4635 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4637 if (*d == '0' && isDIGIT(d[1])) {
4638 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4642 /* consume all of the integer part */
4646 /* look for a fractional part */
4648 /* we found it, so consume it */
4652 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4655 BADVERSION(s,errstr,"Invalid version format (version required)");
4657 /* found just an integer */
4658 goto version_prescan_finish;
4660 else if ( d == s ) {
4661 /* didn't find either integer or period */
4662 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4664 else if (*d == '_') {
4665 /* underscore can't come after integer part */
4667 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4669 else if (isDIGIT(d[1])) {
4670 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4673 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4677 /* anything else after integer part is just invalid data */
4678 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4681 /* scan the fractional part after the decimal point*/
4683 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4684 /* strict or lax-but-not-the-end */
4685 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4688 while (isDIGIT(*d)) {
4690 if (*d == '.' && isDIGIT(d[-1])) {
4692 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4695 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4697 d = (char *)s; /* start all over again */
4699 goto dotted_decimal_version;
4703 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4706 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4708 if ( ! isDIGIT(d[1]) ) {
4709 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4717 version_prescan_finish:
4721 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4722 /* trailing non-numeric data */
4723 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4731 *ssaw_decimal = saw_decimal;
4738 =for apidoc scan_version
4740 Returns a pointer to the next character after the parsed
4741 version string, as well as upgrading the passed in SV to
4744 Function must be called with an already existing SV like
4747 s = scan_version(s, SV *sv, bool qv);
4749 Performs some preprocessing to the string to ensure that
4750 it has the correct characteristics of a version. Flags the
4751 object if it contains an underscore (which denotes this
4752 is an alpha version). The boolean qv denotes that the version
4753 should be interpreted as if it had multiple decimals, even if
4760 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4765 const char *errstr = NULL;
4766 int saw_decimal = 0;
4770 AV * const av = newAV();
4771 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4773 PERL_ARGS_ASSERT_SCAN_VERSION;
4775 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4777 #ifndef NODEFAULT_SHAREKEYS
4778 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4781 while (isSPACE(*s)) /* leading whitespace is OK */
4784 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4786 /* "undef" is a special case and not an error */
4787 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4788 Perl_croak(aTHX_ "%s", errstr);
4798 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4800 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4801 if ( !qv && width < 3 )
4802 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4804 while (isDIGIT(*pos))
4806 if (!isALPHA(*pos)) {
4812 /* this is atoi() that delimits on underscores */
4813 const char *end = pos;
4817 /* the following if() will only be true after the decimal
4818 * point of a version originally created with a bare
4819 * floating point number, i.e. not quoted in any way
4821 if ( !qv && s > start && saw_decimal == 1 ) {
4825 rev += (*s - '0') * mult;
4827 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4828 || (PERL_ABS(rev) > VERSION_MAX )) {
4829 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4830 "Integer overflow in version %d",VERSION_MAX);
4841 while (--end >= s) {
4843 rev += (*end - '0') * mult;
4845 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4846 || (PERL_ABS(rev) > VERSION_MAX )) {
4847 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4848 "Integer overflow in version");
4857 /* Append revision */
4858 av_push(av, newSViv(rev));
4863 else if ( *pos == '.' )
4865 else if ( *pos == '_' && isDIGIT(pos[1]) )
4867 else if ( *pos == ',' && isDIGIT(pos[1]) )
4869 else if ( isDIGIT(*pos) )
4876 while ( isDIGIT(*pos) )
4881 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4889 if ( qv ) { /* quoted versions always get at least three terms*/
4890 I32 len = av_len(av);
4891 /* This for loop appears to trigger a compiler bug on OS X, as it
4892 loops infinitely. Yes, len is negative. No, it makes no sense.
4893 Compiler in question is:
4894 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4895 for ( len = 2 - len; len > 0; len-- )
4896 av_push(MUTABLE_AV(sv), newSViv(0));
4900 av_push(av, newSViv(0));
4903 /* need to save off the current version string for later */
4905 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4906 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4907 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4909 else if ( s > start ) {
4910 SV * orig = newSVpvn(start,s-start);
4911 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4912 /* need to insert a v to be consistent */
4913 sv_insert(orig, 0, 0, "v", 1);
4915 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4918 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4919 av_push(av, newSViv(0));
4922 /* And finally, store the AV in the hash */
4923 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4925 /* fix RT#19517 - special case 'undef' as string */
4926 if ( *s == 'u' && strEQ(s,"undef") ) {
4934 =for apidoc new_version
4936 Returns a new version object based on the passed in SV:
4938 SV *sv = new_version(SV *ver);
4940 Does not alter the passed in ver SV. See "upg_version" if you
4941 want to upgrade the SV.
4947 Perl_new_version(pTHX_ SV *ver)
4950 SV * const rv = newSV(0);
4951 PERL_ARGS_ASSERT_NEW_VERSION;
4952 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4955 AV * const av = newAV();
4957 /* This will get reblessed later if a derived class*/
4958 SV * const hv = newSVrv(rv, "version");
4959 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4960 #ifndef NODEFAULT_SHAREKEYS
4961 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4967 /* Begin copying all of the elements */
4968 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4969 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4971 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4972 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4974 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4976 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4977 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4980 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4982 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4983 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4986 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4987 /* This will get reblessed later if a derived class*/
4988 for ( key = 0; key <= av_len(sav); key++ )
4990 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4991 av_push(av, newSViv(rev));
4994 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4999 const MAGIC* const mg = SvVSTRING_mg(ver);
5000 if ( mg ) { /* already a v-string */
5001 const STRLEN len = mg->mg_len;
5002 char * const version = savepvn( (const char*)mg->mg_ptr, len);
5003 sv_setpvn(rv,version,len);
5004 /* this is for consistency with the pure Perl class */
5005 if ( isDIGIT(*version) )
5006 sv_insert(rv, 0, 0, "v", 1);
5011 sv_setsv(rv,ver); /* make a duplicate */
5016 return upg_version(rv, FALSE);
5020 =for apidoc upg_version
5022 In-place upgrade of the supplied SV to a version object.
5024 SV *sv = upg_version(SV *sv, bool qv);
5026 Returns a pointer to the upgraded SV. Set the boolean qv if you want
5027 to force this SV to be interpreted as an "extended" version.
5033 Perl_upg_version(pTHX_ SV *ver, bool qv)
5035 const char *version, *s;
5040 PERL_ARGS_ASSERT_UPG_VERSION;
5042 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
5044 /* may get too much accuracy */
5046 #ifdef USE_LOCALE_NUMERIC
5047 char *loc = setlocale(LC_NUMERIC, "C");
5049 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
5050 #ifdef USE_LOCALE_NUMERIC
5051 setlocale(LC_NUMERIC, loc);
5053 while (tbuf[len-1] == '0' && len > 0) len--;
5054 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
5055 version = savepvn(tbuf, len);
5058 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
5059 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
5063 else /* must be a string or something like a string */
5066 version = savepv(SvPV(ver,len));
5068 # if PERL_VERSION > 5
5069 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
5070 if ( len >= 3 && !instr(version,".") && !instr(version,"_")
5071 && !(*version == 'u' && strEQ(version, "undef"))
5072 && (*version < '0' || *version > '9') ) {
5073 /* may be a v-string */
5074 SV * const nsv = sv_newmortal();
5077 int saw_decimal = 0;
5078 sv_setpvf(nsv,"v%vd",ver);
5079 pos = nver = savepv(SvPV_nolen(nsv));
5081 /* scan the resulting formatted string */
5082 pos++; /* skip the leading 'v' */
5083 while ( *pos == '.' || isDIGIT(*pos) ) {
5089 /* is definitely a v-string */
5090 if ( saw_decimal >= 2 ) {
5099 s = scan_version(version, ver, qv);
5101 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5102 "Version string '%s' contains invalid data; "
5103 "ignoring: '%s'", version, s);
5111 Validates that the SV contains valid internal structure for a version object.
5112 It may be passed either the version object (RV) or the hash itself (HV). If
5113 the structure is valid, it returns the HV. If the structure is invalid,
5116 SV *hv = vverify(sv);
5118 Note that it only confirms the bare minimum structure (so as not to get
5119 confused by derived classes which may contain additional hash entries):
5123 =item * The SV is an HV or a reference to an HV
5125 =item * The hash contains a "version" key
5127 =item * The "version" key has a reference to an AV as its value
5135 Perl_vverify(pTHX_ SV *vs)
5139 PERL_ARGS_ASSERT_VVERIFY;
5144 /* see if the appropriate elements exist */
5145 if ( SvTYPE(vs) == SVt_PVHV
5146 && hv_exists(MUTABLE_HV(vs), "version", 7)
5147 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
5148 && SvTYPE(sv) == SVt_PVAV )
5157 Accepts a version object and returns the normalized floating
5158 point representation. Call like:
5162 NOTE: you can pass either the object directly or the SV
5163 contained within the RV.
5169 Perl_vnumify(pTHX_ SV *vs)
5177 PERL_ARGS_ASSERT_VNUMIFY;
5179 /* extract the HV from the object */
5182 Perl_croak(aTHX_ "Invalid version object");
5184 /* see if various flags exist */
5185 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5187 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5188 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5193 /* attempt to retrieve the version array */
5194 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5195 return newSVpvs("0");
5201 return newSVpvs("0");
5204 digit = SvIV(*av_fetch(av, 0, 0));
5205 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5206 for ( i = 1 ; i < len ; i++ )
5208 digit = SvIV(*av_fetch(av, i, 0));
5210 const int denom = (width == 2 ? 10 : 100);
5211 const div_t term = div((int)PERL_ABS(digit),denom);
5212 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5215 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5221 digit = SvIV(*av_fetch(av, len, 0));
5222 if ( alpha && width == 3 ) /* alpha version */
5224 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5228 sv_catpvs(sv, "000");
5236 Accepts a version object and returns the normalized string
5237 representation. Call like:
5241 NOTE: you can pass either the object directly or the SV
5242 contained within the RV.
5248 Perl_vnormal(pTHX_ SV *vs)
5255 PERL_ARGS_ASSERT_VNORMAL;
5257 /* extract the HV from the object */
5260 Perl_croak(aTHX_ "Invalid version object");
5262 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5264 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5269 return newSVpvs("");
5271 digit = SvIV(*av_fetch(av, 0, 0));
5272 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5273 for ( i = 1 ; i < len ; i++ ) {
5274 digit = SvIV(*av_fetch(av, i, 0));
5275 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5280 /* handle last digit specially */
5281 digit = SvIV(*av_fetch(av, len, 0));
5283 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5285 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5288 if ( len <= 2 ) { /* short version, must be at least three */
5289 for ( len = 2 - len; len != 0; len-- )
5296 =for apidoc vstringify
5298 In order to maintain maximum compatibility with earlier versions
5299 of Perl, this function will return either the floating point
5300 notation or the multiple dotted notation, depending on whether
5301 the original version contained 1 or more dots, respectively
5307 Perl_vstringify(pTHX_ SV *vs)
5309 PERL_ARGS_ASSERT_VSTRINGIFY;
5311 /* extract the HV from the object */
5314 Perl_croak(aTHX_ "Invalid version object");
5316 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
5318 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5322 return &PL_sv_undef;
5325 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5335 Version object aware cmp. Both operands must already have been
5336 converted into version objects.
5342 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5345 bool lalpha = FALSE;
5346 bool ralpha = FALSE;
5351 PERL_ARGS_ASSERT_VCMP;
5353 /* extract the HVs from the objects */
5356 if ( ! ( lhv && rhv ) )
5357 Perl_croak(aTHX_ "Invalid version object");
5359 /* get the left hand term */
5360 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5361 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5364 /* and the right hand term */
5365 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5366 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5374 while ( i <= m && retval == 0 )
5376 left = SvIV(*av_fetch(lav,i,0));
5377 right = SvIV(*av_fetch(rav,i,0));
5385 /* tiebreaker for alpha with identical terms */
5386 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5388 if ( lalpha && !ralpha )
5392 else if ( ralpha && !lalpha)
5398 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5402 while ( i <= r && retval == 0 )
5404 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5405 retval = -1; /* not a match after all */
5411 while ( i <= l && retval == 0 )
5413 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5414 retval = +1; /* not a match after all */
5422 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5423 # define EMULATE_SOCKETPAIR_UDP
5426 #ifdef EMULATE_SOCKETPAIR_UDP
5428 S_socketpair_udp (int fd[2]) {
5430 /* Fake a datagram socketpair using UDP to localhost. */
5431 int sockets[2] = {-1, -1};
5432 struct sockaddr_in addresses[2];
5434 Sock_size_t size = sizeof(struct sockaddr_in);
5435 unsigned short port;
5438 memset(&addresses, 0, sizeof(addresses));
5441 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5442 if (sockets[i] == -1)
5443 goto tidy_up_and_fail;
5445 addresses[i].sin_family = AF_INET;
5446 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5447 addresses[i].sin_port = 0; /* kernel choses port. */
5448 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5449 sizeof(struct sockaddr_in)) == -1)
5450 goto tidy_up_and_fail;
5453 /* Now have 2 UDP sockets. Find out which port each is connected to, and
5454 for each connect the other socket to it. */
5457 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5459 goto tidy_up_and_fail;
5460 if (size != sizeof(struct sockaddr_in))
5461 goto abort_tidy_up_and_fail;
5462 /* !1 is 0, !0 is 1 */
5463 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5464 sizeof(struct sockaddr_in)) == -1)
5465 goto tidy_up_and_fail;
5468 /* Now we have 2 sockets connected to each other. I don't trust some other
5469 process not to have already sent a packet to us (by random) so send
5470 a packet from each to the other. */
5473 /* I'm going to send my own port number. As a short.
5474 (Who knows if someone somewhere has sin_port as a bitfield and needs
5475 this routine. (I'm assuming crays have socketpair)) */
5476 port = addresses[i].sin_port;
5477 got = PerlLIO_write(sockets[i], &port, sizeof(port));
5478 if (got != sizeof(port)) {
5480 goto tidy_up_and_fail;
5481 goto abort_tidy_up_and_fail;
5485 /* Packets sent. I don't trust them to have arrived though.
5486 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5487 connect to localhost will use a second kernel thread. In 2.6 the
5488 first thread running the connect() returns before the second completes,
5489 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5490 returns 0. Poor programs have tripped up. One poor program's authors'
5491 had a 50-1 reverse stock split. Not sure how connected these were.)
5492 So I don't trust someone not to have an unpredictable UDP stack.
5496 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5497 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5501 FD_SET((unsigned int)sockets[0], &rset);
5502 FD_SET((unsigned int)sockets[1], &rset);
5504 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5505 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5506 || !FD_ISSET(sockets[1], &rset)) {
5507 /* I hope this is portable and appropriate. */
5509 goto tidy_up_and_fail;
5510 goto abort_tidy_up_and_fail;
5514 /* And the paranoia department even now doesn't trust it to have arrive
5515 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5517 struct sockaddr_in readfrom;
5518 unsigned short buffer[2];
5523 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5524 sizeof(buffer), MSG_DONTWAIT,
5525 (struct sockaddr *) &readfrom, &size);
5527 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5529 (struct sockaddr *) &readfrom, &size);
5533 goto tidy_up_and_fail;
5534 if (got != sizeof(port)
5535 || size != sizeof(struct sockaddr_in)
5536 /* Check other socket sent us its port. */
5537 || buffer[0] != (unsigned short) addresses[!i].sin_port
5538 /* Check kernel says we got the datagram from that socket */
5539 || readfrom.sin_family != addresses[!i].sin_family
5540 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5541 || readfrom.sin_port != addresses[!i].sin_port)
5542 goto abort_tidy_up_and_fail;
5545 /* My caller (my_socketpair) has validated that this is non-NULL */
5548 /* I hereby declare this connection open. May God bless all who cross
5552 abort_tidy_up_and_fail:
5553 errno = ECONNABORTED;
5557 if (sockets[0] != -1)
5558 PerlLIO_close(sockets[0]);
5559 if (sockets[1] != -1)
5560 PerlLIO_close(sockets[1]);
5565 #endif /* EMULATE_SOCKETPAIR_UDP */
5567 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5569 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5570 /* Stevens says that family must be AF_LOCAL, protocol 0.
5571 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5576 struct sockaddr_in listen_addr;
5577 struct sockaddr_in connect_addr;
5582 || family != AF_UNIX
5585 errno = EAFNOSUPPORT;
5593 #ifdef EMULATE_SOCKETPAIR_UDP
5594 if (type == SOCK_DGRAM)
5595 return S_socketpair_udp(fd);
5598 listener = PerlSock_socket(AF_INET, type, 0);
5601 memset(&listen_addr, 0, sizeof(listen_addr));
5602 listen_addr.sin_family = AF_INET;
5603 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5604 listen_addr.sin_port = 0; /* kernel choses port. */
5605 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5606 sizeof(listen_addr)) == -1)
5607 goto tidy_up_and_fail;
5608 if (PerlSock_listen(listener, 1) == -1)
5609 goto tidy_up_and_fail;
5611 connector = PerlSock_socket(AF_INET, type, 0);
5612 if (connector == -1)
5613 goto tidy_up_and_fail;
5614 /* We want to find out the port number to connect to. */
5615 size = sizeof(connect_addr);
5616 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5618 goto tidy_up_and_fail;
5619 if (size != sizeof(connect_addr))
5620 goto abort_tidy_up_and_fail;
5621 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5622 sizeof(connect_addr)) == -1)
5623 goto tidy_up_and_fail;
5625 size = sizeof(listen_addr);
5626 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5629 goto tidy_up_and_fail;
5630 if (size != sizeof(listen_addr))
5631 goto abort_tidy_up_and_fail;
5632 PerlLIO_close(listener);
5633 /* Now check we are talking to ourself by matching port and host on the
5635 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5637 goto tidy_up_and_fail;
5638 if (size != sizeof(connect_addr)
5639 || listen_addr.sin_family != connect_addr.sin_family
5640 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5641 || listen_addr.sin_port != connect_addr.sin_port) {
5642 goto abort_tidy_up_and_fail;
5648 abort_tidy_up_and_fail:
5650 errno = ECONNABORTED; /* This would be the standard thing to do. */
5652 # ifdef ECONNREFUSED
5653 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5655 errno = ETIMEDOUT; /* Desperation time. */
5662 PerlLIO_close(listener);
5663 if (connector != -1)
5664 PerlLIO_close(connector);
5666 PerlLIO_close(acceptor);
5672 /* In any case have a stub so that there's code corresponding
5673 * to the my_socketpair in global.sym. */
5675 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5676 #ifdef HAS_SOCKETPAIR
5677 return socketpair(family, type, protocol, fd);
5686 =for apidoc sv_nosharing
5688 Dummy routine which "shares" an SV when there is no sharing module present.
5689 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5690 Exists to avoid test for a NULL function pointer and because it could
5691 potentially warn under some level of strict-ness.
5697 Perl_sv_nosharing(pTHX_ SV *sv)
5699 PERL_UNUSED_CONTEXT;
5700 PERL_UNUSED_ARG(sv);
5705 =for apidoc sv_destroyable
5707 Dummy routine which reports that object can be destroyed when there is no
5708 sharing module present. It ignores its single SV argument, and returns
5709 'true'. Exists to avoid test for a NULL function pointer and because it
5710 could potentially warn under some level of strict-ness.
5716 Perl_sv_destroyable(pTHX_ SV *sv)
5718 PERL_UNUSED_CONTEXT;
5719 PERL_UNUSED_ARG(sv);
5724 Perl_parse_unicode_opts(pTHX_ const char **popt)
5726 const char *p = *popt;
5729 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5733 opt = (U32) atoi(p);
5736 if (*p && *p != '\n' && *p != '\r') {
5737 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5739 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5745 case PERL_UNICODE_STDIN:
5746 opt |= PERL_UNICODE_STDIN_FLAG; break;
5747 case PERL_UNICODE_STDOUT:
5748 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5749 case PERL_UNICODE_STDERR:
5750 opt |= PERL_UNICODE_STDERR_FLAG; break;
5751 case PERL_UNICODE_STD:
5752 opt |= PERL_UNICODE_STD_FLAG; break;
5753 case PERL_UNICODE_IN:
5754 opt |= PERL_UNICODE_IN_FLAG; break;
5755 case PERL_UNICODE_OUT:
5756 opt |= PERL_UNICODE_OUT_FLAG; break;
5757 case PERL_UNICODE_INOUT:
5758 opt |= PERL_UNICODE_INOUT_FLAG; break;
5759 case PERL_UNICODE_LOCALE:
5760 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5761 case PERL_UNICODE_ARGV:
5762 opt |= PERL_UNICODE_ARGV_FLAG; break;
5763 case PERL_UNICODE_UTF8CACHEASSERT:
5764 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5766 if (*p != '\n' && *p != '\r') {
5767 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5770 "Unknown Unicode option letter '%c'", *p);
5777 opt = PERL_UNICODE_DEFAULT_FLAGS;
5779 the_end_of_the_opts_parser:
5781 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5782 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5783 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5795 * This is really just a quick hack which grabs various garbage
5796 * values. It really should be a real hash algorithm which
5797 * spreads the effect of every input bit onto every output bit,
5798 * if someone who knows about such things would bother to write it.
5799 * Might be a good idea to add that function to CORE as well.
5800 * No numbers below come from careful analysis or anything here,
5801 * except they are primes and SEED_C1 > 1E6 to get a full-width
5802 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5803 * probably be bigger too.
5806 # define SEED_C1 1000003
5807 #define SEED_C4 73819
5809 # define SEED_C1 25747
5810 #define SEED_C4 20639
5814 #define SEED_C5 26107
5816 #ifndef PERL_NO_DEV_RANDOM
5821 # include <starlet.h>
5822 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5823 * in 100-ns units, typically incremented ever 10 ms. */
5824 unsigned int when[2];
5826 # ifdef HAS_GETTIMEOFDAY
5827 struct timeval when;
5833 /* This test is an escape hatch, this symbol isn't set by Configure. */
5834 #ifndef PERL_NO_DEV_RANDOM
5835 #ifndef PERL_RANDOM_DEVICE
5836 /* /dev/random isn't used by default because reads from it will block
5837 * if there isn't enough entropy available. You can compile with
5838 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5839 * is enough real entropy to fill the seed. */
5840 # define PERL_RANDOM_DEVICE "/dev/urandom"
5842 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5844 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5853 _ckvmssts(sys$gettim(when));
5854 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5856 # ifdef HAS_GETTIMEOFDAY
5857 PerlProc_gettimeofday(&when,NULL);
5858 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5861 u = (U32)SEED_C1 * when;
5864 u += SEED_C3 * (U32)PerlProc_getpid();
5865 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5866 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5867 u += SEED_C5 * (U32)PTR2UV(&when);
5873 Perl_get_hash_seed(pTHX)
5876 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5882 if (s && isDIGIT(*s))
5883 myseed = (UV)Atoul(s);
5885 #ifdef USE_HASH_SEED_EXPLICIT
5889 /* Compute a random seed */
5890 (void)seedDrand01((Rand_seed_t)seed());
5891 myseed = (UV)(Drand01() * (NV)UV_MAX);
5892 #if RANDBITS < (UVSIZE * 8)
5893 /* Since there are not enough randbits to to reach all
5894 * the bits of a UV, the low bits might need extra
5895 * help. Sum in another random number that will
5896 * fill in the low bits. */
5898 (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5899 #endif /* RANDBITS < (UVSIZE * 8) */
5900 if (myseed == 0) { /* Superparanoia. */
5901 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5903 Perl_croak(aTHX_ "Your random numbers are not that random");
5906 PL_rehash_seed_set = TRUE;
5913 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5915 const char * const stashpv = CopSTASHPV(c);
5916 const char * const name = HvNAME_get(hv);
5917 PERL_UNUSED_CONTEXT;
5918 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5920 if (stashpv == name)
5922 if (stashpv && name)
5923 if (strEQ(stashpv, name))
5930 #ifdef PERL_GLOBAL_STRUCT
5932 #define PERL_GLOBAL_STRUCT_INIT
5933 #include "opcode.h" /* the ppaddr and check */
5936 Perl_init_global_struct(pTHX)
5938 struct perl_vars *plvarsp = NULL;
5939 # ifdef PERL_GLOBAL_STRUCT
5940 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5941 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5942 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5943 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5944 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5948 plvarsp = PL_VarsPtr;
5949 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5955 # define PERLVAR(var,type) /**/
5956 # define PERLVARA(var,n,type) /**/
5957 # define PERLVARI(var,type,init) plvarsp->var = init;
5958 # define PERLVARIC(var,type,init) plvarsp->var = init;
5959 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5960 # include "perlvars.h"
5966 # ifdef PERL_GLOBAL_STRUCT
5969 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5970 if (!plvarsp->Gppaddr)
5974 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5975 if (!plvarsp->Gcheck)
5977 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5978 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5980 # ifdef PERL_SET_VARS
5981 PERL_SET_VARS(plvarsp);
5983 # undef PERL_GLOBAL_STRUCT_INIT
5988 #endif /* PERL_GLOBAL_STRUCT */
5990 #ifdef PERL_GLOBAL_STRUCT
5993 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5995 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5996 # ifdef PERL_GLOBAL_STRUCT
5997 # ifdef PERL_UNSET_VARS
5998 PERL_UNSET_VARS(plvarsp);
6000 free(plvarsp->Gppaddr);
6001 free(plvarsp->Gcheck);
6002 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
6008 #endif /* PERL_GLOBAL_STRUCT */
6012 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
6013 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
6014 * given, and you supply your own implementation.
6016 * The default implementation reads a single env var, PERL_MEM_LOG,
6017 * expecting one or more of the following:
6019 * \d+ - fd fd to write to : must be 1st (atoi)
6020 * 'm' - memlog was PERL_MEM_LOG=1
6021 * 's' - svlog was PERL_SV_LOG=1
6022 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
6024 * This makes the logger controllable enough that it can reasonably be
6025 * added to the system perl.
6028 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
6029 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
6031 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
6033 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
6034 * writes to. In the default logger, this is settable at runtime.
6036 #ifndef PERL_MEM_LOG_FD
6037 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
6040 #ifndef PERL_MEM_LOG_NOIMPL
6042 # ifdef DEBUG_LEAKING_SCALARS
6043 # define SV_LOG_SERIAL_FMT " [%lu]"
6044 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
6046 # define SV_LOG_SERIAL_FMT
6047 # define _SV_LOG_SERIAL_ARG(sv)
6051 S_mem_log_common(enum mem_log_type mlt, const UV n,
6052 const UV typesize, const char *type_name, const SV *sv,
6053 Malloc_t oldalloc, Malloc_t newalloc,
6054 const char *filename, const int linenumber,
6055 const char *funcname)
6059 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
6061 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
6064 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
6066 /* We can't use SVs or PerlIO for obvious reasons,
6067 * so we'll use stdio and low-level IO instead. */
6068 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
6070 # ifdef HAS_GETTIMEOFDAY
6071 # define MEM_LOG_TIME_FMT "%10d.%06d: "
6072 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
6074 gettimeofday(&tv, 0);
6076 # define MEM_LOG_TIME_FMT "%10d: "
6077 # define MEM_LOG_TIME_ARG (int)when
6081 /* If there are other OS specific ways of hires time than
6082 * gettimeofday() (see ext/Time-HiRes), the easiest way is
6083 * probably that they would be used to fill in the struct
6087 int fd = atoi(pmlenv);
6089 fd = PERL_MEM_LOG_FD;
6091 if (strchr(pmlenv, 't')) {
6092 len = my_snprintf(buf, sizeof(buf),
6093 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
6094 PerlLIO_write(fd, buf, len);
6098 len = my_snprintf(buf, sizeof(buf),
6099 "alloc: %s:%d:%s: %"IVdf" %"UVuf
6100 " %s = %"IVdf": %"UVxf"\n",
6101 filename, linenumber, funcname, n, typesize,
6102 type_name, n * typesize, PTR2UV(newalloc));
6105 len = my_snprintf(buf, sizeof(buf),
6106 "realloc: %s:%d:%s: %"IVdf" %"UVuf
6107 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
6108 filename, linenumber, funcname, n, typesize,
6109 type_name, n * typesize, PTR2UV(oldalloc),
6113 len = my_snprintf(buf, sizeof(buf),
6114 "free: %s:%d:%s: %"UVxf"\n",
6115 filename, linenumber, funcname,
6120 len = my_snprintf(buf, sizeof(buf),
6121 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
6122 mlt == MLT_NEW_SV ? "new" : "del",
6123 filename, linenumber, funcname,
6124 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
6129 PerlLIO_write(fd, buf, len);
6133 #endif /* !PERL_MEM_LOG_NOIMPL */
6135 #ifndef PERL_MEM_LOG_NOIMPL
6137 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
6138 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
6140 /* this is suboptimal, but bug compatible. User is providing their
6141 own implemenation, but is getting these functions anyway, and they
6142 do nothing. But _NOIMPL users should be able to cope or fix */
6144 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
6145 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
6149 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
6151 const char *filename, const int linenumber,
6152 const char *funcname)
6154 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6155 NULL, NULL, newalloc,
6156 filename, linenumber, funcname);
6161 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6162 Malloc_t oldalloc, Malloc_t newalloc,
6163 const char *filename, const int linenumber,
6164 const char *funcname)
6166 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6167 NULL, oldalloc, newalloc,
6168 filename, linenumber, funcname);
6173 Perl_mem_log_free(Malloc_t oldalloc,
6174 const char *filename, const int linenumber,
6175 const char *funcname)
6177 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6178 filename, linenumber, funcname);
6183 Perl_mem_log_new_sv(const SV *sv,
6184 const char *filename, const int linenumber,
6185 const char *funcname)
6187 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6188 filename, linenumber, funcname);
6192 Perl_mem_log_del_sv(const SV *sv,
6193 const char *filename, const int linenumber,
6194 const char *funcname)
6196 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6197 filename, linenumber, funcname);
6200 #endif /* PERL_MEM_LOG */
6203 =for apidoc my_sprintf
6205 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6206 the length of the string written to the buffer. Only rare pre-ANSI systems
6207 need the wrapper function - usually this is a direct call to C<sprintf>.
6211 #ifndef SPRINTF_RETURNS_STRLEN
6213 Perl_my_sprintf(char *buffer, const char* pat, ...)
6216 PERL_ARGS_ASSERT_MY_SPRINTF;
6217 va_start(args, pat);
6218 vsprintf(buffer, pat, args);
6220 return strlen(buffer);
6225 =for apidoc my_snprintf
6227 The C library C<snprintf> functionality, if available and
6228 standards-compliant (uses C<vsnprintf>, actually). However, if the
6229 C<vsnprintf> is not available, will unfortunately use the unsafe
6230 C<vsprintf> which can overrun the buffer (there is an overrun check,
6231 but that may be too late). Consider using C<sv_vcatpvf> instead, or
6232 getting C<vsnprintf>.
6237 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6242 PERL_ARGS_ASSERT_MY_SNPRINTF;
6243 va_start(ap, format);
6244 #ifdef HAS_VSNPRINTF
6245 retval = vsnprintf(buffer, len, format, ap);
6247 retval = vsprintf(buffer, format, ap);
6250 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6251 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6252 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6257 =for apidoc my_vsnprintf
6259 The C library C<vsnprintf> if available and standards-compliant.
6260 However, if if the C<vsnprintf> is not available, will unfortunately
6261 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6262 overrun check, but that may be too late). Consider using
6263 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6268 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6275 PERL_ARGS_ASSERT_MY_VSNPRINTF;
6277 Perl_va_copy(ap, apc);
6278 # ifdef HAS_VSNPRINTF
6279 retval = vsnprintf(buffer, len, format, apc);
6281 retval = vsprintf(buffer, format, apc);
6284 # ifdef HAS_VSNPRINTF
6285 retval = vsnprintf(buffer, len, format, ap);
6287 retval = vsprintf(buffer, format, ap);
6289 #endif /* #ifdef NEED_VA_COPY */
6290 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6291 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6292 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6297 Perl_my_clearenv(pTHX)
6300 #if ! defined(PERL_MICRO)
6301 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6303 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6304 # if defined(USE_ENVIRON_ARRAY)
6305 # if defined(USE_ITHREADS)
6306 /* only the parent thread can clobber the process environment */
6307 if (PL_curinterp == aTHX)
6308 # endif /* USE_ITHREADS */
6310 # if ! defined(PERL_USE_SAFE_PUTENV)
6311 if ( !PL_use_safe_putenv) {
6313 if (environ == PL_origenviron)
6314 environ = (char**)safesysmalloc(sizeof(char*));
6316 for (i = 0; environ[i]; i++)
6317 (void)safesysfree(environ[i]);
6320 # else /* PERL_USE_SAFE_PUTENV */
6321 # if defined(HAS_CLEARENV)
6323 # elif defined(HAS_UNSETENV)
6324 int bsiz = 80; /* Most envvar names will be shorter than this. */
6325 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6326 char *buf = (char*)safesysmalloc(bufsiz);
6327 while (*environ != NULL) {
6328 char *e = strchr(*environ, '=');
6329 int l = e ? e - *environ : (int)strlen(*environ);
6331 (void)safesysfree(buf);
6332 bsiz = l + 1; /* + 1 for the \0. */
6333 buf = (char*)safesysmalloc(bufsiz);
6335 memcpy(buf, *environ, l);
6337 (void)unsetenv(buf);
6339 (void)safesysfree(buf);
6340 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6341 /* Just null environ and accept the leakage. */
6343 # endif /* HAS_CLEARENV || HAS_UNSETENV */
6344 # endif /* ! PERL_USE_SAFE_PUTENV */
6346 # endif /* USE_ENVIRON_ARRAY */
6347 # endif /* PERL_IMPLICIT_SYS || WIN32 */
6348 #endif /* PERL_MICRO */
6351 #ifdef PERL_IMPLICIT_CONTEXT
6353 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6354 the global PL_my_cxt_index is incremented, and that value is assigned to
6355 that module's static my_cxt_index (who's address is passed as an arg).
6356 Then, for each interpreter this function is called for, it makes sure a
6357 void* slot is available to hang the static data off, by allocating or
6358 extending the interpreter's PL_my_cxt_list array */
6360 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6362 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6366 PERL_ARGS_ASSERT_MY_CXT_INIT;
6368 /* this module hasn't been allocated an index yet */
6369 #if defined(USE_ITHREADS)
6370 MUTEX_LOCK(&PL_my_ctx_mutex);
6372 *index = PL_my_cxt_index++;
6373 #if defined(USE_ITHREADS)
6374 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6378 /* make sure the array is big enough */
6379 if (PL_my_cxt_size <= *index) {
6380 if (PL_my_cxt_size) {
6381 while (PL_my_cxt_size <= *index)
6382 PL_my_cxt_size *= 2;
6383 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6386 PL_my_cxt_size = 16;
6387 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6390 /* newSV() allocates one more than needed */
6391 p = (void*)SvPVX(newSV(size-1));
6392 PL_my_cxt_list[*index] = p;
6393 Zero(p, size, char);
6397 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6400 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6405 PERL_ARGS_ASSERT_MY_CXT_INDEX;
6407 for (index = 0; index < PL_my_cxt_index; index++) {
6408 const char *key = PL_my_cxt_keys[index];
6409 /* try direct pointer compare first - there are chances to success,
6410 * and it's much faster.
6412 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6419 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6425 PERL_ARGS_ASSERT_MY_CXT_INIT;
6427 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6429 /* this module hasn't been allocated an index yet */
6430 #if defined(USE_ITHREADS)
6431 MUTEX_LOCK(&PL_my_ctx_mutex);
6433 index = PL_my_cxt_index++;
6434 #if defined(USE_ITHREADS)
6435 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6439 /* make sure the array is big enough */
6440 if (PL_my_cxt_size <= index) {
6441 int old_size = PL_my_cxt_size;
6443 if (PL_my_cxt_size) {
6444 while (PL_my_cxt_size <= index)
6445 PL_my_cxt_size *= 2;
6446 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6447 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6450 PL_my_cxt_size = 16;
6451 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6452 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6454 for (i = old_size; i < PL_my_cxt_size; i++) {
6455 PL_my_cxt_keys[i] = 0;
6456 PL_my_cxt_list[i] = 0;
6459 PL_my_cxt_keys[index] = my_cxt_key;
6460 /* newSV() allocates one more than needed */
6461 p = (void*)SvPVX(newSV(size-1));
6462 PL_my_cxt_list[index] = p;
6463 Zero(p, size, char);
6466 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6467 #endif /* PERL_IMPLICIT_CONTEXT */
6470 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
6474 const char *vn = NULL;
6475 SV *const module = PL_stack_base[ax];
6477 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
6479 if (items >= 2) /* version supplied as bootstrap arg */
6480 sv = PL_stack_base[ax + 1];
6482 /* XXX GV_ADDWARN */
6484 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6485 if (!sv || !SvOK(sv)) {
6487 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6491 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
6492 SV *pmsv = sv_derived_from(sv, "version")
6493 ? sv : sv_2mortal(new_version(sv));
6494 xssv = upg_version(xssv, 0);
6495 if ( vcmp(pmsv,xssv) ) {
6496 SV *string = vstringify(xssv);
6497 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
6498 " does not match ", module, string);
6500 SvREFCNT_dec(string);
6501 string = vstringify(pmsv);
6504 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
6507 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6509 SvREFCNT_dec(string);
6511 Perl_sv_2mortal(aTHX_ xpt);
6512 Perl_croak_sv(aTHX_ xpt);
6518 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6522 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6525 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6527 /* This might croak */
6528 compver = upg_version(compver, 0);
6529 /* This should never croak */
6530 runver = new_version(PL_apiversion);
6531 if (vcmp(compver, runver)) {
6532 SV *compver_string = vstringify(compver);
6533 SV *runver_string = vstringify(runver);
6534 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6535 " of %"SVf" does not match %"SVf,
6536 compver_string, module, runver_string);
6537 Perl_sv_2mortal(aTHX_ xpt);
6539 SvREFCNT_dec(compver_string);
6540 SvREFCNT_dec(runver_string);
6542 SvREFCNT_dec(runver);
6544 Perl_croak_sv(aTHX_ xpt);
6549 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6551 Size_t used, length, copy;
6554 length = strlen(src);
6555 if (size > 0 && used < size - 1) {
6556 copy = (length >= size - used) ? size - used - 1 : length;
6557 memcpy(dst + used, src, copy);
6558 dst[used + copy] = '\0';
6560 return used + length;
6566 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6568 Size_t length, copy;
6570 length = strlen(src);
6572 copy = (length >= size) ? size - 1 : length;
6573 memcpy(dst, src, copy);
6580 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6581 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6582 long _ftol( double ); /* Defined by VC6 C libs. */
6583 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6587 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6590 SV * const dbsv = GvSVn(PL_DBsub);
6591 const bool save_taint = PL_tainted;
6593 /* We do not care about using sv to call CV;
6594 * it's for informational purposes only.
6597 PERL_ARGS_ASSERT_GET_DB_SUB;
6601 if (!PERLDB_SUB_NN) {
6604 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6605 || strEQ(GvNAME(gv), "END")
6606 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6607 !( (SvTYPE(*svp) == SVt_PVGV)
6608 && (GvCV((const GV *)*svp) == cv)
6609 && (gv = (GV *)*svp)
6613 /* Use GV from the stack as a fallback. */
6614 /* GV is potentially non-unique, or contain different CV. */
6615 SV * const tmp = newRV(MUTABLE_SV(cv));
6616 sv_setsv(dbsv, tmp);
6620 gv_efullname3(dbsv, gv, NULL);
6624 const int type = SvTYPE(dbsv);
6625 if (type < SVt_PVIV && type != SVt_IV)
6626 sv_upgrade(dbsv, SVt_PVIV);
6627 (void)SvIOK_on(dbsv);
6628 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6630 TAINT_IF(save_taint);
6634 Perl_my_dirfd(pTHX_ DIR * dir) {
6636 /* Most dirfd implementations have problems when passed NULL. */
6641 #elif defined(HAS_DIR_DD_FD)
6644 Perl_die(aTHX_ PL_no_func, "dirfd");
6651 Perl_get_re_arg(pTHX_ SV *sv) {
6657 sv = MUTABLE_SV(SvRV(sv));
6658 if (SvTYPE(sv) == SVt_REGEXP)
6659 return (REGEXP*) sv;
6667 * c-indentation-style: bsd
6669 * indent-tabs-mode: t
6672 * ex: set ts=8 sts=4 sw=4 noet: