3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
15 * [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
18 /* This file contains assorted utility routines.
19 * Which is a polite way of saying any stuff that people couldn't think of
20 * a better place for. Amongst other things, it includes the warning and
21 * dieing stuff, plus wrappers for malloc code.
25 #define PERL_IN_UTIL_C
29 #include "perliol.h" /* For PerlIOUnix_refcnt */
35 # define SIG_ERR ((Sighandler_t) -1)
40 /* Missing protos on LynxOS */
45 # include <sys/wait.h>
50 # include <sys/select.h>
56 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
57 # define FD_CLOEXEC 1 /* NeXT needs this */
60 /* NOTE: Do not call the next three routines directly. Use the macros
61 * in handy.h, so that we can easily redefine everything to do tracking of
62 * allocated hunks back to the original New to track down any memory leaks.
63 * XXX This advice seems to be widely ignored :-( --AD August 1996.
70 /* Can't use PerlIO to write as it allocates memory */
71 PerlLIO_write(PerlIO_fileno(Perl_error_log),
72 PL_no_mem, strlen(PL_no_mem));
74 NORETURN_FUNCTION_END;
77 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
78 # define ALWAYS_NEED_THX
81 /* paranoid version of system's malloc() */
84 Perl_safesysmalloc(MEM_SIZE size)
86 #ifdef ALWAYS_NEED_THX
92 PerlIO_printf(Perl_error_log,
93 "Allocation too large: %lx\n", size) FLUSH;
96 #endif /* HAS_64K_LIMIT */
97 #ifdef PERL_TRACK_MEMPOOL
102 Perl_croak_nocontext("panic: malloc");
104 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
105 PERL_ALLOC_CHECK(ptr);
107 #ifdef PERL_TRACK_MEMPOOL
108 struct perl_memory_debug_header *const header
109 = (struct perl_memory_debug_header *)ptr;
113 PoisonNew(((char *)ptr), size, char);
116 #ifdef PERL_TRACK_MEMPOOL
117 header->interpreter = aTHX;
118 /* Link us into the list. */
119 header->prev = &PL_memory_debug_header;
120 header->next = PL_memory_debug_header.next;
121 PL_memory_debug_header.next = header;
122 header->next->prev = header;
126 ptr = (Malloc_t)((char*)ptr+sTHX);
128 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
132 #ifndef ALWAYS_NEED_THX
138 return write_no_mem();
144 /* paranoid version of system's realloc() */
147 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
149 #ifdef ALWAYS_NEED_THX
153 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
154 Malloc_t PerlMem_realloc();
155 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
159 PerlIO_printf(Perl_error_log,
160 "Reallocation too large: %lx\n", size) FLUSH;
163 #endif /* HAS_64K_LIMIT */
170 return safesysmalloc(size);
171 #ifdef PERL_TRACK_MEMPOOL
172 where = (Malloc_t)((char*)where-sTHX);
175 struct perl_memory_debug_header *const header
176 = (struct perl_memory_debug_header *)where;
178 if (header->interpreter != aTHX) {
179 Perl_croak_nocontext("panic: realloc from wrong pool");
181 assert(header->next->prev == header);
182 assert(header->prev->next == header);
184 if (header->size > size) {
185 const MEM_SIZE freed_up = header->size - size;
186 char *start_of_freed = ((char *)where) + size;
187 PoisonFree(start_of_freed, freed_up, char);
195 Perl_croak_nocontext("panic: realloc");
197 ptr = (Malloc_t)PerlMem_realloc(where,size);
198 PERL_ALLOC_CHECK(ptr);
200 /* MUST do this fixup first, before doing ANYTHING else, as anything else
201 might allocate memory/free/move memory, and until we do the fixup, it
202 may well be chasing (and writing to) free memory. */
203 #ifdef PERL_TRACK_MEMPOOL
205 struct perl_memory_debug_header *const header
206 = (struct perl_memory_debug_header *)ptr;
209 if (header->size < size) {
210 const MEM_SIZE fresh = size - header->size;
211 char *start_of_fresh = ((char *)ptr) + size;
212 PoisonNew(start_of_fresh, fresh, char);
216 header->next->prev = header;
217 header->prev->next = header;
219 ptr = (Malloc_t)((char*)ptr+sTHX);
223 /* In particular, must do that fixup above before logging anything via
224 *printf(), as it can reallocate memory, which can cause SEGVs. */
226 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
227 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
234 #ifndef ALWAYS_NEED_THX
240 return write_no_mem();
246 /* safe version of system's free() */
249 Perl_safesysfree(Malloc_t where)
251 #ifdef ALWAYS_NEED_THX
256 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
258 #ifdef PERL_TRACK_MEMPOOL
259 where = (Malloc_t)((char*)where-sTHX);
261 struct perl_memory_debug_header *const header
262 = (struct perl_memory_debug_header *)where;
264 if (header->interpreter != aTHX) {
265 Perl_croak_nocontext("panic: free from wrong pool");
268 Perl_croak_nocontext("panic: duplicate free");
270 if (!(header->next) || header->next->prev != header
271 || header->prev->next != header) {
272 Perl_croak_nocontext("panic: bad free");
274 /* Unlink us from the chain. */
275 header->next->prev = header->prev;
276 header->prev->next = header->next;
278 PoisonNew(where, header->size, char);
280 /* Trigger the duplicate free warning. */
288 /* safe version of system's calloc() */
291 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
293 #ifdef ALWAYS_NEED_THX
297 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
298 MEM_SIZE total_size = 0;
301 /* Even though calloc() for zero bytes is strange, be robust. */
302 if (size && (count <= MEM_SIZE_MAX / size)) {
303 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
304 total_size = size * count;
308 Perl_croak_nocontext("%s", PL_memory_wrap);
309 #ifdef PERL_TRACK_MEMPOOL
310 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
313 Perl_croak_nocontext("%s", PL_memory_wrap);
316 if (total_size > 0xffff) {
317 PerlIO_printf(Perl_error_log,
318 "Allocation too large: %lx\n", total_size) FLUSH;
321 #endif /* HAS_64K_LIMIT */
323 if ((long)size < 0 || (long)count < 0)
324 Perl_croak_nocontext("panic: calloc");
326 #ifdef PERL_TRACK_MEMPOOL
327 /* Have to use malloc() because we've added some space for our tracking
329 /* malloc(0) is non-portable. */
330 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
332 /* Use calloc() because it might save a memset() if the memory is fresh
333 and clean from the OS. */
335 ptr = (Malloc_t)PerlMem_calloc(count, size);
336 else /* calloc(0) is non-portable. */
337 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
339 PERL_ALLOC_CHECK(ptr);
340 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
342 #ifdef PERL_TRACK_MEMPOOL
344 struct perl_memory_debug_header *const header
345 = (struct perl_memory_debug_header *)ptr;
347 memset((void*)ptr, 0, total_size);
348 header->interpreter = aTHX;
349 /* Link us into the list. */
350 header->prev = &PL_memory_debug_header;
351 header->next = PL_memory_debug_header.next;
352 PL_memory_debug_header.next = header;
353 header->next->prev = header;
355 header->size = total_size;
357 ptr = (Malloc_t)((char*)ptr+sTHX);
363 #ifndef ALWAYS_NEED_THX
368 return write_no_mem();
372 /* These must be defined when not using Perl's malloc for binary
377 Malloc_t Perl_malloc (MEM_SIZE nbytes)
380 return (Malloc_t)PerlMem_malloc(nbytes);
383 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
386 return (Malloc_t)PerlMem_calloc(elements, size);
389 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
392 return (Malloc_t)PerlMem_realloc(where, nbytes);
395 Free_t Perl_mfree (Malloc_t where)
403 /* copy a string up to some (non-backslashed) delimiter, if any */
406 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
410 PERL_ARGS_ASSERT_DELIMCPY;
412 for (tolen = 0; from < fromend; from++, tolen++) {
414 if (from[1] != delim) {
421 else if (*from == delim)
432 /* return ptr to little string in big string, NULL if not found */
433 /* This routine was donated by Corey Satten. */
436 Perl_instr(register const char *big, register const char *little)
440 PERL_ARGS_ASSERT_INSTR;
448 register const char *s, *x;
451 for (x=big,s=little; *s; /**/ ) {
462 return (char*)(big-1);
467 /* same as instr but allow embedded nulls */
470 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
472 PERL_ARGS_ASSERT_NINSTR;
476 const char first = *little;
478 bigend -= lend - little++;
480 while (big <= bigend) {
481 if (*big++ == first) {
482 for (x=big,s=little; s < lend; x++,s++) {
486 return (char*)(big-1);
493 /* reverse of the above--find last substring */
496 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
498 register const char *bigbeg;
499 register const I32 first = *little;
500 register const char * const littleend = lend;
502 PERL_ARGS_ASSERT_RNINSTR;
504 if (little >= littleend)
505 return (char*)bigend;
507 big = bigend - (littleend - little++);
508 while (big >= bigbeg) {
509 register const char *s, *x;
512 for (x=big+2,s=little; s < littleend; /**/ ) {
521 return (char*)(big+1);
526 /* As a space optimization, we do not compile tables for strings of length
527 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
528 special-cased in fbm_instr().
530 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
533 =head1 Miscellaneous Functions
535 =for apidoc fbm_compile
537 Analyses the string in order to make fast searches on it using fbm_instr()
538 -- the Boyer-Moore algorithm.
544 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
547 register const U8 *s;
554 PERL_ARGS_ASSERT_FBM_COMPILE;
556 /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in
557 SV flag usage. No real-world code would ever end up using a studied
558 scalar as a compile-time second argument to index, so this isn't a real
566 if (flags & FBMcf_TAIL) {
567 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
568 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
569 if (mg && mg->mg_len >= 0)
572 s = (U8*)SvPV_force_mutable(sv, len);
573 if (len == 0) /* TAIL might be on a zero-length string. */
575 SvUPGRADE(sv, SVt_PVMG);
580 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
581 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
582 to call SvVALID_off() if the scalar was assigned to.
584 The comment itself (and "deeper magic" below) date back to
585 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
587 where the magic (presumably) was that the scalar had a BM table hidden
590 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
591 the table instead of the previous (somewhat hacky) approach of co-opting
592 the string buffer and storing it after the string. */
594 assert(!mg_find(sv, PERL_MAGIC_bm));
595 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
599 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
601 const U8 mlen = (len>255) ? 255 : (U8)len;
602 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
605 Newx(table, 256, U8);
606 memset((void*)table, mlen, 256);
607 mg->mg_ptr = (char *)table;
610 s += len - 1; /* last char */
613 if (table[*s] == mlen)
619 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
620 for (i = 0; i < len; i++) {
621 if (PL_freq[s[i]] < frequency) {
623 frequency = PL_freq[s[i]];
626 BmRARE(sv) = s[rarest];
627 BmPREVIOUS(sv) = rarest;
628 BmUSEFUL(sv) = 100; /* Initial value */
629 if (flags & FBMcf_TAIL)
631 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
632 BmRARE(sv), BmPREVIOUS(sv)));
635 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
636 /* If SvTAIL is actually due to \Z or \z, this gives false positives
640 =for apidoc fbm_instr
642 Returns the location of the SV in the string delimited by C<str> and
643 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
644 does not have to be fbm_compiled, but the search will not be as fast
651 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
653 register unsigned char *s;
655 register const unsigned char *little
656 = (const unsigned char *)SvPV_const(littlestr,l);
657 register STRLEN littlelen = l;
658 register const I32 multiline = flags & FBMrf_MULTILINE;
660 PERL_ARGS_ASSERT_FBM_INSTR;
662 if ((STRLEN)(bigend - big) < littlelen) {
663 if ( SvTAIL(littlestr)
664 && ((STRLEN)(bigend - big) == littlelen - 1)
666 || (*big == *little &&
667 memEQ((char *)big, (char *)little, littlelen - 1))))
672 switch (littlelen) { /* Special cases for 0, 1 and 2 */
674 return (char*)big; /* Cannot be SvTAIL! */
676 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
677 /* Know that bigend != big. */
678 if (bigend[-1] == '\n')
679 return (char *)(bigend - 1);
680 return (char *) bigend;
688 if (SvTAIL(littlestr))
689 return (char *) bigend;
692 if (SvTAIL(littlestr) && !multiline) {
693 if (bigend[-1] == '\n' && bigend[-2] == *little)
694 return (char*)bigend - 2;
695 if (bigend[-1] == *little)
696 return (char*)bigend - 1;
700 /* This should be better than FBM if c1 == c2, and almost
701 as good otherwise: maybe better since we do less indirection.
702 And we save a lot of memory by caching no table. */
703 const unsigned char c1 = little[0];
704 const unsigned char c2 = little[1];
709 while (s <= bigend) {
719 goto check_1char_anchor;
730 goto check_1char_anchor;
733 while (s <= bigend) {
738 goto check_1char_anchor;
747 check_1char_anchor: /* One char and anchor! */
748 if (SvTAIL(littlestr) && (*bigend == *little))
749 return (char *)bigend; /* bigend is already decremented. */
752 break; /* Only lengths 0 1 and 2 have special-case code. */
755 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
756 s = bigend - littlelen;
757 if (s >= big && bigend[-1] == '\n' && *s == *little
758 /* Automatically of length > 2 */
759 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
761 return (char*)s; /* how sweet it is */
764 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
766 return (char*)s + 1; /* how sweet it is */
770 if (!SvVALID(littlestr)) {
771 char * const b = ninstr((char*)big,(char*)bigend,
772 (char*)little, (char*)little + littlelen);
774 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
775 /* Chop \n from littlestr: */
776 s = bigend - littlelen + 1;
778 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
788 if (littlelen > (STRLEN)(bigend - big))
792 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
793 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
794 register const unsigned char *oldlittle;
796 --littlelen; /* Last char found by table lookup */
799 little += littlelen; /* last char */
805 if ((tmp = table[*s])) {
806 if ((s += tmp) < bigend)
810 else { /* less expensive than calling strncmp() */
811 register unsigned char * const olds = s;
816 if (*--s == *--little)
818 s = olds + 1; /* here we pay the price for failure */
820 if (s < bigend) /* fake up continue to outer loop */
830 && memEQ((char *)(bigend - littlelen),
831 (char *)(oldlittle - littlelen), littlelen) )
832 return (char*)bigend - littlelen;
837 /* start_shift, end_shift are positive quantities which give offsets
838 of ends of some substring of bigstr.
839 If "last" we want the last occurrence.
840 old_posp is the way of communication between consequent calls if
841 the next call needs to find the .
842 The initial *old_posp should be -1.
844 Note that we take into account SvTAIL, so one can get extra
845 optimizations if _ALL flag is set.
848 /* If SvTAIL is actually due to \Z or \z, this gives false positives
849 if PL_multiline. In fact if !PL_multiline the authoritative answer
850 is not supported yet. */
853 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
856 register const unsigned char *big;
858 register I32 previous;
860 register const unsigned char *little;
861 register I32 stop_pos;
862 register const unsigned char *littleend;
865 PERL_ARGS_ASSERT_SCREAMINSTR;
867 assert(SvTYPE(littlestr) == SVt_PVMG);
868 assert(SvVALID(littlestr));
871 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
872 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
874 if ( BmRARE(littlestr) == '\n'
875 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
876 little = (const unsigned char *)(SvPVX_const(littlestr));
877 littleend = little + SvCUR(littlestr);
884 little = (const unsigned char *)(SvPVX_const(littlestr));
885 littleend = little + SvCUR(littlestr);
887 /* The value of pos we can start at: */
888 previous = BmPREVIOUS(littlestr);
889 big = (const unsigned char *)(SvPVX_const(bigstr));
890 /* The value of pos we can stop at: */
891 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
892 if (previous + start_shift > stop_pos) {
894 stop_pos does not include SvTAIL in the count, so this check is incorrect
895 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
898 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
903 while (pos < previous + start_shift) {
904 if (!(pos += PL_screamnext[pos]))
909 register const unsigned char *s, *x;
910 if (pos >= stop_pos) break;
911 if (big[pos] != first)
913 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
919 if (s == littleend) {
921 if (!last) return (char *)(big+pos);
924 } while ( pos += PL_screamnext[pos] );
926 return (char *)(big+(*old_posp));
928 if (!SvTAIL(littlestr) || (end_shift > 0))
930 /* Ignore the trailing "\n". This code is not microoptimized */
931 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
932 stop_pos = littleend - little; /* Actual littlestr len */
937 && ((stop_pos == 1) ||
938 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
946 Returns true if the leading len bytes of the strings s1 and s2 are the same
947 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
948 match themselves and their opposite case counterparts. Non-cased and non-ASCII
949 range bytes match only themselves.
956 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
958 register const U8 *a = (const U8 *)s1;
959 register const U8 *b = (const U8 *)s2;
961 PERL_ARGS_ASSERT_FOLDEQ;
964 if (*a != *b && *a != PL_fold[*b])
971 Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
973 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
974 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
975 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
976 * does it check that the strings each have at least 'len' characters */
978 register const U8 *a = (const U8 *)s1;
979 register const U8 *b = (const U8 *)s2;
981 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
984 if (*a != *b && *a != PL_fold_latin1[*b]) {
993 =for apidoc foldEQ_locale
995 Returns true if the leading len bytes of the strings s1 and s2 are the same
996 case-insensitively in the current locale; false otherwise.
1002 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
1005 register const U8 *a = (const U8 *)s1;
1006 register const U8 *b = (const U8 *)s2;
1008 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1011 if (*a != *b && *a != PL_fold_locale[*b])
1018 /* copy a string to a safe spot */
1021 =head1 Memory Management
1025 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1026 string which is a duplicate of C<pv>. The size of the string is
1027 determined by C<strlen()>. The memory allocated for the new string can
1028 be freed with the C<Safefree()> function.
1034 Perl_savepv(pTHX_ const char *pv)
1036 PERL_UNUSED_CONTEXT;
1041 const STRLEN pvlen = strlen(pv)+1;
1042 Newx(newaddr, pvlen, char);
1043 return (char*)memcpy(newaddr, pv, pvlen);
1047 /* same thing but with a known length */
1052 Perl's version of what C<strndup()> would be if it existed. Returns a
1053 pointer to a newly allocated string which is a duplicate of the first
1054 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
1055 the new string can be freed with the C<Safefree()> function.
1061 Perl_savepvn(pTHX_ const char *pv, register I32 len)
1063 register char *newaddr;
1064 PERL_UNUSED_CONTEXT;
1066 Newx(newaddr,len+1,char);
1067 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1069 /* might not be null terminated */
1070 newaddr[len] = '\0';
1071 return (char *) CopyD(pv,newaddr,len,char);
1074 return (char *) ZeroD(newaddr,len+1,char);
1079 =for apidoc savesharedpv
1081 A version of C<savepv()> which allocates the duplicate string in memory
1082 which is shared between threads.
1087 Perl_savesharedpv(pTHX_ const char *pv)
1089 register char *newaddr;
1094 pvlen = strlen(pv)+1;
1095 newaddr = (char*)PerlMemShared_malloc(pvlen);
1097 return write_no_mem();
1099 return (char*)memcpy(newaddr, pv, pvlen);
1103 =for apidoc savesharedpvn
1105 A version of C<savepvn()> which allocates the duplicate string in memory
1106 which is shared between threads. (With the specific difference that a NULL
1107 pointer is not acceptable)
1112 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1114 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1116 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1119 return write_no_mem();
1121 newaddr[len] = '\0';
1122 return (char*)memcpy(newaddr, pv, len);
1126 =for apidoc savesvpv
1128 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1129 the passed in SV using C<SvPV()>
1135 Perl_savesvpv(pTHX_ SV *sv)
1138 const char * const pv = SvPV_const(sv, len);
1139 register char *newaddr;
1141 PERL_ARGS_ASSERT_SAVESVPV;
1144 Newx(newaddr,len,char);
1145 return (char *) CopyD(pv,newaddr,len,char);
1149 =for apidoc savesharedsvpv
1151 A version of C<savesharedpv()> which allocates the duplicate string in
1152 memory which is shared between threads.
1158 Perl_savesharedsvpv(pTHX_ SV *sv)
1161 const char * const pv = SvPV_const(sv, len);
1163 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1165 return savesharedpvn(pv, len);
1168 /* the SV for Perl_form() and mess() is not kept in an arena */
1177 if (PL_phase != PERL_PHASE_DESTRUCT)
1178 return newSVpvs_flags("", SVs_TEMP);
1183 /* Create as PVMG now, to avoid any upgrading later */
1185 Newxz(any, 1, XPVMG);
1186 SvFLAGS(sv) = SVt_PVMG;
1187 SvANY(sv) = (void*)any;
1189 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1194 #if defined(PERL_IMPLICIT_CONTEXT)
1196 Perl_form_nocontext(const char* pat, ...)
1201 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1202 va_start(args, pat);
1203 retval = vform(pat, &args);
1207 #endif /* PERL_IMPLICIT_CONTEXT */
1210 =head1 Miscellaneous Functions
1213 Takes a sprintf-style format pattern and conventional
1214 (non-SV) arguments and returns the formatted string.
1216 (char *) Perl_form(pTHX_ const char* pat, ...)
1218 can be used any place a string (char *) is required:
1220 char * s = Perl_form("%d.%d",major,minor);
1222 Uses a single private buffer so if you want to format several strings you
1223 must explicitly copy the earlier strings away (and free the copies when you
1230 Perl_form(pTHX_ const char* pat, ...)
1234 PERL_ARGS_ASSERT_FORM;
1235 va_start(args, pat);
1236 retval = vform(pat, &args);
1242 Perl_vform(pTHX_ const char *pat, va_list *args)
1244 SV * const sv = mess_alloc();
1245 PERL_ARGS_ASSERT_VFORM;
1246 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1251 =for apidoc Am|SV *|mess|const char *pat|...
1253 Take a sprintf-style format pattern and argument list. These are used to
1254 generate a string message. If the message does not end with a newline,
1255 then it will be extended with some indication of the current location
1256 in the code, as described for L</mess_sv>.
1258 Normally, the resulting message is returned in a new mortal SV.
1259 During global destruction a single SV may be shared between uses of
1265 #if defined(PERL_IMPLICIT_CONTEXT)
1267 Perl_mess_nocontext(const char *pat, ...)
1272 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1273 va_start(args, pat);
1274 retval = vmess(pat, &args);
1278 #endif /* PERL_IMPLICIT_CONTEXT */
1281 Perl_mess(pTHX_ const char *pat, ...)
1285 PERL_ARGS_ASSERT_MESS;
1286 va_start(args, pat);
1287 retval = vmess(pat, &args);
1293 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1296 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1298 PERL_ARGS_ASSERT_CLOSEST_COP;
1300 if (!o || o == PL_op)
1303 if (o->op_flags & OPf_KIDS) {
1305 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1308 /* If the OP_NEXTSTATE has been optimised away we can still use it
1309 * the get the file and line number. */
1311 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1312 cop = (const COP *)kid;
1314 /* Keep searching, and return when we've found something. */
1316 new_cop = closest_cop(cop, kid);
1322 /* Nothing found. */
1328 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1330 Expands a message, intended for the user, to include an indication of
1331 the current location in the code, if the message does not already appear
1334 C<basemsg> is the initial message or object. If it is a reference, it
1335 will be used as-is and will be the result of this function. Otherwise it
1336 is used as a string, and if it already ends with a newline, it is taken
1337 to be complete, and the result of this function will be the same string.
1338 If the message does not end with a newline, then a segment such as C<at
1339 foo.pl line 37> will be appended, and possibly other clauses indicating
1340 the current state of execution. The resulting message will end with a
1343 Normally, the resulting message is returned in a new mortal SV.
1344 During global destruction a single SV may be shared between uses of this
1345 function. If C<consume> is true, then the function is permitted (but not
1346 required) to modify and return C<basemsg> instead of allocating a new SV.
1352 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1357 PERL_ARGS_ASSERT_MESS_SV;
1359 if (SvROK(basemsg)) {
1365 sv_setsv(sv, basemsg);
1370 if (SvPOK(basemsg) && consume) {
1375 sv_copypv(sv, basemsg);
1378 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1380 * Try and find the file and line for PL_op. This will usually be
1381 * PL_curcop, but it might be a cop that has been optimised away. We
1382 * can try to find such a cop by searching through the optree starting
1383 * from the sibling of PL_curcop.
1386 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1391 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1392 OutCopFILE(cop), (IV)CopLINE(cop));
1393 /* Seems that GvIO() can be untrustworthy during global destruction. */
1394 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1395 && IoLINES(GvIOp(PL_last_in_gv)))
1397 const bool line_mode = (RsSIMPLE(PL_rs) &&
1398 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1399 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1400 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1401 line_mode ? "line" : "chunk",
1402 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1404 if (PL_phase == PERL_PHASE_DESTRUCT)
1405 sv_catpvs(sv, " during global destruction");
1406 sv_catpvs(sv, ".\n");
1412 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1414 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1415 argument list. These are used to generate a string message. If the
1416 message does not end with a newline, then it will be extended with
1417 some indication of the current location in the code, as described for
1420 Normally, the resulting message is returned in a new mortal SV.
1421 During global destruction a single SV may be shared between uses of
1428 Perl_vmess(pTHX_ const char *pat, va_list *args)
1431 SV * const sv = mess_alloc();
1433 PERL_ARGS_ASSERT_VMESS;
1435 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1436 return mess_sv(sv, 1);
1440 Perl_write_to_stderr(pTHX_ SV* msv)
1446 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1448 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1449 && (io = GvIO(PL_stderrgv))
1450 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1451 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
1452 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1455 /* SFIO can really mess with your errno */
1458 PerlIO * const serr = Perl_error_log;
1460 do_print(msv, serr);
1461 (void)PerlIO_flush(serr);
1469 =head1 Warning and Dieing
1472 /* Common code used in dieing and warning */
1475 S_with_queued_errors(pTHX_ SV *ex)
1477 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1478 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1479 sv_catsv(PL_errors, ex);
1480 ex = sv_mortalcopy(PL_errors);
1481 SvCUR_set(PL_errors, 0);
1487 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1493 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1494 /* sv_2cv might call Perl_croak() or Perl_warner() */
1495 SV * const oldhook = *hook;
1503 cv = sv_2cv(oldhook, &stash, &gv, 0);
1505 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1515 exarg = newSVsv(ex);
1516 SvREADONLY_on(exarg);
1519 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1523 call_sv(MUTABLE_SV(cv), G_DISCARD);
1532 =for apidoc Am|OP *|die_sv|SV *baseex
1534 Behaves the same as L</croak_sv>, except for the return type.
1535 It should be used only where the C<OP *> return type is required.
1536 The function never actually returns.
1542 Perl_die_sv(pTHX_ SV *baseex)
1544 PERL_ARGS_ASSERT_DIE_SV;
1551 =for apidoc Am|OP *|die|const char *pat|...
1553 Behaves the same as L</croak>, except for the return type.
1554 It should be used only where the C<OP *> return type is required.
1555 The function never actually returns.
1560 #if defined(PERL_IMPLICIT_CONTEXT)
1562 Perl_die_nocontext(const char* pat, ...)
1566 va_start(args, pat);
1572 #endif /* PERL_IMPLICIT_CONTEXT */
1575 Perl_die(pTHX_ const char* pat, ...)
1578 va_start(args, pat);
1586 =for apidoc Am|void|croak_sv|SV *baseex
1588 This is an XS interface to Perl's C<die> function.
1590 C<baseex> is the error message or object. If it is a reference, it
1591 will be used as-is. Otherwise it is used as a string, and if it does
1592 not end with a newline then it will be extended with some indication of
1593 the current location in the code, as described for L</mess_sv>.
1595 The error message or object will be used as an exception, by default
1596 returning control to the nearest enclosing C<eval>, but subject to
1597 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1598 function never returns normally.
1600 To die with a simple string message, the L</croak> function may be
1607 Perl_croak_sv(pTHX_ SV *baseex)
1609 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1610 PERL_ARGS_ASSERT_CROAK_SV;
1611 invoke_exception_hook(ex, FALSE);
1616 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1618 This is an XS interface to Perl's C<die> function.
1620 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1621 argument list. These are used to generate a string message. If the
1622 message does not end with a newline, then it will be extended with
1623 some indication of the current location in the code, as described for
1626 The error message will be used as an exception, by default
1627 returning control to the nearest enclosing C<eval>, but subject to
1628 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1629 function never returns normally.
1631 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1632 (C<$@>) will be used as an error message or object instead of building an
1633 error message from arguments. If you want to throw a non-string object,
1634 or build an error message in an SV yourself, it is preferable to use
1635 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1641 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1643 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1644 invoke_exception_hook(ex, FALSE);
1649 =for apidoc Am|void|croak|const char *pat|...
1651 This is an XS interface to Perl's C<die> function.
1653 Take a sprintf-style format pattern and argument list. These are used to
1654 generate a string message. If the message does not end with a newline,
1655 then it will be extended with some indication of the current location
1656 in the code, as described for L</mess_sv>.
1658 The error message will be used as an exception, by default
1659 returning control to the nearest enclosing C<eval>, but subject to
1660 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1661 function never returns normally.
1663 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1664 (C<$@>) will be used as an error message or object instead of building an
1665 error message from arguments. If you want to throw a non-string object,
1666 or build an error message in an SV yourself, it is preferable to use
1667 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1672 #if defined(PERL_IMPLICIT_CONTEXT)
1674 Perl_croak_nocontext(const char *pat, ...)
1678 va_start(args, pat);
1683 #endif /* PERL_IMPLICIT_CONTEXT */
1686 Perl_croak(pTHX_ const char *pat, ...)
1689 va_start(args, pat);
1696 =for apidoc Am|void|croak_no_modify
1698 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1699 terser object code than using C<Perl_croak>. Less code used on exception code
1700 paths reduces CPU cache pressure.
1706 Perl_croak_no_modify(pTHX)
1708 Perl_croak(aTHX_ "%s", PL_no_modify);
1712 =for apidoc Am|void|warn_sv|SV *baseex
1714 This is an XS interface to Perl's C<warn> function.
1716 C<baseex> is the error message or object. If it is a reference, it
1717 will be used as-is. Otherwise it is used as a string, and if it does
1718 not end with a newline then it will be extended with some indication of
1719 the current location in the code, as described for L</mess_sv>.
1721 The error message or object will by default be written to standard error,
1722 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1724 To warn with a simple string message, the L</warn> function may be
1731 Perl_warn_sv(pTHX_ SV *baseex)
1733 SV *ex = mess_sv(baseex, 0);
1734 PERL_ARGS_ASSERT_WARN_SV;
1735 if (!invoke_exception_hook(ex, TRUE))
1736 write_to_stderr(ex);
1740 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1742 This is an XS interface to Perl's C<warn> function.
1744 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1745 argument list. These are used to generate a string message. If the
1746 message does not end with a newline, then it will be extended with
1747 some indication of the current location in the code, as described for
1750 The error message or object will by default be written to standard error,
1751 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1753 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1759 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1761 SV *ex = vmess(pat, args);
1762 PERL_ARGS_ASSERT_VWARN;
1763 if (!invoke_exception_hook(ex, TRUE))
1764 write_to_stderr(ex);
1768 =for apidoc Am|void|warn|const char *pat|...
1770 This is an XS interface to Perl's C<warn> function.
1772 Take a sprintf-style format pattern and argument list. These are used to
1773 generate a string message. If the message does not end with a newline,
1774 then it will be extended with some indication of the current location
1775 in the code, as described for L</mess_sv>.
1777 The error message or object will by default be written to standard error,
1778 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1780 Unlike with L</croak>, C<pat> is not permitted to be null.
1785 #if defined(PERL_IMPLICIT_CONTEXT)
1787 Perl_warn_nocontext(const char *pat, ...)
1791 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1792 va_start(args, pat);
1796 #endif /* PERL_IMPLICIT_CONTEXT */
1799 Perl_warn(pTHX_ const char *pat, ...)
1802 PERL_ARGS_ASSERT_WARN;
1803 va_start(args, pat);
1808 #if defined(PERL_IMPLICIT_CONTEXT)
1810 Perl_warner_nocontext(U32 err, const char *pat, ...)
1814 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1815 va_start(args, pat);
1816 vwarner(err, pat, &args);
1819 #endif /* PERL_IMPLICIT_CONTEXT */
1822 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1824 PERL_ARGS_ASSERT_CK_WARNER_D;
1826 if (Perl_ckwarn_d(aTHX_ err)) {
1828 va_start(args, pat);
1829 vwarner(err, pat, &args);
1835 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1837 PERL_ARGS_ASSERT_CK_WARNER;
1839 if (Perl_ckwarn(aTHX_ err)) {
1841 va_start(args, pat);
1842 vwarner(err, pat, &args);
1848 Perl_warner(pTHX_ U32 err, const char* pat,...)
1851 PERL_ARGS_ASSERT_WARNER;
1852 va_start(args, pat);
1853 vwarner(err, pat, &args);
1858 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1861 PERL_ARGS_ASSERT_VWARNER;
1862 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1863 SV * const msv = vmess(pat, args);
1865 invoke_exception_hook(msv, FALSE);
1869 Perl_vwarn(aTHX_ pat, args);
1873 /* implements the ckWARN? macros */
1876 Perl_ckwarn(pTHX_ U32 w)
1879 /* If lexical warnings have not been set, use $^W. */
1881 return PL_dowarn & G_WARN_ON;
1883 return ckwarn_common(w);
1886 /* implements the ckWARN?_d macro */
1889 Perl_ckwarn_d(pTHX_ U32 w)
1892 /* If lexical warnings have not been set then default classes warn. */
1896 return ckwarn_common(w);
1900 S_ckwarn_common(pTHX_ U32 w)
1902 if (PL_curcop->cop_warnings == pWARN_ALL)
1905 if (PL_curcop->cop_warnings == pWARN_NONE)
1908 /* Check the assumption that at least the first slot is non-zero. */
1909 assert(unpackWARN1(w));
1911 /* Check the assumption that it is valid to stop as soon as a zero slot is
1913 if (!unpackWARN2(w)) {
1914 assert(!unpackWARN3(w));
1915 assert(!unpackWARN4(w));
1916 } else if (!unpackWARN3(w)) {
1917 assert(!unpackWARN4(w));
1920 /* Right, dealt with all the special cases, which are implemented as non-
1921 pointers, so there is a pointer to a real warnings mask. */
1923 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1925 } while (w >>= WARNshift);
1930 /* Set buffer=NULL to get a new one. */
1932 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1934 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1935 PERL_UNUSED_CONTEXT;
1936 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1939 (specialWARN(buffer) ?
1940 PerlMemShared_malloc(len_wanted) :
1941 PerlMemShared_realloc(buffer, len_wanted));
1943 Copy(bits, (buffer + 1), size, char);
1947 /* since we've already done strlen() for both nam and val
1948 * we can use that info to make things faster than
1949 * sprintf(s, "%s=%s", nam, val)
1951 #define my_setenv_format(s, nam, nlen, val, vlen) \
1952 Copy(nam, s, nlen, char); \
1954 Copy(val, s+(nlen+1), vlen, char); \
1955 *(s+(nlen+1+vlen)) = '\0'
1957 #ifdef USE_ENVIRON_ARRAY
1958 /* VMS' my_setenv() is in vms.c */
1959 #if !defined(WIN32) && !defined(NETWARE)
1961 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1965 /* only parent thread can modify process environment */
1966 if (PL_curinterp == aTHX)
1969 #ifndef PERL_USE_SAFE_PUTENV
1970 if (!PL_use_safe_putenv) {
1971 /* most putenv()s leak, so we manipulate environ directly */
1973 register const I32 len = strlen(nam);
1976 /* where does it go? */
1977 for (i = 0; environ[i]; i++) {
1978 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1982 if (environ == PL_origenviron) { /* need we copy environment? */
1988 while (environ[max])
1990 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1991 for (j=0; j<max; j++) { /* copy environment */
1992 const int len = strlen(environ[j]);
1993 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1994 Copy(environ[j], tmpenv[j], len+1, char);
1997 environ = tmpenv; /* tell exec where it is now */
2000 safesysfree(environ[i]);
2001 while (environ[i]) {
2002 environ[i] = environ[i+1];
2007 if (!environ[i]) { /* does not exist yet */
2008 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2009 environ[i+1] = NULL; /* make sure it's null terminated */
2012 safesysfree(environ[i]);
2016 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2017 /* all that work just for this */
2018 my_setenv_format(environ[i], nam, nlen, val, vlen);
2021 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
2022 # if defined(HAS_UNSETENV)
2024 (void)unsetenv(nam);
2026 (void)setenv(nam, val, 1);
2028 # else /* ! HAS_UNSETENV */
2029 (void)setenv(nam, val, 1);
2030 # endif /* HAS_UNSETENV */
2032 # if defined(HAS_UNSETENV)
2034 (void)unsetenv(nam);
2036 const int nlen = strlen(nam);
2037 const int vlen = strlen(val);
2038 char * const new_env =
2039 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2040 my_setenv_format(new_env, nam, nlen, val, vlen);
2041 (void)putenv(new_env);
2043 # else /* ! HAS_UNSETENV */
2045 const int nlen = strlen(nam);
2051 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2052 /* all that work just for this */
2053 my_setenv_format(new_env, nam, nlen, val, vlen);
2054 (void)putenv(new_env);
2055 # endif /* HAS_UNSETENV */
2056 # endif /* __CYGWIN__ */
2057 #ifndef PERL_USE_SAFE_PUTENV
2063 #else /* WIN32 || NETWARE */
2066 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2069 register char *envstr;
2070 const int nlen = strlen(nam);
2077 Newx(envstr, nlen+vlen+2, char);
2078 my_setenv_format(envstr, nam, nlen, val, vlen);
2079 (void)PerlEnv_putenv(envstr);
2083 #endif /* WIN32 || NETWARE */
2085 #endif /* !VMS && !EPOC*/
2087 #ifdef UNLINK_ALL_VERSIONS
2089 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2093 PERL_ARGS_ASSERT_UNLNK;
2095 while (PerlLIO_unlink(f) >= 0)
2097 return retries ? 0 : -1;
2101 /* this is a drop-in replacement for bcopy() */
2102 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2104 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2106 char * const retval = to;
2108 PERL_ARGS_ASSERT_MY_BCOPY;
2110 if (from - to >= 0) {
2118 *(--to) = *(--from);
2124 /* this is a drop-in replacement for memset() */
2127 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2129 char * const retval = loc;
2131 PERL_ARGS_ASSERT_MY_MEMSET;
2139 /* this is a drop-in replacement for bzero() */
2140 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2142 Perl_my_bzero(register char *loc, register I32 len)
2144 char * const retval = loc;
2146 PERL_ARGS_ASSERT_MY_BZERO;
2154 /* this is a drop-in replacement for memcmp() */
2155 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2157 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2159 register const U8 *a = (const U8 *)s1;
2160 register const U8 *b = (const U8 *)s2;
2163 PERL_ARGS_ASSERT_MY_MEMCMP;
2166 if ((tmp = *a++ - *b++))
2171 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2174 /* This vsprintf replacement should generally never get used, since
2175 vsprintf was available in both System V and BSD 2.11. (There may
2176 be some cross-compilation or embedded set-ups where it is needed,
2179 If you encounter a problem in this function, it's probably a symptom
2180 that Configure failed to detect your system's vprintf() function.
2181 See the section on "item vsprintf" in the INSTALL file.
2183 This version may compile on systems with BSD-ish <stdio.h>,
2184 but probably won't on others.
2187 #ifdef USE_CHAR_VSPRINTF
2192 vsprintf(char *dest, const char *pat, void *args)
2196 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2197 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2198 FILE_cnt(&fakebuf) = 32767;
2200 /* These probably won't compile -- If you really need
2201 this, you'll have to figure out some other method. */
2202 fakebuf._ptr = dest;
2203 fakebuf._cnt = 32767;
2208 fakebuf._flag = _IOWRT|_IOSTRG;
2209 _doprnt(pat, args, &fakebuf); /* what a kludge */
2210 #if defined(STDIO_PTR_LVALUE)
2211 *(FILE_ptr(&fakebuf)++) = '\0';
2213 /* PerlIO has probably #defined away fputc, but we want it here. */
2215 # undef fputc /* XXX Should really restore it later */
2217 (void)fputc('\0', &fakebuf);
2219 #ifdef USE_CHAR_VSPRINTF
2222 return 0; /* perl doesn't use return value */
2226 #endif /* HAS_VPRINTF */
2229 #if BYTEORDER != 0x4321
2231 Perl_my_swap(pTHX_ short s)
2233 #if (BYTEORDER & 1) == 0
2236 result = ((s & 255) << 8) + ((s >> 8) & 255);
2244 Perl_my_htonl(pTHX_ long l)
2248 char c[sizeof(long)];
2251 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2252 #if BYTEORDER == 0x12345678
2255 u.c[0] = (l >> 24) & 255;
2256 u.c[1] = (l >> 16) & 255;
2257 u.c[2] = (l >> 8) & 255;
2261 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2262 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2267 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2268 u.c[o & 0xf] = (l >> s) & 255;
2276 Perl_my_ntohl(pTHX_ long l)
2280 char c[sizeof(long)];
2283 #if BYTEORDER == 0x1234
2284 u.c[0] = (l >> 24) & 255;
2285 u.c[1] = (l >> 16) & 255;
2286 u.c[2] = (l >> 8) & 255;
2290 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2291 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2298 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2299 l |= (u.c[o & 0xf] & 255) << s;
2306 #endif /* BYTEORDER != 0x4321 */
2310 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2311 * If these functions are defined,
2312 * the BYTEORDER is neither 0x1234 nor 0x4321.
2313 * However, this is not assumed.
2317 #define HTOLE(name,type) \
2319 name (register type n) \
2323 char c[sizeof(type)]; \
2326 register U32 s = 0; \
2327 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2328 u.c[i] = (n >> s) & 0xFF; \
2333 #define LETOH(name,type) \
2335 name (register type n) \
2339 char c[sizeof(type)]; \
2342 register U32 s = 0; \
2345 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2346 n |= ((type)(u.c[i] & 0xFF)) << s; \
2352 * Big-endian byte order functions.
2355 #define HTOBE(name,type) \
2357 name (register type n) \
2361 char c[sizeof(type)]; \
2364 register U32 s = 8*(sizeof(u.c)-1); \
2365 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2366 u.c[i] = (n >> s) & 0xFF; \
2371 #define BETOH(name,type) \
2373 name (register type n) \
2377 char c[sizeof(type)]; \
2380 register U32 s = 8*(sizeof(u.c)-1); \
2383 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2384 n |= ((type)(u.c[i] & 0xFF)) << s; \
2390 * If we just can't do it...
2393 #define NOT_AVAIL(name,type) \
2395 name (register type n) \
2397 Perl_croak_nocontext(#name "() not available"); \
2398 return n; /* not reached */ \
2402 #if defined(HAS_HTOVS) && !defined(htovs)
2405 #if defined(HAS_HTOVL) && !defined(htovl)
2408 #if defined(HAS_VTOHS) && !defined(vtohs)
2411 #if defined(HAS_VTOHL) && !defined(vtohl)
2415 #ifdef PERL_NEED_MY_HTOLE16
2417 HTOLE(Perl_my_htole16,U16)
2419 NOT_AVAIL(Perl_my_htole16,U16)
2422 #ifdef PERL_NEED_MY_LETOH16
2424 LETOH(Perl_my_letoh16,U16)
2426 NOT_AVAIL(Perl_my_letoh16,U16)
2429 #ifdef PERL_NEED_MY_HTOBE16
2431 HTOBE(Perl_my_htobe16,U16)
2433 NOT_AVAIL(Perl_my_htobe16,U16)
2436 #ifdef PERL_NEED_MY_BETOH16
2438 BETOH(Perl_my_betoh16,U16)
2440 NOT_AVAIL(Perl_my_betoh16,U16)
2444 #ifdef PERL_NEED_MY_HTOLE32
2446 HTOLE(Perl_my_htole32,U32)
2448 NOT_AVAIL(Perl_my_htole32,U32)
2451 #ifdef PERL_NEED_MY_LETOH32
2453 LETOH(Perl_my_letoh32,U32)
2455 NOT_AVAIL(Perl_my_letoh32,U32)
2458 #ifdef PERL_NEED_MY_HTOBE32
2460 HTOBE(Perl_my_htobe32,U32)
2462 NOT_AVAIL(Perl_my_htobe32,U32)
2465 #ifdef PERL_NEED_MY_BETOH32
2467 BETOH(Perl_my_betoh32,U32)
2469 NOT_AVAIL(Perl_my_betoh32,U32)
2473 #ifdef PERL_NEED_MY_HTOLE64
2475 HTOLE(Perl_my_htole64,U64)
2477 NOT_AVAIL(Perl_my_htole64,U64)
2480 #ifdef PERL_NEED_MY_LETOH64
2482 LETOH(Perl_my_letoh64,U64)
2484 NOT_AVAIL(Perl_my_letoh64,U64)
2487 #ifdef PERL_NEED_MY_HTOBE64
2489 HTOBE(Perl_my_htobe64,U64)
2491 NOT_AVAIL(Perl_my_htobe64,U64)
2494 #ifdef PERL_NEED_MY_BETOH64
2496 BETOH(Perl_my_betoh64,U64)
2498 NOT_AVAIL(Perl_my_betoh64,U64)
2502 #ifdef PERL_NEED_MY_HTOLES
2503 HTOLE(Perl_my_htoles,short)
2505 #ifdef PERL_NEED_MY_LETOHS
2506 LETOH(Perl_my_letohs,short)
2508 #ifdef PERL_NEED_MY_HTOBES
2509 HTOBE(Perl_my_htobes,short)
2511 #ifdef PERL_NEED_MY_BETOHS
2512 BETOH(Perl_my_betohs,short)
2515 #ifdef PERL_NEED_MY_HTOLEI
2516 HTOLE(Perl_my_htolei,int)
2518 #ifdef PERL_NEED_MY_LETOHI
2519 LETOH(Perl_my_letohi,int)
2521 #ifdef PERL_NEED_MY_HTOBEI
2522 HTOBE(Perl_my_htobei,int)
2524 #ifdef PERL_NEED_MY_BETOHI
2525 BETOH(Perl_my_betohi,int)
2528 #ifdef PERL_NEED_MY_HTOLEL
2529 HTOLE(Perl_my_htolel,long)
2531 #ifdef PERL_NEED_MY_LETOHL
2532 LETOH(Perl_my_letohl,long)
2534 #ifdef PERL_NEED_MY_HTOBEL
2535 HTOBE(Perl_my_htobel,long)
2537 #ifdef PERL_NEED_MY_BETOHL
2538 BETOH(Perl_my_betohl,long)
2542 Perl_my_swabn(void *ptr, int n)
2544 register char *s = (char *)ptr;
2545 register char *e = s + (n-1);
2548 PERL_ARGS_ASSERT_MY_SWABN;
2550 for (n /= 2; n > 0; s++, e--, n--) {
2558 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2560 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2563 register I32 This, that;
2569 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2571 PERL_FLUSHALL_FOR_CHILD;
2572 This = (*mode == 'w');
2576 taint_proper("Insecure %s%s", "EXEC");
2578 if (PerlProc_pipe(p) < 0)
2580 /* Try for another pipe pair for error return */
2581 if (PerlProc_pipe(pp) >= 0)
2583 while ((pid = PerlProc_fork()) < 0) {
2584 if (errno != EAGAIN) {
2585 PerlLIO_close(p[This]);
2586 PerlLIO_close(p[that]);
2588 PerlLIO_close(pp[0]);
2589 PerlLIO_close(pp[1]);
2593 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2602 /* Close parent's end of error status pipe (if any) */
2604 PerlLIO_close(pp[0]);
2605 #if defined(HAS_FCNTL) && defined(F_SETFD)
2606 /* Close error pipe automatically if exec works */
2607 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2610 /* Now dup our end of _the_ pipe to right position */
2611 if (p[THIS] != (*mode == 'r')) {
2612 PerlLIO_dup2(p[THIS], *mode == 'r');
2613 PerlLIO_close(p[THIS]);
2614 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2615 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2618 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2619 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2620 /* No automatic close - do it by hand */
2627 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2633 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2639 do_execfree(); /* free any memory malloced by child on fork */
2641 PerlLIO_close(pp[1]);
2642 /* Keep the lower of the two fd numbers */
2643 if (p[that] < p[This]) {
2644 PerlLIO_dup2(p[This], p[that]);
2645 PerlLIO_close(p[This]);
2649 PerlLIO_close(p[that]); /* close child's end of pipe */
2651 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2652 SvUPGRADE(sv,SVt_IV);
2654 PL_forkprocess = pid;
2655 /* If we managed to get status pipe check for exec fail */
2656 if (did_pipes && pid > 0) {
2661 while (n < sizeof(int)) {
2662 n1 = PerlLIO_read(pp[0],
2663 (void*)(((char*)&errkid)+n),
2669 PerlLIO_close(pp[0]);
2671 if (n) { /* Error */
2673 PerlLIO_close(p[This]);
2674 if (n != sizeof(int))
2675 Perl_croak(aTHX_ "panic: kid popen errno read");
2677 pid2 = wait4pid(pid, &status, 0);
2678 } while (pid2 == -1 && errno == EINTR);
2679 errno = errkid; /* Propagate errno from kid */
2684 PerlLIO_close(pp[0]);
2685 return PerlIO_fdopen(p[This], mode);
2687 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2688 return my_syspopen4(aTHX_ NULL, mode, n, args);
2690 Perl_croak(aTHX_ "List form of piped open not implemented");
2691 return (PerlIO *) NULL;
2696 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2697 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2699 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2703 register I32 This, that;
2706 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2710 PERL_ARGS_ASSERT_MY_POPEN;
2712 PERL_FLUSHALL_FOR_CHILD;
2715 return my_syspopen(aTHX_ cmd,mode);
2718 This = (*mode == 'w');
2720 if (doexec && PL_tainting) {
2722 taint_proper("Insecure %s%s", "EXEC");
2724 if (PerlProc_pipe(p) < 0)
2726 if (doexec && PerlProc_pipe(pp) >= 0)
2728 while ((pid = PerlProc_fork()) < 0) {
2729 if (errno != EAGAIN) {
2730 PerlLIO_close(p[This]);
2731 PerlLIO_close(p[that]);
2733 PerlLIO_close(pp[0]);
2734 PerlLIO_close(pp[1]);
2737 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2740 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2750 PerlLIO_close(pp[0]);
2751 #if defined(HAS_FCNTL) && defined(F_SETFD)
2752 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2755 if (p[THIS] != (*mode == 'r')) {
2756 PerlLIO_dup2(p[THIS], *mode == 'r');
2757 PerlLIO_close(p[THIS]);
2758 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2759 PerlLIO_close(p[THAT]);
2762 PerlLIO_close(p[THAT]);
2765 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2772 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2777 /* may or may not use the shell */
2778 do_exec3(cmd, pp[1], did_pipes);
2781 #endif /* defined OS2 */
2783 #ifdef PERLIO_USING_CRLF
2784 /* Since we circumvent IO layers when we manipulate low-level
2785 filedescriptors directly, need to manually switch to the
2786 default, binary, low-level mode; see PerlIOBuf_open(). */
2787 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2789 #ifdef THREADS_HAVE_PIDS
2790 PL_ppid = (IV)getppid();
2793 #ifdef PERL_USES_PL_PIDSTATUS
2794 hv_clear(PL_pidstatus); /* we have no children */
2800 do_execfree(); /* free any memory malloced by child on vfork */
2802 PerlLIO_close(pp[1]);
2803 if (p[that] < p[This]) {
2804 PerlLIO_dup2(p[This], p[that]);
2805 PerlLIO_close(p[This]);
2809 PerlLIO_close(p[that]);
2811 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2812 SvUPGRADE(sv,SVt_IV);
2814 PL_forkprocess = pid;
2815 if (did_pipes && pid > 0) {
2820 while (n < sizeof(int)) {
2821 n1 = PerlLIO_read(pp[0],
2822 (void*)(((char*)&errkid)+n),
2828 PerlLIO_close(pp[0]);
2830 if (n) { /* Error */
2832 PerlLIO_close(p[This]);
2833 if (n != sizeof(int))
2834 Perl_croak(aTHX_ "panic: kid popen errno read");
2836 pid2 = wait4pid(pid, &status, 0);
2837 } while (pid2 == -1 && errno == EINTR);
2838 errno = errkid; /* Propagate errno from kid */
2843 PerlLIO_close(pp[0]);
2844 return PerlIO_fdopen(p[This], mode);
2847 #if defined(atarist) || defined(EPOC)
2850 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2852 PERL_ARGS_ASSERT_MY_POPEN;
2853 PERL_FLUSHALL_FOR_CHILD;
2854 /* Call system's popen() to get a FILE *, then import it.
2855 used 0 for 2nd parameter to PerlIO_importFILE;
2858 return PerlIO_importFILE(popen(cmd, mode), 0);
2862 FILE *djgpp_popen();
2864 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2866 PERL_FLUSHALL_FOR_CHILD;
2867 /* Call system's popen() to get a FILE *, then import it.
2868 used 0 for 2nd parameter to PerlIO_importFILE;
2871 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2874 #if defined(__LIBCATAMOUNT__)
2876 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2884 #endif /* !DOSISH */
2886 /* this is called in parent before the fork() */
2888 Perl_atfork_lock(void)
2891 #if defined(USE_ITHREADS)
2892 /* locks must be held in locking order (if any) */
2894 MUTEX_LOCK(&PL_malloc_mutex);
2900 /* this is called in both parent and child after the fork() */
2902 Perl_atfork_unlock(void)
2905 #if defined(USE_ITHREADS)
2906 /* locks must be released in same order as in atfork_lock() */
2908 MUTEX_UNLOCK(&PL_malloc_mutex);
2917 #if defined(HAS_FORK)
2919 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2924 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2925 * handlers elsewhere in the code */
2930 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2931 Perl_croak_nocontext("fork() not available");
2933 #endif /* HAS_FORK */
2938 Perl_dump_fds(pTHX_ const char *const s)
2943 PERL_ARGS_ASSERT_DUMP_FDS;
2945 PerlIO_printf(Perl_debug_log,"%s", s);
2946 for (fd = 0; fd < 32; fd++) {
2947 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2948 PerlIO_printf(Perl_debug_log," %d",fd);
2950 PerlIO_printf(Perl_debug_log,"\n");
2953 #endif /* DUMP_FDS */
2957 dup2(int oldfd, int newfd)
2959 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2962 PerlLIO_close(newfd);
2963 return fcntl(oldfd, F_DUPFD, newfd);
2965 #define DUP2_MAX_FDS 256
2966 int fdtmp[DUP2_MAX_FDS];
2972 PerlLIO_close(newfd);
2973 /* good enough for low fd's... */
2974 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2975 if (fdx >= DUP2_MAX_FDS) {
2983 PerlLIO_close(fdtmp[--fdx]);
2990 #ifdef HAS_SIGACTION
2993 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2996 struct sigaction act, oact;
2999 /* only "parent" interpreter can diddle signals */
3000 if (PL_curinterp != aTHX)
3001 return (Sighandler_t) SIG_ERR;
3004 act.sa_handler = (void(*)(int))handler;
3005 sigemptyset(&act.sa_mask);
3008 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3009 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3011 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3012 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3013 act.sa_flags |= SA_NOCLDWAIT;
3015 if (sigaction(signo, &act, &oact) == -1)
3016 return (Sighandler_t) SIG_ERR;
3018 return (Sighandler_t) oact.sa_handler;
3022 Perl_rsignal_state(pTHX_ int signo)
3024 struct sigaction oact;
3025 PERL_UNUSED_CONTEXT;
3027 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3028 return (Sighandler_t) SIG_ERR;
3030 return (Sighandler_t) oact.sa_handler;
3034 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3037 struct sigaction act;
3039 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3042 /* only "parent" interpreter can diddle signals */
3043 if (PL_curinterp != aTHX)
3047 act.sa_handler = (void(*)(int))handler;
3048 sigemptyset(&act.sa_mask);
3051 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3052 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3054 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3055 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3056 act.sa_flags |= SA_NOCLDWAIT;
3058 return sigaction(signo, &act, save);
3062 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3066 /* only "parent" interpreter can diddle signals */
3067 if (PL_curinterp != aTHX)
3071 return sigaction(signo, save, (struct sigaction *)NULL);
3074 #else /* !HAS_SIGACTION */
3077 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3079 #if defined(USE_ITHREADS) && !defined(WIN32)
3080 /* only "parent" interpreter can diddle signals */
3081 if (PL_curinterp != aTHX)
3082 return (Sighandler_t) SIG_ERR;
3085 return PerlProc_signal(signo, handler);
3096 Perl_rsignal_state(pTHX_ int signo)
3099 Sighandler_t oldsig;
3101 #if defined(USE_ITHREADS) && !defined(WIN32)
3102 /* only "parent" interpreter can diddle signals */
3103 if (PL_curinterp != aTHX)
3104 return (Sighandler_t) SIG_ERR;
3108 oldsig = PerlProc_signal(signo, sig_trap);
3109 PerlProc_signal(signo, oldsig);
3111 PerlProc_kill(PerlProc_getpid(), signo);
3116 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3118 #if defined(USE_ITHREADS) && !defined(WIN32)
3119 /* only "parent" interpreter can diddle signals */
3120 if (PL_curinterp != aTHX)
3123 *save = PerlProc_signal(signo, handler);
3124 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3128 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3130 #if defined(USE_ITHREADS) && !defined(WIN32)
3131 /* only "parent" interpreter can diddle signals */
3132 if (PL_curinterp != aTHX)
3135 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3138 #endif /* !HAS_SIGACTION */
3139 #endif /* !PERL_MICRO */
3141 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3142 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3144 Perl_my_pclose(pTHX_ PerlIO *ptr)
3147 Sigsave_t hstat, istat, qstat;
3154 const int fd = PerlIO_fileno(ptr);
3157 /* Find out whether the refcount is low enough for us to wait for the
3158 child proc without blocking. */
3159 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3161 const bool should_wait = 1;
3164 svp = av_fetch(PL_fdpid,fd,TRUE);
3165 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3167 *svp = &PL_sv_undef;
3169 if (pid == -1) { /* Opened by popen. */
3170 return my_syspclose(ptr);
3173 close_failed = (PerlIO_close(ptr) == EOF);
3176 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
3179 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3180 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3181 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3183 if (should_wait) do {
3184 pid2 = wait4pid(pid, &status, 0);
3185 } while (pid2 == -1 && errno == EINTR);
3187 rsignal_restore(SIGHUP, &hstat);
3188 rsignal_restore(SIGINT, &istat);
3189 rsignal_restore(SIGQUIT, &qstat);
3197 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3202 #if defined(__LIBCATAMOUNT__)
3204 Perl_my_pclose(pTHX_ PerlIO *ptr)
3209 #endif /* !DOSISH */
3211 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3213 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3217 PERL_ARGS_ASSERT_WAIT4PID;
3220 #ifdef PERL_USES_PL_PIDSTATUS
3223 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3224 pid, rather than a string form. */
3225 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3226 if (svp && *svp != &PL_sv_undef) {
3227 *statusp = SvIVX(*svp);
3228 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3236 hv_iterinit(PL_pidstatus);
3237 if ((entry = hv_iternext(PL_pidstatus))) {
3238 SV * const sv = hv_iterval(PL_pidstatus,entry);
3240 const char * const spid = hv_iterkey(entry,&len);
3242 assert (len == sizeof(Pid_t));
3243 memcpy((char *)&pid, spid, len);
3244 *statusp = SvIVX(sv);
3245 /* The hash iterator is currently on this entry, so simply
3246 calling hv_delete would trigger the lazy delete, which on
3247 aggregate does more work, beacuse next call to hv_iterinit()
3248 would spot the flag, and have to call the delete routine,
3249 while in the meantime any new entries can't re-use that
3251 hv_iterinit(PL_pidstatus);
3252 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3259 # ifdef HAS_WAITPID_RUNTIME
3260 if (!HAS_WAITPID_RUNTIME)
3263 result = PerlProc_waitpid(pid,statusp,flags);
3266 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3267 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3270 #ifdef PERL_USES_PL_PIDSTATUS
3271 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3276 Perl_croak(aTHX_ "Can't do waitpid with flags");
3278 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3279 pidgone(result,*statusp);
3285 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3288 if (result < 0 && errno == EINTR) {
3290 errno = EINTR; /* reset in case a signal handler changed $! */
3294 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3296 #ifdef PERL_USES_PL_PIDSTATUS
3298 S_pidgone(pTHX_ Pid_t pid, int status)
3302 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3303 SvUPGRADE(sv,SVt_IV);
3304 SvIV_set(sv, status);
3309 #if defined(atarist) || defined(OS2) || defined(EPOC)
3312 int /* Cannot prototype with I32
3314 my_syspclose(PerlIO *ptr)
3317 Perl_my_pclose(pTHX_ PerlIO *ptr)
3320 /* Needs work for PerlIO ! */
3321 FILE * const f = PerlIO_findFILE(ptr);
3322 const I32 result = pclose(f);
3323 PerlIO_releaseFILE(ptr,f);
3331 Perl_my_pclose(pTHX_ PerlIO *ptr)
3333 /* Needs work for PerlIO ! */
3334 FILE * const f = PerlIO_findFILE(ptr);
3335 I32 result = djgpp_pclose(f);
3336 result = (result << 8) & 0xff00;
3337 PerlIO_releaseFILE(ptr,f);
3342 #define PERL_REPEATCPY_LINEAR 4
3344 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3346 PERL_ARGS_ASSERT_REPEATCPY;
3349 memset(to, *from, count);
3351 register char *p = to;
3352 I32 items, linear, half;
3354 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3355 for (items = 0; items < linear; ++items) {
3356 register const char *q = from;
3358 for (todo = len; todo > 0; todo--)
3363 while (items <= half) {
3364 I32 size = items * len;
3365 memcpy(p, to, size);
3371 memcpy(p, to, (count - items) * len);
3377 Perl_same_dirent(pTHX_ const char *a, const char *b)
3379 char *fa = strrchr(a,'/');
3380 char *fb = strrchr(b,'/');
3383 SV * const tmpsv = sv_newmortal();
3385 PERL_ARGS_ASSERT_SAME_DIRENT;
3398 sv_setpvs(tmpsv, ".");
3400 sv_setpvn(tmpsv, a, fa - a);
3401 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3404 sv_setpvs(tmpsv, ".");
3406 sv_setpvn(tmpsv, b, fb - b);
3407 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3409 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3410 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3412 #endif /* !HAS_RENAME */
3415 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3416 const char *const *const search_ext, I32 flags)
3419 const char *xfound = NULL;
3420 char *xfailed = NULL;
3421 char tmpbuf[MAXPATHLEN];
3426 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3427 # define SEARCH_EXTS ".bat", ".cmd", NULL
3428 # define MAX_EXT_LEN 4
3431 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3432 # define MAX_EXT_LEN 4
3435 # define SEARCH_EXTS ".pl", ".com", NULL
3436 # define MAX_EXT_LEN 4
3438 /* additional extensions to try in each dir if scriptname not found */
3440 static const char *const exts[] = { SEARCH_EXTS };
3441 const char *const *const ext = search_ext ? search_ext : exts;
3442 int extidx = 0, i = 0;
3443 const char *curext = NULL;
3445 PERL_UNUSED_ARG(search_ext);
3446 # define MAX_EXT_LEN 0
3449 PERL_ARGS_ASSERT_FIND_SCRIPT;
3452 * If dosearch is true and if scriptname does not contain path
3453 * delimiters, search the PATH for scriptname.
3455 * If SEARCH_EXTS is also defined, will look for each
3456 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3457 * while searching the PATH.
3459 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3460 * proceeds as follows:
3461 * If DOSISH or VMSISH:
3462 * + look for ./scriptname{,.foo,.bar}
3463 * + search the PATH for scriptname{,.foo,.bar}
3466 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3467 * this will not look in '.' if it's not in the PATH)
3472 # ifdef ALWAYS_DEFTYPES
3473 len = strlen(scriptname);
3474 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3475 int idx = 0, deftypes = 1;
3478 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3481 int idx = 0, deftypes = 1;
3484 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3486 /* The first time through, just add SEARCH_EXTS to whatever we
3487 * already have, so we can check for default file types. */
3489 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3495 if ((strlen(tmpbuf) + strlen(scriptname)
3496 + MAX_EXT_LEN) >= sizeof tmpbuf)
3497 continue; /* don't search dir with too-long name */
3498 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3502 if (strEQ(scriptname, "-"))
3504 if (dosearch) { /* Look in '.' first. */
3505 const char *cur = scriptname;
3507 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3509 if (strEQ(ext[i++],curext)) {
3510 extidx = -1; /* already has an ext */
3515 DEBUG_p(PerlIO_printf(Perl_debug_log,
3516 "Looking for %s\n",cur));
3517 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3518 && !S_ISDIR(PL_statbuf.st_mode)) {
3526 if (cur == scriptname) {
3527 len = strlen(scriptname);
3528 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3530 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3533 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3534 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3539 if (dosearch && !strchr(scriptname, '/')
3541 && !strchr(scriptname, '\\')
3543 && (s = PerlEnv_getenv("PATH")))
3547 bufend = s + strlen(s);
3548 while (s < bufend) {
3549 #if defined(atarist) || defined(DOSISH)
3554 && *s != ';'; len++, s++) {
3555 if (len < sizeof tmpbuf)
3558 if (len < sizeof tmpbuf)
3560 #else /* ! (atarist || DOSISH) */
3561 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3564 #endif /* ! (atarist || DOSISH) */
3567 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3568 continue; /* don't search dir with too-long name */
3570 # if defined(atarist) || defined(DOSISH)
3571 && tmpbuf[len - 1] != '/'
3572 && tmpbuf[len - 1] != '\\'
3575 tmpbuf[len++] = '/';
3576 if (len == 2 && tmpbuf[0] == '.')
3578 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3582 len = strlen(tmpbuf);
3583 if (extidx > 0) /* reset after previous loop */
3587 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3588 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3589 if (S_ISDIR(PL_statbuf.st_mode)) {
3593 } while ( retval < 0 /* not there */
3594 && extidx>=0 && ext[extidx] /* try an extension? */
3595 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3600 if (S_ISREG(PL_statbuf.st_mode)
3601 && cando(S_IRUSR,TRUE,&PL_statbuf)
3602 #if !defined(DOSISH)
3603 && cando(S_IXUSR,TRUE,&PL_statbuf)
3607 xfound = tmpbuf; /* bingo! */
3611 xfailed = savepv(tmpbuf);
3614 if (!xfound && !seen_dot && !xfailed &&
3615 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3616 || S_ISDIR(PL_statbuf.st_mode)))
3618 seen_dot = 1; /* Disable message. */
3620 if (flags & 1) { /* do or die? */
3621 Perl_croak(aTHX_ "Can't %s %s%s%s",
3622 (xfailed ? "execute" : "find"),
3623 (xfailed ? xfailed : scriptname),
3624 (xfailed ? "" : " on PATH"),
3625 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3630 scriptname = xfound;
3632 return (scriptname ? savepv(scriptname) : NULL);
3635 #ifndef PERL_GET_CONTEXT_DEFINED
3638 Perl_get_context(void)
3641 #if defined(USE_ITHREADS)
3642 # ifdef OLD_PTHREADS_API
3644 if (pthread_getspecific(PL_thr_key, &t))
3645 Perl_croak_nocontext("panic: pthread_getspecific");
3648 # ifdef I_MACH_CTHREADS
3649 return (void*)cthread_data(cthread_self());
3651 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3660 Perl_set_context(void *t)
3663 PERL_ARGS_ASSERT_SET_CONTEXT;
3664 #if defined(USE_ITHREADS)
3665 # ifdef I_MACH_CTHREADS
3666 cthread_set_data(cthread_self(), t);
3668 if (pthread_setspecific(PL_thr_key, t))
3669 Perl_croak_nocontext("panic: pthread_setspecific");
3676 #endif /* !PERL_GET_CONTEXT_DEFINED */
3678 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3687 Perl_get_op_names(pTHX)
3689 PERL_UNUSED_CONTEXT;
3690 return (char **)PL_op_name;
3694 Perl_get_op_descs(pTHX)
3696 PERL_UNUSED_CONTEXT;
3697 return (char **)PL_op_desc;
3701 Perl_get_no_modify(pTHX)
3703 PERL_UNUSED_CONTEXT;
3704 return PL_no_modify;
3708 Perl_get_opargs(pTHX)
3710 PERL_UNUSED_CONTEXT;
3711 return (U32 *)PL_opargs;
3715 Perl_get_ppaddr(pTHX)
3718 PERL_UNUSED_CONTEXT;
3719 return (PPADDR_t*)PL_ppaddr;
3722 #ifndef HAS_GETENV_LEN
3724 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3726 char * const env_trans = PerlEnv_getenv(env_elem);
3727 PERL_UNUSED_CONTEXT;
3728 PERL_ARGS_ASSERT_GETENV_LEN;
3730 *len = strlen(env_trans);
3737 Perl_get_vtbl(pTHX_ int vtbl_id)
3739 PERL_UNUSED_CONTEXT;
3741 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3742 ? NULL : PL_magic_vtables + vtbl_id;
3746 Perl_my_fflush_all(pTHX)
3748 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3749 return PerlIO_flush(NULL);
3751 # if defined(HAS__FWALK)
3752 extern int fflush(FILE *);
3753 /* undocumented, unprototyped, but very useful BSDism */
3754 extern void _fwalk(int (*)(FILE *));
3758 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3760 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3761 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3763 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3764 open_max = sysconf(_SC_OPEN_MAX);
3767 open_max = FOPEN_MAX;
3770 open_max = OPEN_MAX;
3781 for (i = 0; i < open_max; i++)
3782 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3783 STDIO_STREAM_ARRAY[i]._file < open_max &&
3784 STDIO_STREAM_ARRAY[i]._flag)
3785 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3789 SETERRNO(EBADF,RMS_IFI);
3796 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3798 if (ckWARN(WARN_IO)) {
3799 const char * const name
3800 = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3801 const char * const direction = have == '>' ? "out" : "in";
3804 Perl_warner(aTHX_ packWARN(WARN_IO),
3805 "Filehandle %s opened only for %sput",
3808 Perl_warner(aTHX_ packWARN(WARN_IO),
3809 "Filehandle opened only for %sput", direction);
3814 Perl_report_evil_fh(pTHX_ const GV *gv)
3816 const IO *io = gv ? GvIO(gv) : NULL;
3817 const PERL_BITFIELD16 op = PL_op->op_type;
3821 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3823 warn_type = WARN_CLOSED;
3827 warn_type = WARN_UNOPENED;
3830 if (ckWARN(warn_type)) {
3831 const char * const name
3832 = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3833 const char * const pars =
3834 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3835 const char * const func =
3837 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3838 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3840 const char * const type =
3842 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3843 ? "socket" : "filehandle");
3844 if (name && *name) {
3845 Perl_warner(aTHX_ packWARN(warn_type),
3846 "%s%s on %s %s %s", func, pars, vile, type, name);
3847 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3849 aTHX_ packWARN(warn_type),
3850 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3855 Perl_warner(aTHX_ packWARN(warn_type),
3856 "%s%s on %s %s", func, pars, vile, type);
3857 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3859 aTHX_ packWARN(warn_type),
3860 "\t(Are you trying to call %s%s on dirhandle?)\n",
3867 /* To workaround core dumps from the uninitialised tm_zone we get the
3868 * system to give us a reasonable struct to copy. This fix means that
3869 * strftime uses the tm_zone and tm_gmtoff values returned by
3870 * localtime(time()). That should give the desired result most of the
3871 * time. But probably not always!
3873 * This does not address tzname aspects of NETaa14816.
3878 # ifndef STRUCT_TM_HASZONE
3879 # define STRUCT_TM_HASZONE
3883 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3884 # ifndef HAS_TM_TM_ZONE
3885 # define HAS_TM_TM_ZONE
3890 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3892 #ifdef HAS_TM_TM_ZONE
3894 const struct tm* my_tm;
3895 PERL_ARGS_ASSERT_INIT_TM;
3897 my_tm = localtime(&now);
3899 Copy(my_tm, ptm, 1, struct tm);
3901 PERL_ARGS_ASSERT_INIT_TM;
3902 PERL_UNUSED_ARG(ptm);
3907 * mini_mktime - normalise struct tm values without the localtime()
3908 * semantics (and overhead) of mktime().
3911 Perl_mini_mktime(pTHX_ struct tm *ptm)
3915 int month, mday, year, jday;
3916 int odd_cent, odd_year;
3917 PERL_UNUSED_CONTEXT;
3919 PERL_ARGS_ASSERT_MINI_MKTIME;
3921 #define DAYS_PER_YEAR 365
3922 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3923 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3924 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3925 #define SECS_PER_HOUR (60*60)
3926 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3927 /* parentheses deliberately absent on these two, otherwise they don't work */
3928 #define MONTH_TO_DAYS 153/5
3929 #define DAYS_TO_MONTH 5/153
3930 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3931 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3932 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3933 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3936 * Year/day algorithm notes:
3938 * With a suitable offset for numeric value of the month, one can find
3939 * an offset into the year by considering months to have 30.6 (153/5) days,
3940 * using integer arithmetic (i.e., with truncation). To avoid too much
3941 * messing about with leap days, we consider January and February to be
3942 * the 13th and 14th month of the previous year. After that transformation,
3943 * we need the month index we use to be high by 1 from 'normal human' usage,
3944 * so the month index values we use run from 4 through 15.
3946 * Given that, and the rules for the Gregorian calendar (leap years are those
3947 * divisible by 4 unless also divisible by 100, when they must be divisible
3948 * by 400 instead), we can simply calculate the number of days since some
3949 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3950 * the days we derive from our month index, and adding in the day of the
3951 * month. The value used here is not adjusted for the actual origin which
3952 * it normally would use (1 January A.D. 1), since we're not exposing it.
3953 * We're only building the value so we can turn around and get the
3954 * normalised values for the year, month, day-of-month, and day-of-year.
3956 * For going backward, we need to bias the value we're using so that we find
3957 * the right year value. (Basically, we don't want the contribution of
3958 * March 1st to the number to apply while deriving the year). Having done
3959 * that, we 'count up' the contribution to the year number by accounting for
3960 * full quadracenturies (400-year periods) with their extra leap days, plus
3961 * the contribution from full centuries (to avoid counting in the lost leap
3962 * days), plus the contribution from full quad-years (to count in the normal
3963 * leap days), plus the leftover contribution from any non-leap years.
3964 * At this point, if we were working with an actual leap day, we'll have 0
3965 * days left over. This is also true for March 1st, however. So, we have
3966 * to special-case that result, and (earlier) keep track of the 'odd'
3967 * century and year contributions. If we got 4 extra centuries in a qcent,
3968 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3969 * Otherwise, we add back in the earlier bias we removed (the 123 from
3970 * figuring in March 1st), find the month index (integer division by 30.6),
3971 * and the remainder is the day-of-month. We then have to convert back to
3972 * 'real' months (including fixing January and February from being 14/15 in
3973 * the previous year to being in the proper year). After that, to get
3974 * tm_yday, we work with the normalised year and get a new yearday value for
3975 * January 1st, which we subtract from the yearday value we had earlier,
3976 * representing the date we've re-built. This is done from January 1
3977 * because tm_yday is 0-origin.
3979 * Since POSIX time routines are only guaranteed to work for times since the
3980 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3981 * applies Gregorian calendar rules even to dates before the 16th century
3982 * doesn't bother me. Besides, you'd need cultural context for a given
3983 * date to know whether it was Julian or Gregorian calendar, and that's
3984 * outside the scope for this routine. Since we convert back based on the
3985 * same rules we used to build the yearday, you'll only get strange results
3986 * for input which needed normalising, or for the 'odd' century years which
3987 * were leap years in the Julian calendar but not in the Gregorian one.
3988 * I can live with that.
3990 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3991 * that's still outside the scope for POSIX time manipulation, so I don't
3995 year = 1900 + ptm->tm_year;
3996 month = ptm->tm_mon;
3997 mday = ptm->tm_mday;
3998 /* allow given yday with no month & mday to dominate the result */
3999 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4002 jday = 1 + ptm->tm_yday;
4011 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4012 yearday += month*MONTH_TO_DAYS + mday + jday;
4014 * Note that we don't know when leap-seconds were or will be,
4015 * so we have to trust the user if we get something which looks
4016 * like a sensible leap-second. Wild values for seconds will
4017 * be rationalised, however.
4019 if ((unsigned) ptm->tm_sec <= 60) {
4026 secs += 60 * ptm->tm_min;
4027 secs += SECS_PER_HOUR * ptm->tm_hour;
4029 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4030 /* got negative remainder, but need positive time */
4031 /* back off an extra day to compensate */
4032 yearday += (secs/SECS_PER_DAY)-1;
4033 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4036 yearday += (secs/SECS_PER_DAY);
4037 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4040 else if (secs >= SECS_PER_DAY) {
4041 yearday += (secs/SECS_PER_DAY);
4042 secs %= SECS_PER_DAY;
4044 ptm->tm_hour = secs/SECS_PER_HOUR;
4045 secs %= SECS_PER_HOUR;
4046 ptm->tm_min = secs/60;
4048 ptm->tm_sec += secs;
4049 /* done with time of day effects */
4051 * The algorithm for yearday has (so far) left it high by 428.
4052 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4053 * bias it by 123 while trying to figure out what year it
4054 * really represents. Even with this tweak, the reverse
4055 * translation fails for years before A.D. 0001.
4056 * It would still fail for Feb 29, but we catch that one below.
4058 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
4059 yearday -= YEAR_ADJUST;
4060 year = (yearday / DAYS_PER_QCENT) * 400;
4061 yearday %= DAYS_PER_QCENT;
4062 odd_cent = yearday / DAYS_PER_CENT;
4063 year += odd_cent * 100;
4064 yearday %= DAYS_PER_CENT;
4065 year += (yearday / DAYS_PER_QYEAR) * 4;
4066 yearday %= DAYS_PER_QYEAR;
4067 odd_year = yearday / DAYS_PER_YEAR;
4069 yearday %= DAYS_PER_YEAR;
4070 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4075 yearday += YEAR_ADJUST; /* recover March 1st crock */
4076 month = yearday*DAYS_TO_MONTH;
4077 yearday -= month*MONTH_TO_DAYS;
4078 /* recover other leap-year adjustment */
4087 ptm->tm_year = year - 1900;
4089 ptm->tm_mday = yearday;
4090 ptm->tm_mon = month;
4094 ptm->tm_mon = month - 1;
4096 /* re-build yearday based on Jan 1 to get tm_yday */
4098 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4099 yearday += 14*MONTH_TO_DAYS + 1;
4100 ptm->tm_yday = jday - yearday;
4101 /* fix tm_wday if not overridden by caller */
4102 if ((unsigned)ptm->tm_wday > 6)
4103 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4107 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)
4115 PERL_ARGS_ASSERT_MY_STRFTIME;
4117 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4120 mytm.tm_hour = hour;
4121 mytm.tm_mday = mday;
4123 mytm.tm_year = year;
4124 mytm.tm_wday = wday;
4125 mytm.tm_yday = yday;
4126 mytm.tm_isdst = isdst;
4128 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4129 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4134 #ifdef HAS_TM_TM_GMTOFF
4135 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4137 #ifdef HAS_TM_TM_ZONE
4138 mytm.tm_zone = mytm2.tm_zone;
4143 Newx(buf, buflen, char);
4144 len = strftime(buf, buflen, fmt, &mytm);
4146 ** The following is needed to handle to the situation where
4147 ** tmpbuf overflows. Basically we want to allocate a buffer
4148 ** and try repeatedly. The reason why it is so complicated
4149 ** is that getting a return value of 0 from strftime can indicate
4150 ** one of the following:
4151 ** 1. buffer overflowed,
4152 ** 2. illegal conversion specifier, or
4153 ** 3. the format string specifies nothing to be returned(not
4154 ** an error). This could be because format is an empty string
4155 ** or it specifies %p that yields an empty string in some locale.
4156 ** If there is a better way to make it portable, go ahead by
4159 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4162 /* Possibly buf overflowed - try again with a bigger buf */
4163 const int fmtlen = strlen(fmt);
4164 int bufsize = fmtlen + buflen;
4166 Renew(buf, bufsize, char);
4168 buflen = strftime(buf, bufsize, fmt, &mytm);
4169 if (buflen > 0 && buflen < bufsize)
4171 /* heuristic to prevent out-of-memory errors */
4172 if (bufsize > 100*fmtlen) {
4178 Renew(buf, bufsize, char);
4183 Perl_croak(aTHX_ "panic: no strftime");
4189 #define SV_CWD_RETURN_UNDEF \
4190 sv_setsv(sv, &PL_sv_undef); \
4193 #define SV_CWD_ISDOT(dp) \
4194 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4195 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4198 =head1 Miscellaneous Functions
4200 =for apidoc getcwd_sv
4202 Fill the sv with current working directory
4207 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4208 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4209 * getcwd(3) if available
4210 * Comments from the orignal:
4211 * This is a faster version of getcwd. It's also more dangerous
4212 * because you might chdir out of a directory that you can't chdir
4216 Perl_getcwd_sv(pTHX_ register SV *sv)
4220 #ifndef INCOMPLETE_TAINTS
4224 PERL_ARGS_ASSERT_GETCWD_SV;
4228 char buf[MAXPATHLEN];
4230 /* Some getcwd()s automatically allocate a buffer of the given
4231 * size from the heap if they are given a NULL buffer pointer.
4232 * The problem is that this behaviour is not portable. */
4233 if (getcwd(buf, sizeof(buf) - 1)) {
4238 sv_setsv(sv, &PL_sv_undef);
4246 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4250 SvUPGRADE(sv, SVt_PV);
4252 if (PerlLIO_lstat(".", &statbuf) < 0) {
4253 SV_CWD_RETURN_UNDEF;
4256 orig_cdev = statbuf.st_dev;
4257 orig_cino = statbuf.st_ino;
4267 if (PerlDir_chdir("..") < 0) {
4268 SV_CWD_RETURN_UNDEF;
4270 if (PerlLIO_stat(".", &statbuf) < 0) {
4271 SV_CWD_RETURN_UNDEF;
4274 cdev = statbuf.st_dev;
4275 cino = statbuf.st_ino;
4277 if (odev == cdev && oino == cino) {
4280 if (!(dir = PerlDir_open("."))) {
4281 SV_CWD_RETURN_UNDEF;
4284 while ((dp = PerlDir_read(dir)) != NULL) {
4286 namelen = dp->d_namlen;
4288 namelen = strlen(dp->d_name);
4291 if (SV_CWD_ISDOT(dp)) {
4295 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4296 SV_CWD_RETURN_UNDEF;
4299 tdev = statbuf.st_dev;
4300 tino = statbuf.st_ino;
4301 if (tino == oino && tdev == odev) {
4307 SV_CWD_RETURN_UNDEF;
4310 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4311 SV_CWD_RETURN_UNDEF;
4314 SvGROW(sv, pathlen + namelen + 1);
4318 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4321 /* prepend current directory to the front */
4323 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4324 pathlen += (namelen + 1);
4326 #ifdef VOID_CLOSEDIR
4329 if (PerlDir_close(dir) < 0) {
4330 SV_CWD_RETURN_UNDEF;
4336 SvCUR_set(sv, pathlen);
4340 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4341 SV_CWD_RETURN_UNDEF;
4344 if (PerlLIO_stat(".", &statbuf) < 0) {
4345 SV_CWD_RETURN_UNDEF;
4348 cdev = statbuf.st_dev;
4349 cino = statbuf.st_ino;
4351 if (cdev != orig_cdev || cino != orig_cino) {
4352 Perl_croak(aTHX_ "Unstable directory path, "
4353 "current directory changed unexpectedly");
4364 #define VERSION_MAX 0x7FFFFFFF
4367 =for apidoc prescan_version
4369 Validate that a given string can be parsed as a version object, but doesn't
4370 actually perform the parsing. Can use either strict or lax validation rules.
4371 Can optionally set a number of hint variables to save the parsing code
4372 some time when tokenizing.
4377 Perl_prescan_version(pTHX_ const char *s, bool strict,
4378 const char **errstr,
4379 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4380 bool qv = (sqv ? *sqv : FALSE);
4382 int saw_decimal = 0;
4386 PERL_ARGS_ASSERT_PRESCAN_VERSION;
4388 if (qv && isDIGIT(*d))
4389 goto dotted_decimal_version;
4391 if (*d == 'v') { /* explicit v-string */
4396 else { /* degenerate v-string */
4397 /* requires v1.2.3 */
4398 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4401 dotted_decimal_version:
4402 if (strict && d[0] == '0' && isDIGIT(d[1])) {
4403 /* no leading zeros allowed */
4404 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4407 while (isDIGIT(*d)) /* integer part */
4413 d++; /* decimal point */
4418 /* require v1.2.3 */
4419 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4422 goto version_prescan_finish;
4429 while (isDIGIT(*d)) { /* just keep reading */
4431 while (isDIGIT(*d)) {
4433 /* maximum 3 digits between decimal */
4434 if (strict && j > 3) {
4435 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4440 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4443 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4448 else if (*d == '.') {
4450 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4455 else if (!isDIGIT(*d)) {
4461 if (strict && i < 2) {
4462 /* requires v1.2.3 */
4463 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4466 } /* end if dotted-decimal */
4468 { /* decimal versions */
4469 /* special strict case for leading '.' or '0' */
4472 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4474 if (*d == '0' && isDIGIT(d[1])) {
4475 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4479 /* consume all of the integer part */
4483 /* look for a fractional part */
4485 /* we found it, so consume it */
4489 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4492 BADVERSION(s,errstr,"Invalid version format (version required)");
4494 /* found just an integer */
4495 goto version_prescan_finish;
4497 else if ( d == s ) {
4498 /* didn't find either integer or period */
4499 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4501 else if (*d == '_') {
4502 /* underscore can't come after integer part */
4504 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4506 else if (isDIGIT(d[1])) {
4507 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4510 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4514 /* anything else after integer part is just invalid data */
4515 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4518 /* scan the fractional part after the decimal point*/
4520 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4521 /* strict or lax-but-not-the-end */
4522 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4525 while (isDIGIT(*d)) {
4527 if (*d == '.' && isDIGIT(d[-1])) {
4529 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4532 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4534 d = (char *)s; /* start all over again */
4536 goto dotted_decimal_version;
4540 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4543 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4545 if ( ! isDIGIT(d[1]) ) {
4546 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4554 version_prescan_finish:
4558 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4559 /* trailing non-numeric data */
4560 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4568 *ssaw_decimal = saw_decimal;
4575 =for apidoc scan_version
4577 Returns a pointer to the next character after the parsed
4578 version string, as well as upgrading the passed in SV to
4581 Function must be called with an already existing SV like
4584 s = scan_version(s, SV *sv, bool qv);
4586 Performs some preprocessing to the string to ensure that
4587 it has the correct characteristics of a version. Flags the
4588 object if it contains an underscore (which denotes this
4589 is an alpha version). The boolean qv denotes that the version
4590 should be interpreted as if it had multiple decimals, even if
4597 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4602 const char *errstr = NULL;
4603 int saw_decimal = 0;
4607 AV * const av = newAV();
4608 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4610 PERL_ARGS_ASSERT_SCAN_VERSION;
4612 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4614 #ifndef NODEFAULT_SHAREKEYS
4615 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4618 while (isSPACE(*s)) /* leading whitespace is OK */
4621 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4623 /* "undef" is a special case and not an error */
4624 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4625 Perl_croak(aTHX_ "%s", errstr);
4635 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4637 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4638 if ( !qv && width < 3 )
4639 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4641 while (isDIGIT(*pos))
4643 if (!isALPHA(*pos)) {
4649 /* this is atoi() that delimits on underscores */
4650 const char *end = pos;
4654 /* the following if() will only be true after the decimal
4655 * point of a version originally created with a bare
4656 * floating point number, i.e. not quoted in any way
4658 if ( !qv && s > start && saw_decimal == 1 ) {
4662 rev += (*s - '0') * mult;
4664 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4665 || (PERL_ABS(rev) > VERSION_MAX )) {
4666 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4667 "Integer overflow in version %d",VERSION_MAX);
4678 while (--end >= s) {
4680 rev += (*end - '0') * mult;
4682 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4683 || (PERL_ABS(rev) > VERSION_MAX )) {
4684 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4685 "Integer overflow in version");
4694 /* Append revision */
4695 av_push(av, newSViv(rev));
4700 else if ( *pos == '.' )
4702 else if ( *pos == '_' && isDIGIT(pos[1]) )
4704 else if ( *pos == ',' && isDIGIT(pos[1]) )
4706 else if ( isDIGIT(*pos) )
4713 while ( isDIGIT(*pos) )
4718 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4726 if ( qv ) { /* quoted versions always get at least three terms*/
4727 I32 len = av_len(av);
4728 /* This for loop appears to trigger a compiler bug on OS X, as it
4729 loops infinitely. Yes, len is negative. No, it makes no sense.
4730 Compiler in question is:
4731 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4732 for ( len = 2 - len; len > 0; len-- )
4733 av_push(MUTABLE_AV(sv), newSViv(0));
4737 av_push(av, newSViv(0));
4740 /* need to save off the current version string for later */
4742 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4743 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4744 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4746 else if ( s > start ) {
4747 SV * orig = newSVpvn(start,s-start);
4748 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4749 /* need to insert a v to be consistent */
4750 sv_insert(orig, 0, 0, "v", 1);
4752 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4755 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4756 av_push(av, newSViv(0));
4759 /* And finally, store the AV in the hash */
4760 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4762 /* fix RT#19517 - special case 'undef' as string */
4763 if ( *s == 'u' && strEQ(s,"undef") ) {
4771 =for apidoc new_version
4773 Returns a new version object based on the passed in SV:
4775 SV *sv = new_version(SV *ver);
4777 Does not alter the passed in ver SV. See "upg_version" if you
4778 want to upgrade the SV.
4784 Perl_new_version(pTHX_ SV *ver)
4787 SV * const rv = newSV(0);
4788 PERL_ARGS_ASSERT_NEW_VERSION;
4789 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4792 AV * const av = newAV();
4794 /* This will get reblessed later if a derived class*/
4795 SV * const hv = newSVrv(rv, "version");
4796 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4797 #ifndef NODEFAULT_SHAREKEYS
4798 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4804 /* Begin copying all of the elements */
4805 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4806 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4808 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4809 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4811 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4813 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4814 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4817 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4819 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4820 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4823 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4824 /* This will get reblessed later if a derived class*/
4825 for ( key = 0; key <= av_len(sav); key++ )
4827 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4828 av_push(av, newSViv(rev));
4831 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4836 const MAGIC* const mg = SvVSTRING_mg(ver);
4837 if ( mg ) { /* already a v-string */
4838 const STRLEN len = mg->mg_len;
4839 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4840 sv_setpvn(rv,version,len);
4841 /* this is for consistency with the pure Perl class */
4842 if ( isDIGIT(*version) )
4843 sv_insert(rv, 0, 0, "v", 1);
4848 sv_setsv(rv,ver); /* make a duplicate */
4853 return upg_version(rv, FALSE);
4857 =for apidoc upg_version
4859 In-place upgrade of the supplied SV to a version object.
4861 SV *sv = upg_version(SV *sv, bool qv);
4863 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4864 to force this SV to be interpreted as an "extended" version.
4870 Perl_upg_version(pTHX_ SV *ver, bool qv)
4872 const char *version, *s;
4877 PERL_ARGS_ASSERT_UPG_VERSION;
4879 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4881 /* may get too much accuracy */
4883 #ifdef USE_LOCALE_NUMERIC
4884 char *loc = setlocale(LC_NUMERIC, "C");
4886 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4887 #ifdef USE_LOCALE_NUMERIC
4888 setlocale(LC_NUMERIC, loc);
4890 while (tbuf[len-1] == '0' && len > 0) len--;
4891 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4892 version = savepvn(tbuf, len);
4895 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4896 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4900 else /* must be a string or something like a string */
4903 version = savepv(SvPV(ver,len));
4905 # if PERL_VERSION > 5
4906 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4907 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4908 /* may be a v-string */
4909 char *testv = (char *)version;
4911 for (tlen=0; tlen < len; tlen++, testv++) {
4912 /* if one of the characters is non-text assume v-string */
4913 if (testv[0] < ' ') {
4914 SV * const nsv = sv_newmortal();
4917 int saw_decimal = 0;
4918 sv_setpvf(nsv,"v%vd",ver);
4919 pos = nver = savepv(SvPV_nolen(nsv));
4921 /* scan the resulting formatted string */
4922 pos++; /* skip the leading 'v' */
4923 while ( *pos == '.' || isDIGIT(*pos) ) {
4929 /* is definitely a v-string */
4930 if ( saw_decimal >= 2 ) {
4942 s = scan_version(version, ver, qv);
4944 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4945 "Version string '%s' contains invalid data; "
4946 "ignoring: '%s'", version, s);
4954 Validates that the SV contains valid internal structure for a version object.
4955 It may be passed either the version object (RV) or the hash itself (HV). If
4956 the structure is valid, it returns the HV. If the structure is invalid,
4959 SV *hv = vverify(sv);
4961 Note that it only confirms the bare minimum structure (so as not to get
4962 confused by derived classes which may contain additional hash entries):
4966 =item * The SV is an HV or a reference to an HV
4968 =item * The hash contains a "version" key
4970 =item * The "version" key has a reference to an AV as its value
4978 Perl_vverify(pTHX_ SV *vs)
4982 PERL_ARGS_ASSERT_VVERIFY;
4987 /* see if the appropriate elements exist */
4988 if ( SvTYPE(vs) == SVt_PVHV
4989 && hv_exists(MUTABLE_HV(vs), "version", 7)
4990 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4991 && SvTYPE(sv) == SVt_PVAV )
5000 Accepts a version object and returns the normalized floating
5001 point representation. Call like:
5005 NOTE: you can pass either the object directly or the SV
5006 contained within the RV.
5008 The SV returned has a refcount of 1.
5014 Perl_vnumify(pTHX_ SV *vs)
5022 PERL_ARGS_ASSERT_VNUMIFY;
5024 /* extract the HV from the object */
5027 Perl_croak(aTHX_ "Invalid version object");
5029 /* see if various flags exist */
5030 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5032 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5033 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5038 /* attempt to retrieve the version array */
5039 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5040 return newSVpvs("0");
5046 return newSVpvs("0");
5049 digit = SvIV(*av_fetch(av, 0, 0));
5050 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5051 for ( i = 1 ; i < len ; i++ )
5053 digit = SvIV(*av_fetch(av, i, 0));
5055 const int denom = (width == 2 ? 10 : 100);
5056 const div_t term = div((int)PERL_ABS(digit),denom);
5057 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5060 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5066 digit = SvIV(*av_fetch(av, len, 0));
5067 if ( alpha && width == 3 ) /* alpha version */
5069 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5073 sv_catpvs(sv, "000");
5081 Accepts a version object and returns the normalized string
5082 representation. Call like:
5086 NOTE: you can pass either the object directly or the SV
5087 contained within the RV.
5089 The SV returned has a refcount of 1.
5095 Perl_vnormal(pTHX_ SV *vs)
5102 PERL_ARGS_ASSERT_VNORMAL;
5104 /* extract the HV from the object */
5107 Perl_croak(aTHX_ "Invalid version object");
5109 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5111 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5116 return newSVpvs("");
5118 digit = SvIV(*av_fetch(av, 0, 0));
5119 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5120 for ( i = 1 ; i < len ; i++ ) {
5121 digit = SvIV(*av_fetch(av, i, 0));
5122 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5127 /* handle last digit specially */
5128 digit = SvIV(*av_fetch(av, len, 0));
5130 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5132 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5135 if ( len <= 2 ) { /* short version, must be at least three */
5136 for ( len = 2 - len; len != 0; len-- )
5143 =for apidoc vstringify
5145 In order to maintain maximum compatibility with earlier versions
5146 of Perl, this function will return either the floating point
5147 notation or the multiple dotted notation, depending on whether
5148 the original version contained 1 or more dots, respectively.
5150 The SV returned has a refcount of 1.
5156 Perl_vstringify(pTHX_ SV *vs)
5158 PERL_ARGS_ASSERT_VSTRINGIFY;
5160 /* extract the HV from the object */
5163 Perl_croak(aTHX_ "Invalid version object");
5165 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
5167 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5171 return &PL_sv_undef;
5174 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5184 Version object aware cmp. Both operands must already have been
5185 converted into version objects.
5191 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5194 bool lalpha = FALSE;
5195 bool ralpha = FALSE;
5200 PERL_ARGS_ASSERT_VCMP;
5202 /* extract the HVs from the objects */
5205 if ( ! ( lhv && rhv ) )
5206 Perl_croak(aTHX_ "Invalid version object");
5208 /* get the left hand term */
5209 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5210 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5213 /* and the right hand term */
5214 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5215 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5223 while ( i <= m && retval == 0 )
5225 left = SvIV(*av_fetch(lav,i,0));
5226 right = SvIV(*av_fetch(rav,i,0));
5234 /* tiebreaker for alpha with identical terms */
5235 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5237 if ( lalpha && !ralpha )
5241 else if ( ralpha && !lalpha)
5247 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5251 while ( i <= r && retval == 0 )
5253 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5254 retval = -1; /* not a match after all */
5260 while ( i <= l && retval == 0 )
5262 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5263 retval = +1; /* not a match after all */
5271 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5272 # define EMULATE_SOCKETPAIR_UDP
5275 #ifdef EMULATE_SOCKETPAIR_UDP
5277 S_socketpair_udp (int fd[2]) {
5279 /* Fake a datagram socketpair using UDP to localhost. */
5280 int sockets[2] = {-1, -1};
5281 struct sockaddr_in addresses[2];
5283 Sock_size_t size = sizeof(struct sockaddr_in);
5284 unsigned short port;
5287 memset(&addresses, 0, sizeof(addresses));
5290 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5291 if (sockets[i] == -1)
5292 goto tidy_up_and_fail;
5294 addresses[i].sin_family = AF_INET;
5295 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5296 addresses[i].sin_port = 0; /* kernel choses port. */
5297 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5298 sizeof(struct sockaddr_in)) == -1)
5299 goto tidy_up_and_fail;
5302 /* Now have 2 UDP sockets. Find out which port each is connected to, and
5303 for each connect the other socket to it. */
5306 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5308 goto tidy_up_and_fail;
5309 if (size != sizeof(struct sockaddr_in))
5310 goto abort_tidy_up_and_fail;
5311 /* !1 is 0, !0 is 1 */
5312 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5313 sizeof(struct sockaddr_in)) == -1)
5314 goto tidy_up_and_fail;
5317 /* Now we have 2 sockets connected to each other. I don't trust some other
5318 process not to have already sent a packet to us (by random) so send
5319 a packet from each to the other. */
5322 /* I'm going to send my own port number. As a short.
5323 (Who knows if someone somewhere has sin_port as a bitfield and needs
5324 this routine. (I'm assuming crays have socketpair)) */
5325 port = addresses[i].sin_port;
5326 got = PerlLIO_write(sockets[i], &port, sizeof(port));
5327 if (got != sizeof(port)) {
5329 goto tidy_up_and_fail;
5330 goto abort_tidy_up_and_fail;
5334 /* Packets sent. I don't trust them to have arrived though.
5335 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5336 connect to localhost will use a second kernel thread. In 2.6 the
5337 first thread running the connect() returns before the second completes,
5338 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5339 returns 0. Poor programs have tripped up. One poor program's authors'
5340 had a 50-1 reverse stock split. Not sure how connected these were.)
5341 So I don't trust someone not to have an unpredictable UDP stack.
5345 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5346 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5350 FD_SET((unsigned int)sockets[0], &rset);
5351 FD_SET((unsigned int)sockets[1], &rset);
5353 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5354 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5355 || !FD_ISSET(sockets[1], &rset)) {
5356 /* I hope this is portable and appropriate. */
5358 goto tidy_up_and_fail;
5359 goto abort_tidy_up_and_fail;
5363 /* And the paranoia department even now doesn't trust it to have arrive
5364 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5366 struct sockaddr_in readfrom;
5367 unsigned short buffer[2];
5372 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5373 sizeof(buffer), MSG_DONTWAIT,
5374 (struct sockaddr *) &readfrom, &size);
5376 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5378 (struct sockaddr *) &readfrom, &size);
5382 goto tidy_up_and_fail;
5383 if (got != sizeof(port)
5384 || size != sizeof(struct sockaddr_in)
5385 /* Check other socket sent us its port. */
5386 || buffer[0] != (unsigned short) addresses[!i].sin_port
5387 /* Check kernel says we got the datagram from that socket */
5388 || readfrom.sin_family != addresses[!i].sin_family
5389 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5390 || readfrom.sin_port != addresses[!i].sin_port)
5391 goto abort_tidy_up_and_fail;
5394 /* My caller (my_socketpair) has validated that this is non-NULL */
5397 /* I hereby declare this connection open. May God bless all who cross
5401 abort_tidy_up_and_fail:
5402 errno = ECONNABORTED;
5406 if (sockets[0] != -1)
5407 PerlLIO_close(sockets[0]);
5408 if (sockets[1] != -1)
5409 PerlLIO_close(sockets[1]);
5414 #endif /* EMULATE_SOCKETPAIR_UDP */
5416 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5418 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5419 /* Stevens says that family must be AF_LOCAL, protocol 0.
5420 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5425 struct sockaddr_in listen_addr;
5426 struct sockaddr_in connect_addr;
5431 || family != AF_UNIX
5434 errno = EAFNOSUPPORT;
5442 #ifdef EMULATE_SOCKETPAIR_UDP
5443 if (type == SOCK_DGRAM)
5444 return S_socketpair_udp(fd);
5447 listener = PerlSock_socket(AF_INET, type, 0);
5450 memset(&listen_addr, 0, sizeof(listen_addr));
5451 listen_addr.sin_family = AF_INET;
5452 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5453 listen_addr.sin_port = 0; /* kernel choses port. */
5454 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5455 sizeof(listen_addr)) == -1)
5456 goto tidy_up_and_fail;
5457 if (PerlSock_listen(listener, 1) == -1)
5458 goto tidy_up_and_fail;
5460 connector = PerlSock_socket(AF_INET, type, 0);
5461 if (connector == -1)
5462 goto tidy_up_and_fail;
5463 /* We want to find out the port number to connect to. */
5464 size = sizeof(connect_addr);
5465 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5467 goto tidy_up_and_fail;
5468 if (size != sizeof(connect_addr))
5469 goto abort_tidy_up_and_fail;
5470 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5471 sizeof(connect_addr)) == -1)
5472 goto tidy_up_and_fail;
5474 size = sizeof(listen_addr);
5475 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5478 goto tidy_up_and_fail;
5479 if (size != sizeof(listen_addr))
5480 goto abort_tidy_up_and_fail;
5481 PerlLIO_close(listener);
5482 /* Now check we are talking to ourself by matching port and host on the
5484 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5486 goto tidy_up_and_fail;
5487 if (size != sizeof(connect_addr)
5488 || listen_addr.sin_family != connect_addr.sin_family
5489 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5490 || listen_addr.sin_port != connect_addr.sin_port) {
5491 goto abort_tidy_up_and_fail;
5497 abort_tidy_up_and_fail:
5499 errno = ECONNABORTED; /* This would be the standard thing to do. */
5501 # ifdef ECONNREFUSED
5502 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5504 errno = ETIMEDOUT; /* Desperation time. */
5511 PerlLIO_close(listener);
5512 if (connector != -1)
5513 PerlLIO_close(connector);
5515 PerlLIO_close(acceptor);
5521 /* In any case have a stub so that there's code corresponding
5522 * to the my_socketpair in global.sym. */
5524 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5525 #ifdef HAS_SOCKETPAIR
5526 return socketpair(family, type, protocol, fd);
5535 =for apidoc sv_nosharing
5537 Dummy routine which "shares" an SV when there is no sharing module present.
5538 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5539 Exists to avoid test for a NULL function pointer and because it could
5540 potentially warn under some level of strict-ness.
5546 Perl_sv_nosharing(pTHX_ SV *sv)
5548 PERL_UNUSED_CONTEXT;
5549 PERL_UNUSED_ARG(sv);
5554 =for apidoc sv_destroyable
5556 Dummy routine which reports that object can be destroyed when there is no
5557 sharing module present. It ignores its single SV argument, and returns
5558 'true'. Exists to avoid test for a NULL function pointer and because it
5559 could potentially warn under some level of strict-ness.
5565 Perl_sv_destroyable(pTHX_ SV *sv)
5567 PERL_UNUSED_CONTEXT;
5568 PERL_UNUSED_ARG(sv);
5573 Perl_parse_unicode_opts(pTHX_ const char **popt)
5575 const char *p = *popt;
5578 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5582 opt = (U32) atoi(p);
5585 if (*p && *p != '\n' && *p != '\r') {
5586 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5588 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5594 case PERL_UNICODE_STDIN:
5595 opt |= PERL_UNICODE_STDIN_FLAG; break;
5596 case PERL_UNICODE_STDOUT:
5597 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5598 case PERL_UNICODE_STDERR:
5599 opt |= PERL_UNICODE_STDERR_FLAG; break;
5600 case PERL_UNICODE_STD:
5601 opt |= PERL_UNICODE_STD_FLAG; break;
5602 case PERL_UNICODE_IN:
5603 opt |= PERL_UNICODE_IN_FLAG; break;
5604 case PERL_UNICODE_OUT:
5605 opt |= PERL_UNICODE_OUT_FLAG; break;
5606 case PERL_UNICODE_INOUT:
5607 opt |= PERL_UNICODE_INOUT_FLAG; break;
5608 case PERL_UNICODE_LOCALE:
5609 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5610 case PERL_UNICODE_ARGV:
5611 opt |= PERL_UNICODE_ARGV_FLAG; break;
5612 case PERL_UNICODE_UTF8CACHEASSERT:
5613 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5615 if (*p != '\n' && *p != '\r') {
5616 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5619 "Unknown Unicode option letter '%c'", *p);
5626 opt = PERL_UNICODE_DEFAULT_FLAGS;
5628 the_end_of_the_opts_parser:
5630 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5631 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5632 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5644 * This is really just a quick hack which grabs various garbage
5645 * values. It really should be a real hash algorithm which
5646 * spreads the effect of every input bit onto every output bit,
5647 * if someone who knows about such things would bother to write it.
5648 * Might be a good idea to add that function to CORE as well.
5649 * No numbers below come from careful analysis or anything here,
5650 * except they are primes and SEED_C1 > 1E6 to get a full-width
5651 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5652 * probably be bigger too.
5655 # define SEED_C1 1000003
5656 #define SEED_C4 73819
5658 # define SEED_C1 25747
5659 #define SEED_C4 20639
5663 #define SEED_C5 26107
5665 #ifndef PERL_NO_DEV_RANDOM
5670 # include <starlet.h>
5671 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5672 * in 100-ns units, typically incremented ever 10 ms. */
5673 unsigned int when[2];
5675 # ifdef HAS_GETTIMEOFDAY
5676 struct timeval when;
5682 /* This test is an escape hatch, this symbol isn't set by Configure. */
5683 #ifndef PERL_NO_DEV_RANDOM
5684 #ifndef PERL_RANDOM_DEVICE
5685 /* /dev/random isn't used by default because reads from it will block
5686 * if there isn't enough entropy available. You can compile with
5687 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5688 * is enough real entropy to fill the seed. */
5689 # define PERL_RANDOM_DEVICE "/dev/urandom"
5691 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5693 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5702 _ckvmssts(sys$gettim(when));
5703 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5705 # ifdef HAS_GETTIMEOFDAY
5706 PerlProc_gettimeofday(&when,NULL);
5707 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5710 u = (U32)SEED_C1 * when;
5713 u += SEED_C3 * (U32)PerlProc_getpid();
5714 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5715 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5716 u += SEED_C5 * (U32)PTR2UV(&when);
5722 Perl_get_hash_seed(pTHX)
5725 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5731 if (s && isDIGIT(*s))
5732 myseed = (UV)Atoul(s);
5734 #ifdef USE_HASH_SEED_EXPLICIT
5738 /* Compute a random seed */
5739 (void)seedDrand01((Rand_seed_t)seed());
5740 myseed = (UV)(Drand01() * (NV)UV_MAX);
5741 #if RANDBITS < (UVSIZE * 8)
5742 /* Since there are not enough randbits to to reach all
5743 * the bits of a UV, the low bits might need extra
5744 * help. Sum in another random number that will
5745 * fill in the low bits. */
5747 (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5748 #endif /* RANDBITS < (UVSIZE * 8) */
5749 if (myseed == 0) { /* Superparanoia. */
5750 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5752 Perl_croak(aTHX_ "Your random numbers are not that random");
5755 PL_rehash_seed_set = TRUE;
5762 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5764 const char * const stashpv = CopSTASHPV(c);
5765 const char * const name = HvNAME_get(hv);
5766 PERL_UNUSED_CONTEXT;
5767 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5769 if (stashpv == name)
5771 if (stashpv && name)
5772 if (strEQ(stashpv, name))
5779 #ifdef PERL_GLOBAL_STRUCT
5781 #define PERL_GLOBAL_STRUCT_INIT
5782 #include "opcode.h" /* the ppaddr and check */
5785 Perl_init_global_struct(pTHX)
5787 struct perl_vars *plvarsp = NULL;
5788 # ifdef PERL_GLOBAL_STRUCT
5789 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5790 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5791 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5792 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5793 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5797 plvarsp = PL_VarsPtr;
5798 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5803 # define PERLVAR(var,type) /**/
5804 # define PERLVARA(var,n,type) /**/
5805 # define PERLVARI(var,type,init) plvarsp->var = init;
5806 # define PERLVARIC(var,type,init) plvarsp->var = init;
5807 # include "perlvars.h"
5812 # ifdef PERL_GLOBAL_STRUCT
5815 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5816 if (!plvarsp->Gppaddr)
5820 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5821 if (!plvarsp->Gcheck)
5823 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5824 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5826 # ifdef PERL_SET_VARS
5827 PERL_SET_VARS(plvarsp);
5829 # undef PERL_GLOBAL_STRUCT_INIT
5834 #endif /* PERL_GLOBAL_STRUCT */
5836 #ifdef PERL_GLOBAL_STRUCT
5839 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5841 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5842 # ifdef PERL_GLOBAL_STRUCT
5843 # ifdef PERL_UNSET_VARS
5844 PERL_UNSET_VARS(plvarsp);
5846 free(plvarsp->Gppaddr);
5847 free(plvarsp->Gcheck);
5848 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5854 #endif /* PERL_GLOBAL_STRUCT */
5858 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5859 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5860 * given, and you supply your own implementation.
5862 * The default implementation reads a single env var, PERL_MEM_LOG,
5863 * expecting one or more of the following:
5865 * \d+ - fd fd to write to : must be 1st (atoi)
5866 * 'm' - memlog was PERL_MEM_LOG=1
5867 * 's' - svlog was PERL_SV_LOG=1
5868 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5870 * This makes the logger controllable enough that it can reasonably be
5871 * added to the system perl.
5874 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5875 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5877 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5879 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5880 * writes to. In the default logger, this is settable at runtime.
5882 #ifndef PERL_MEM_LOG_FD
5883 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5886 #ifndef PERL_MEM_LOG_NOIMPL
5888 # ifdef DEBUG_LEAKING_SCALARS
5889 # define SV_LOG_SERIAL_FMT " [%lu]"
5890 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5892 # define SV_LOG_SERIAL_FMT
5893 # define _SV_LOG_SERIAL_ARG(sv)
5897 S_mem_log_common(enum mem_log_type mlt, const UV n,
5898 const UV typesize, const char *type_name, const SV *sv,
5899 Malloc_t oldalloc, Malloc_t newalloc,
5900 const char *filename, const int linenumber,
5901 const char *funcname)
5905 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5907 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5910 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5912 /* We can't use SVs or PerlIO for obvious reasons,
5913 * so we'll use stdio and low-level IO instead. */
5914 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5916 # ifdef HAS_GETTIMEOFDAY
5917 # define MEM_LOG_TIME_FMT "%10d.%06d: "
5918 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5920 gettimeofday(&tv, 0);
5922 # define MEM_LOG_TIME_FMT "%10d: "
5923 # define MEM_LOG_TIME_ARG (int)when
5927 /* If there are other OS specific ways of hires time than
5928 * gettimeofday() (see ext/Time-HiRes), the easiest way is
5929 * probably that they would be used to fill in the struct
5933 int fd = atoi(pmlenv);
5935 fd = PERL_MEM_LOG_FD;
5937 if (strchr(pmlenv, 't')) {
5938 len = my_snprintf(buf, sizeof(buf),
5939 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5940 PerlLIO_write(fd, buf, len);
5944 len = my_snprintf(buf, sizeof(buf),
5945 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5946 " %s = %"IVdf": %"UVxf"\n",
5947 filename, linenumber, funcname, n, typesize,
5948 type_name, n * typesize, PTR2UV(newalloc));
5951 len = my_snprintf(buf, sizeof(buf),
5952 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5953 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5954 filename, linenumber, funcname, n, typesize,
5955 type_name, n * typesize, PTR2UV(oldalloc),
5959 len = my_snprintf(buf, sizeof(buf),
5960 "free: %s:%d:%s: %"UVxf"\n",
5961 filename, linenumber, funcname,
5966 len = my_snprintf(buf, sizeof(buf),
5967 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5968 mlt == MLT_NEW_SV ? "new" : "del",
5969 filename, linenumber, funcname,
5970 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5975 PerlLIO_write(fd, buf, len);
5979 #endif /* !PERL_MEM_LOG_NOIMPL */
5981 #ifndef PERL_MEM_LOG_NOIMPL
5983 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5984 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5986 /* this is suboptimal, but bug compatible. User is providing their
5987 own implementation, but is getting these functions anyway, and they
5988 do nothing. But _NOIMPL users should be able to cope or fix */
5990 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5991 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5995 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5997 const char *filename, const int linenumber,
5998 const char *funcname)
6000 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6001 NULL, NULL, newalloc,
6002 filename, linenumber, funcname);
6007 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6008 Malloc_t oldalloc, Malloc_t newalloc,
6009 const char *filename, const int linenumber,
6010 const char *funcname)
6012 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6013 NULL, oldalloc, newalloc,
6014 filename, linenumber, funcname);
6019 Perl_mem_log_free(Malloc_t oldalloc,
6020 const char *filename, const int linenumber,
6021 const char *funcname)
6023 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6024 filename, linenumber, funcname);
6029 Perl_mem_log_new_sv(const SV *sv,
6030 const char *filename, const int linenumber,
6031 const char *funcname)
6033 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6034 filename, linenumber, funcname);
6038 Perl_mem_log_del_sv(const SV *sv,
6039 const char *filename, const int linenumber,
6040 const char *funcname)
6042 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6043 filename, linenumber, funcname);
6046 #endif /* PERL_MEM_LOG */
6049 =for apidoc my_sprintf
6051 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6052 the length of the string written to the buffer. Only rare pre-ANSI systems
6053 need the wrapper function - usually this is a direct call to C<sprintf>.
6057 #ifndef SPRINTF_RETURNS_STRLEN
6059 Perl_my_sprintf(char *buffer, const char* pat, ...)
6062 PERL_ARGS_ASSERT_MY_SPRINTF;
6063 va_start(args, pat);
6064 vsprintf(buffer, pat, args);
6066 return strlen(buffer);
6071 =for apidoc my_snprintf
6073 The C library C<snprintf> functionality, if available and
6074 standards-compliant (uses C<vsnprintf>, actually). However, if the
6075 C<vsnprintf> is not available, will unfortunately use the unsafe
6076 C<vsprintf> which can overrun the buffer (there is an overrun check,
6077 but that may be too late). Consider using C<sv_vcatpvf> instead, or
6078 getting C<vsnprintf>.
6083 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6088 PERL_ARGS_ASSERT_MY_SNPRINTF;
6089 va_start(ap, format);
6090 #ifdef HAS_VSNPRINTF
6091 retval = vsnprintf(buffer, len, format, ap);
6093 retval = vsprintf(buffer, format, ap);
6096 /* vsprintf() shows failure with < 0 */
6098 #ifdef HAS_VSNPRINTF
6099 /* vsnprintf() shows failure with >= len */
6101 (len > 0 && (Size_t)retval >= len)
6104 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6109 =for apidoc my_vsnprintf
6111 The C library C<vsnprintf> if available and standards-compliant.
6112 However, if if the C<vsnprintf> is not available, will unfortunately
6113 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6114 overrun check, but that may be too late). Consider using
6115 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6120 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6127 PERL_ARGS_ASSERT_MY_VSNPRINTF;
6129 Perl_va_copy(ap, apc);
6130 # ifdef HAS_VSNPRINTF
6131 retval = vsnprintf(buffer, len, format, apc);
6133 retval = vsprintf(buffer, format, apc);
6136 # ifdef HAS_VSNPRINTF
6137 retval = vsnprintf(buffer, len, format, ap);
6139 retval = vsprintf(buffer, format, ap);
6141 #endif /* #ifdef NEED_VA_COPY */
6142 /* vsprintf() shows failure with < 0 */
6144 #ifdef HAS_VSNPRINTF
6145 /* vsnprintf() shows failure with >= len */
6147 (len > 0 && (Size_t)retval >= len)
6150 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6155 Perl_my_clearenv(pTHX)
6158 #if ! defined(PERL_MICRO)
6159 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6161 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6162 # if defined(USE_ENVIRON_ARRAY)
6163 # if defined(USE_ITHREADS)
6164 /* only the parent thread can clobber the process environment */
6165 if (PL_curinterp == aTHX)
6166 # endif /* USE_ITHREADS */
6168 # if ! defined(PERL_USE_SAFE_PUTENV)
6169 if ( !PL_use_safe_putenv) {
6171 if (environ == PL_origenviron)
6172 environ = (char**)safesysmalloc(sizeof(char*));
6174 for (i = 0; environ[i]; i++)
6175 (void)safesysfree(environ[i]);
6178 # else /* PERL_USE_SAFE_PUTENV */
6179 # if defined(HAS_CLEARENV)
6181 # elif defined(HAS_UNSETENV)
6182 int bsiz = 80; /* Most envvar names will be shorter than this. */
6183 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6184 char *buf = (char*)safesysmalloc(bufsiz);
6185 while (*environ != NULL) {
6186 char *e = strchr(*environ, '=');
6187 int l = e ? e - *environ : (int)strlen(*environ);
6189 (void)safesysfree(buf);
6190 bsiz = l + 1; /* + 1 for the \0. */
6191 buf = (char*)safesysmalloc(bufsiz);
6193 memcpy(buf, *environ, l);
6195 (void)unsetenv(buf);
6197 (void)safesysfree(buf);
6198 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6199 /* Just null environ and accept the leakage. */
6201 # endif /* HAS_CLEARENV || HAS_UNSETENV */
6202 # endif /* ! PERL_USE_SAFE_PUTENV */
6204 # endif /* USE_ENVIRON_ARRAY */
6205 # endif /* PERL_IMPLICIT_SYS || WIN32 */
6206 #endif /* PERL_MICRO */
6209 #ifdef PERL_IMPLICIT_CONTEXT
6211 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6212 the global PL_my_cxt_index is incremented, and that value is assigned to
6213 that module's static my_cxt_index (who's address is passed as an arg).
6214 Then, for each interpreter this function is called for, it makes sure a
6215 void* slot is available to hang the static data off, by allocating or
6216 extending the interpreter's PL_my_cxt_list array */
6218 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6220 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6224 PERL_ARGS_ASSERT_MY_CXT_INIT;
6226 /* this module hasn't been allocated an index yet */
6227 #if defined(USE_ITHREADS)
6228 MUTEX_LOCK(&PL_my_ctx_mutex);
6230 *index = PL_my_cxt_index++;
6231 #if defined(USE_ITHREADS)
6232 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6236 /* make sure the array is big enough */
6237 if (PL_my_cxt_size <= *index) {
6238 if (PL_my_cxt_size) {
6239 while (PL_my_cxt_size <= *index)
6240 PL_my_cxt_size *= 2;
6241 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6244 PL_my_cxt_size = 16;
6245 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6248 /* newSV() allocates one more than needed */
6249 p = (void*)SvPVX(newSV(size-1));
6250 PL_my_cxt_list[*index] = p;
6251 Zero(p, size, char);
6255 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6258 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6263 PERL_ARGS_ASSERT_MY_CXT_INDEX;
6265 for (index = 0; index < PL_my_cxt_index; index++) {
6266 const char *key = PL_my_cxt_keys[index];
6267 /* try direct pointer compare first - there are chances to success,
6268 * and it's much faster.
6270 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6277 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6283 PERL_ARGS_ASSERT_MY_CXT_INIT;
6285 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6287 /* this module hasn't been allocated an index yet */
6288 #if defined(USE_ITHREADS)
6289 MUTEX_LOCK(&PL_my_ctx_mutex);
6291 index = PL_my_cxt_index++;
6292 #if defined(USE_ITHREADS)
6293 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6297 /* make sure the array is big enough */
6298 if (PL_my_cxt_size <= index) {
6299 int old_size = PL_my_cxt_size;
6301 if (PL_my_cxt_size) {
6302 while (PL_my_cxt_size <= index)
6303 PL_my_cxt_size *= 2;
6304 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6305 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6308 PL_my_cxt_size = 16;
6309 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6310 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6312 for (i = old_size; i < PL_my_cxt_size; i++) {
6313 PL_my_cxt_keys[i] = 0;
6314 PL_my_cxt_list[i] = 0;
6317 PL_my_cxt_keys[index] = my_cxt_key;
6318 /* newSV() allocates one more than needed */
6319 p = (void*)SvPVX(newSV(size-1));
6320 PL_my_cxt_list[index] = p;
6321 Zero(p, size, char);
6324 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6325 #endif /* PERL_IMPLICIT_CONTEXT */
6328 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
6332 const char *vn = NULL;
6333 SV *const module = PL_stack_base[ax];
6335 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
6337 if (items >= 2) /* version supplied as bootstrap arg */
6338 sv = PL_stack_base[ax + 1];
6340 /* XXX GV_ADDWARN */
6342 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6343 if (!sv || !SvOK(sv)) {
6345 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6349 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
6350 SV *pmsv = sv_derived_from(sv, "version")
6351 ? sv : sv_2mortal(new_version(sv));
6352 xssv = upg_version(xssv, 0);
6353 if ( vcmp(pmsv,xssv) ) {
6354 SV *string = vstringify(xssv);
6355 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
6356 " does not match ", module, string);
6358 SvREFCNT_dec(string);
6359 string = vstringify(pmsv);
6362 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
6365 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6367 SvREFCNT_dec(string);
6369 Perl_sv_2mortal(aTHX_ xpt);
6370 Perl_croak_sv(aTHX_ xpt);
6376 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6380 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6383 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6385 /* This might croak */
6386 compver = upg_version(compver, 0);
6387 /* This should never croak */
6388 runver = new_version(PL_apiversion);
6389 if (vcmp(compver, runver)) {
6390 SV *compver_string = vstringify(compver);
6391 SV *runver_string = vstringify(runver);
6392 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6393 " of %"SVf" does not match %"SVf,
6394 compver_string, module, runver_string);
6395 Perl_sv_2mortal(aTHX_ xpt);
6397 SvREFCNT_dec(compver_string);
6398 SvREFCNT_dec(runver_string);
6400 SvREFCNT_dec(runver);
6402 Perl_croak_sv(aTHX_ xpt);
6407 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6409 Size_t used, length, copy;
6412 length = strlen(src);
6413 if (size > 0 && used < size - 1) {
6414 copy = (length >= size - used) ? size - used - 1 : length;
6415 memcpy(dst + used, src, copy);
6416 dst[used + copy] = '\0';
6418 return used + length;
6424 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6426 Size_t length, copy;
6428 length = strlen(src);
6430 copy = (length >= size) ? size - 1 : length;
6431 memcpy(dst, src, copy);
6438 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6439 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6440 long _ftol( double ); /* Defined by VC6 C libs. */
6441 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6445 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6448 SV * const dbsv = GvSVn(PL_DBsub);
6449 const bool save_taint = PL_tainted;
6451 /* We do not care about using sv to call CV;
6452 * it's for informational purposes only.
6455 PERL_ARGS_ASSERT_GET_DB_SUB;
6459 if (!PERLDB_SUB_NN) {
6462 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6463 || strEQ(GvNAME(gv), "END")
6464 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6465 !( (SvTYPE(*svp) == SVt_PVGV)
6466 && (GvCV((const GV *)*svp) == cv)
6467 && (gv = (GV *)*svp)
6471 /* Use GV from the stack as a fallback. */
6472 /* GV is potentially non-unique, or contain different CV. */
6473 SV * const tmp = newRV(MUTABLE_SV(cv));
6474 sv_setsv(dbsv, tmp);
6478 gv_efullname3(dbsv, gv, NULL);
6482 const int type = SvTYPE(dbsv);
6483 if (type < SVt_PVIV && type != SVt_IV)
6484 sv_upgrade(dbsv, SVt_PVIV);
6485 (void)SvIOK_on(dbsv);
6486 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6488 TAINT_IF(save_taint);
6492 Perl_my_dirfd(pTHX_ DIR * dir) {
6494 /* Most dirfd implementations have problems when passed NULL. */
6499 #elif defined(HAS_DIR_DD_FD)
6502 Perl_die(aTHX_ PL_no_func, "dirfd");
6509 Perl_get_re_arg(pTHX_ SV *sv) {
6515 sv = MUTABLE_SV(SvRV(sv));
6516 if (SvTYPE(sv) == SVt_REGEXP)
6517 return (REGEXP*) sv;
6525 * c-indentation-style: bsd
6527 * indent-tabs-mode: t
6530 * ex: set ts=8 sts=4 sw=4 noet: