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 */
46 # include <sys/select.h>
52 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
53 # define FD_CLOEXEC 1 /* NeXT needs this */
56 /* NOTE: Do not call the next three routines directly. Use the macros
57 * in handy.h, so that we can easily redefine everything to do tracking of
58 * allocated hunks back to the original New to track down any memory leaks.
59 * XXX This advice seems to be widely ignored :-( --AD August 1996.
66 /* Can't use PerlIO to write as it allocates memory */
67 PerlLIO_write(PerlIO_fileno(Perl_error_log),
68 PL_no_mem, strlen(PL_no_mem));
70 NORETURN_FUNCTION_END;
73 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
74 # define ALWAYS_NEED_THX
77 /* paranoid version of system's malloc() */
80 Perl_safesysmalloc(MEM_SIZE size)
82 #ifdef ALWAYS_NEED_THX
88 PerlIO_printf(Perl_error_log,
89 "Allocation too large: %lx\n", size) FLUSH;
92 #endif /* HAS_64K_LIMIT */
93 #ifdef PERL_TRACK_MEMPOOL
97 if ((SSize_t)size < 0)
98 Perl_croak_nocontext("panic: malloc");
100 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
101 PERL_ALLOC_CHECK(ptr);
103 #ifdef PERL_TRACK_MEMPOOL
104 struct perl_memory_debug_header *const header
105 = (struct perl_memory_debug_header *)ptr;
109 PoisonNew(((char *)ptr), size, char);
112 #ifdef PERL_TRACK_MEMPOOL
113 header->interpreter = aTHX;
114 /* Link us into the list. */
115 header->prev = &PL_memory_debug_header;
116 header->next = PL_memory_debug_header.next;
117 PL_memory_debug_header.next = header;
118 header->next->prev = header;
122 ptr = (Malloc_t)((char*)ptr+sTHX);
124 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
128 #ifndef ALWAYS_NEED_THX
134 return write_no_mem();
140 /* paranoid version of system's realloc() */
143 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
145 #ifdef ALWAYS_NEED_THX
149 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
150 Malloc_t PerlMem_realloc();
151 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
155 PerlIO_printf(Perl_error_log,
156 "Reallocation too large: %lx\n", size) FLUSH;
159 #endif /* HAS_64K_LIMIT */
166 return safesysmalloc(size);
167 #ifdef PERL_TRACK_MEMPOOL
168 where = (Malloc_t)((char*)where-sTHX);
171 struct perl_memory_debug_header *const header
172 = (struct perl_memory_debug_header *)where;
174 if (header->interpreter != aTHX) {
175 Perl_croak_nocontext("panic: realloc from wrong pool");
177 assert(header->next->prev == header);
178 assert(header->prev->next == header);
180 if (header->size > size) {
181 const MEM_SIZE freed_up = header->size - size;
182 char *start_of_freed = ((char *)where) + size;
183 PoisonFree(start_of_freed, freed_up, char);
190 if ((SSize_t)size < 0)
191 Perl_croak_nocontext("panic: realloc");
193 ptr = (Malloc_t)PerlMem_realloc(where,size);
194 PERL_ALLOC_CHECK(ptr);
196 /* MUST do this fixup first, before doing ANYTHING else, as anything else
197 might allocate memory/free/move memory, and until we do the fixup, it
198 may well be chasing (and writing to) free memory. */
199 #ifdef PERL_TRACK_MEMPOOL
201 struct perl_memory_debug_header *const header
202 = (struct perl_memory_debug_header *)ptr;
205 if (header->size < size) {
206 const MEM_SIZE fresh = size - header->size;
207 char *start_of_fresh = ((char *)ptr) + size;
208 PoisonNew(start_of_fresh, fresh, char);
212 header->next->prev = header;
213 header->prev->next = header;
215 ptr = (Malloc_t)((char*)ptr+sTHX);
219 /* In particular, must do that fixup above before logging anything via
220 *printf(), as it can reallocate memory, which can cause SEGVs. */
222 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
223 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
230 #ifndef ALWAYS_NEED_THX
236 return write_no_mem();
242 /* safe version of system's free() */
245 Perl_safesysfree(Malloc_t where)
247 #ifdef ALWAYS_NEED_THX
252 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
254 #ifdef PERL_TRACK_MEMPOOL
255 where = (Malloc_t)((char*)where-sTHX);
257 struct perl_memory_debug_header *const header
258 = (struct perl_memory_debug_header *)where;
260 if (header->interpreter != aTHX) {
261 Perl_croak_nocontext("panic: free from wrong pool");
264 Perl_croak_nocontext("panic: duplicate free");
266 if (!(header->next) || header->next->prev != header
267 || header->prev->next != header) {
268 Perl_croak_nocontext("panic: bad free");
270 /* Unlink us from the chain. */
271 header->next->prev = header->prev;
272 header->prev->next = header->next;
274 PoisonNew(where, header->size, char);
276 /* Trigger the duplicate free warning. */
284 /* safe version of system's calloc() */
287 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
289 #ifdef ALWAYS_NEED_THX
293 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
294 MEM_SIZE total_size = 0;
297 /* Even though calloc() for zero bytes is strange, be robust. */
298 if (size && (count <= MEM_SIZE_MAX / size)) {
299 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
300 total_size = size * count;
304 Perl_croak_nocontext("%s", PL_memory_wrap);
305 #ifdef PERL_TRACK_MEMPOOL
306 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
309 Perl_croak_nocontext("%s", PL_memory_wrap);
312 if (total_size > 0xffff) {
313 PerlIO_printf(Perl_error_log,
314 "Allocation too large: %lx\n", total_size) FLUSH;
317 #endif /* HAS_64K_LIMIT */
319 if ((SSize_t)size < 0 || (SSize_t)count < 0)
320 Perl_croak_nocontext("panic: calloc");
322 #ifdef PERL_TRACK_MEMPOOL
323 /* Have to use malloc() because we've added some space for our tracking
325 /* malloc(0) is non-portable. */
326 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
328 /* Use calloc() because it might save a memset() if the memory is fresh
329 and clean from the OS. */
331 ptr = (Malloc_t)PerlMem_calloc(count, size);
332 else /* calloc(0) is non-portable. */
333 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
335 PERL_ALLOC_CHECK(ptr);
336 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));
338 #ifdef PERL_TRACK_MEMPOOL
340 struct perl_memory_debug_header *const header
341 = (struct perl_memory_debug_header *)ptr;
343 memset((void*)ptr, 0, total_size);
344 header->interpreter = aTHX;
345 /* Link us into the list. */
346 header->prev = &PL_memory_debug_header;
347 header->next = PL_memory_debug_header.next;
348 PL_memory_debug_header.next = header;
349 header->next->prev = header;
351 header->size = total_size;
353 ptr = (Malloc_t)((char*)ptr+sTHX);
359 #ifndef ALWAYS_NEED_THX
364 return write_no_mem();
368 /* These must be defined when not using Perl's malloc for binary
373 Malloc_t Perl_malloc (MEM_SIZE nbytes)
376 return (Malloc_t)PerlMem_malloc(nbytes);
379 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
382 return (Malloc_t)PerlMem_calloc(elements, size);
385 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
388 return (Malloc_t)PerlMem_realloc(where, nbytes);
391 Free_t Perl_mfree (Malloc_t where)
399 /* copy a string up to some (non-backslashed) delimiter, if any */
402 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
406 PERL_ARGS_ASSERT_DELIMCPY;
408 for (tolen = 0; from < fromend; from++, tolen++) {
410 if (from[1] != delim) {
417 else if (*from == delim)
428 /* return ptr to little string in big string, NULL if not found */
429 /* This routine was donated by Corey Satten. */
432 Perl_instr(register const char *big, register const char *little)
436 PERL_ARGS_ASSERT_INSTR;
444 register const char *s, *x;
447 for (x=big,s=little; *s; /**/ ) {
458 return (char*)(big-1);
463 /* same as instr but allow embedded nulls */
466 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
468 PERL_ARGS_ASSERT_NINSTR;
472 const char first = *little;
474 bigend -= lend - little++;
476 while (big <= bigend) {
477 if (*big++ == first) {
478 for (x=big,s=little; s < lend; x++,s++) {
482 return (char*)(big-1);
489 /* reverse of the above--find last substring */
492 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
494 register const char *bigbeg;
495 register const I32 first = *little;
496 register const char * const littleend = lend;
498 PERL_ARGS_ASSERT_RNINSTR;
500 if (little >= littleend)
501 return (char*)bigend;
503 big = bigend - (littleend - little++);
504 while (big >= bigbeg) {
505 register const char *s, *x;
508 for (x=big+2,s=little; s < littleend; /**/ ) {
517 return (char*)(big+1);
522 /* As a space optimization, we do not compile tables for strings of length
523 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
524 special-cased in fbm_instr().
526 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
529 =head1 Miscellaneous Functions
531 =for apidoc fbm_compile
533 Analyses the string in order to make fast searches on it using fbm_instr()
534 -- the Boyer-Moore algorithm.
540 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
543 register const U8 *s;
550 PERL_ARGS_ASSERT_FBM_COMPILE;
552 /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in
553 SV flag usage. No real-world code would ever end up using a studied
554 scalar as a compile-time second argument to index, so this isn't a real
562 if (flags & FBMcf_TAIL) {
563 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
564 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
565 if (mg && mg->mg_len >= 0)
568 s = (U8*)SvPV_force_mutable(sv, len);
569 if (len == 0) /* TAIL might be on a zero-length string. */
571 SvUPGRADE(sv, SVt_PVMG);
576 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
577 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
578 to call SvVALID_off() if the scalar was assigned to.
580 The comment itself (and "deeper magic" below) date back to
581 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
583 where the magic (presumably) was that the scalar had a BM table hidden
586 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
587 the table instead of the previous (somewhat hacky) approach of co-opting
588 the string buffer and storing it after the string. */
590 assert(!mg_find(sv, PERL_MAGIC_bm));
591 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
595 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
597 const U8 mlen = (len>255) ? 255 : (U8)len;
598 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
601 Newx(table, 256, U8);
602 memset((void*)table, mlen, 256);
603 mg->mg_ptr = (char *)table;
606 s += len - 1; /* last char */
609 if (table[*s] == mlen)
615 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
616 for (i = 0; i < len; i++) {
617 if (PL_freq[s[i]] < frequency) {
619 frequency = PL_freq[s[i]];
622 BmRARE(sv) = s[rarest];
623 BmPREVIOUS(sv) = rarest;
624 BmUSEFUL(sv) = 100; /* Initial value */
625 if (flags & FBMcf_TAIL)
627 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
628 BmRARE(sv), BmPREVIOUS(sv)));
631 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
632 /* If SvTAIL is actually due to \Z or \z, this gives false positives
636 =for apidoc fbm_instr
638 Returns the location of the SV in the string delimited by C<str> and
639 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
640 does not have to be fbm_compiled, but the search will not be as fast
647 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
649 register unsigned char *s;
651 register const unsigned char *little
652 = (const unsigned char *)SvPV_const(littlestr,l);
653 register STRLEN littlelen = l;
654 register const I32 multiline = flags & FBMrf_MULTILINE;
656 PERL_ARGS_ASSERT_FBM_INSTR;
658 if ((STRLEN)(bigend - big) < littlelen) {
659 if ( SvTAIL(littlestr)
660 && ((STRLEN)(bigend - big) == littlelen - 1)
662 || (*big == *little &&
663 memEQ((char *)big, (char *)little, littlelen - 1))))
668 switch (littlelen) { /* Special cases for 0, 1 and 2 */
670 return (char*)big; /* Cannot be SvTAIL! */
672 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
673 /* Know that bigend != big. */
674 if (bigend[-1] == '\n')
675 return (char *)(bigend - 1);
676 return (char *) bigend;
684 if (SvTAIL(littlestr))
685 return (char *) bigend;
688 if (SvTAIL(littlestr) && !multiline) {
689 if (bigend[-1] == '\n' && bigend[-2] == *little)
690 return (char*)bigend - 2;
691 if (bigend[-1] == *little)
692 return (char*)bigend - 1;
696 /* This should be better than FBM if c1 == c2, and almost
697 as good otherwise: maybe better since we do less indirection.
698 And we save a lot of memory by caching no table. */
699 const unsigned char c1 = little[0];
700 const unsigned char c2 = little[1];
705 while (s <= bigend) {
715 goto check_1char_anchor;
726 goto check_1char_anchor;
729 while (s <= bigend) {
734 goto check_1char_anchor;
743 check_1char_anchor: /* One char and anchor! */
744 if (SvTAIL(littlestr) && (*bigend == *little))
745 return (char *)bigend; /* bigend is already decremented. */
748 break; /* Only lengths 0 1 and 2 have special-case code. */
751 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
752 s = bigend - littlelen;
753 if (s >= big && bigend[-1] == '\n' && *s == *little
754 /* Automatically of length > 2 */
755 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
757 return (char*)s; /* how sweet it is */
760 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
762 return (char*)s + 1; /* how sweet it is */
766 if (!SvVALID(littlestr)) {
767 char * const b = ninstr((char*)big,(char*)bigend,
768 (char*)little, (char*)little + littlelen);
770 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
771 /* Chop \n from littlestr: */
772 s = bigend - littlelen + 1;
774 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
784 if (littlelen > (STRLEN)(bigend - big))
788 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
789 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
790 register const unsigned char *oldlittle;
792 --littlelen; /* Last char found by table lookup */
795 little += littlelen; /* last char */
801 if ((tmp = table[*s])) {
802 if ((s += tmp) < bigend)
806 else { /* less expensive than calling strncmp() */
807 register unsigned char * const olds = s;
812 if (*--s == *--little)
814 s = olds + 1; /* here we pay the price for failure */
816 if (s < bigend) /* fake up continue to outer loop */
826 && memEQ((char *)(bigend - littlelen),
827 (char *)(oldlittle - littlelen), littlelen) )
828 return (char*)bigend - littlelen;
833 /* start_shift, end_shift are positive quantities which give offsets
834 of ends of some substring of bigstr.
835 If "last" we want the last occurrence.
836 old_posp is the way of communication between consequent calls if
837 the next call needs to find the .
838 The initial *old_posp should be -1.
840 Note that we take into account SvTAIL, so one can get extra
841 optimizations if _ALL flag is set.
844 /* If SvTAIL is actually due to \Z or \z, this gives false positives
845 if PL_multiline. In fact if !PL_multiline the authoritative answer
846 is not supported yet. */
849 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
852 register const unsigned char *big;
853 U32 pos = 0; /* hush a gcc warning */
854 register I32 previous;
856 register const unsigned char *little;
857 register I32 stop_pos;
858 register const unsigned char *littleend;
861 const void *screamnext_raw = NULL; /* hush a gcc warning */
862 bool cant_find = FALSE; /* hush a gcc warning */
864 PERL_ARGS_ASSERT_SCREAMINSTR;
866 assert(SvMAGICAL(bigstr));
867 mg = mg_find(bigstr, PERL_MAGIC_study);
869 assert(SvTYPE(littlestr) == SVt_PVMG);
870 assert(SvVALID(littlestr));
872 if (mg->mg_private == 1) {
873 const U8 *const screamfirst = (U8 *)mg->mg_ptr;
874 const U8 *const screamnext = screamfirst + 256;
876 screamnext_raw = (const void *)screamnext;
878 pos = *old_posp == -1
879 ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
880 cant_find = pos == (U8)~0;
881 } else if (mg->mg_private == 2) {
882 const U16 *const screamfirst = (U16 *)mg->mg_ptr;
883 const U16 *const screamnext = screamfirst + 256;
885 screamnext_raw = (const void *)screamnext;
887 pos = *old_posp == -1
888 ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
889 cant_find = pos == (U16)~0;
890 } else if (mg->mg_private == 4) {
891 const U32 *const screamfirst = (U32 *)mg->mg_ptr;
892 const U32 *const screamnext = screamfirst + 256;
894 screamnext_raw = (const void *)screamnext;
896 pos = *old_posp == -1
897 ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
898 cant_find = pos == (U32)~0;
900 Perl_croak(aTHX_ "panic: unknown study size %u", mg->mg_private);
904 if ( BmRARE(littlestr) == '\n'
905 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
906 little = (const unsigned char *)(SvPVX_const(littlestr));
907 littleend = little + SvCUR(littlestr);
914 little = (const unsigned char *)(SvPVX_const(littlestr));
915 littleend = little + SvCUR(littlestr);
917 /* The value of pos we can start at: */
918 previous = BmPREVIOUS(littlestr);
919 big = (const unsigned char *)(SvPVX_const(bigstr));
920 /* The value of pos we can stop at: */
921 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
922 if (previous + start_shift > stop_pos) {
924 stop_pos does not include SvTAIL in the count, so this check is incorrect
925 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
928 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
933 if (mg->mg_private == 1) {
934 const U8 *const screamnext = (const U8 *const) screamnext_raw;
935 while ((I32)pos < previous + start_shift) {
936 pos = screamnext[pos];
940 } else if (mg->mg_private == 2) {
941 const U16 *const screamnext = (const U16 *const) screamnext_raw;
942 while ((I32)pos < previous + start_shift) {
943 pos = screamnext[pos];
947 } else if (mg->mg_private == 4) {
948 const U32 *const screamnext = (const U32 *const) screamnext_raw;
949 while ((I32)pos < previous + start_shift) {
950 pos = screamnext[pos];
957 if ((I32)pos >= stop_pos) break;
958 if (big[pos] == first) {
959 const unsigned char *s = little;
960 const unsigned char *x = big + pos + 1;
961 while (s < littleend) {
966 if (s == littleend) {
967 *old_posp = (I32)pos;
968 if (!last) return (char *)(big+pos);
972 if (mg->mg_private == 1) {
973 pos = ((const U8 *const)screamnext_raw)[pos];
976 } else if (mg->mg_private == 2) {
977 pos = ((const U16 *const)screamnext_raw)[pos];
980 } else if (mg->mg_private == 4) {
981 pos = ((const U32 *const)screamnext_raw)[pos];
987 return (char *)(big+(*old_posp));
989 if (!SvTAIL(littlestr) || (end_shift > 0))
991 /* Ignore the trailing "\n". This code is not microoptimized */
992 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
993 stop_pos = littleend - little; /* Actual littlestr len */
998 && ((stop_pos == 1) ||
999 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
1007 Returns true if the leading len bytes of the strings s1 and s2 are the same
1008 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1009 match themselves and their opposite case counterparts. Non-cased and non-ASCII
1010 range bytes match only themselves.
1017 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
1019 register const U8 *a = (const U8 *)s1;
1020 register const U8 *b = (const U8 *)s2;
1022 PERL_ARGS_ASSERT_FOLDEQ;
1025 if (*a != *b && *a != PL_fold[*b])
1032 Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
1034 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1035 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1036 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1037 * does it check that the strings each have at least 'len' characters */
1039 register const U8 *a = (const U8 *)s1;
1040 register const U8 *b = (const U8 *)s2;
1042 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1045 if (*a != *b && *a != PL_fold_latin1[*b]) {
1054 =for apidoc foldEQ_locale
1056 Returns true if the leading len bytes of the strings s1 and s2 are the same
1057 case-insensitively in the current locale; false otherwise.
1063 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
1066 register const U8 *a = (const U8 *)s1;
1067 register const U8 *b = (const U8 *)s2;
1069 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1072 if (*a != *b && *a != PL_fold_locale[*b])
1079 /* copy a string to a safe spot */
1082 =head1 Memory Management
1086 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1087 string which is a duplicate of C<pv>. The size of the string is
1088 determined by C<strlen()>. The memory allocated for the new string can
1089 be freed with the C<Safefree()> function.
1095 Perl_savepv(pTHX_ const char *pv)
1097 PERL_UNUSED_CONTEXT;
1102 const STRLEN pvlen = strlen(pv)+1;
1103 Newx(newaddr, pvlen, char);
1104 return (char*)memcpy(newaddr, pv, pvlen);
1108 /* same thing but with a known length */
1113 Perl's version of what C<strndup()> would be if it existed. Returns a
1114 pointer to a newly allocated string which is a duplicate of the first
1115 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
1116 the new string can be freed with the C<Safefree()> function.
1122 Perl_savepvn(pTHX_ const char *pv, register I32 len)
1124 register char *newaddr;
1125 PERL_UNUSED_CONTEXT;
1127 Newx(newaddr,len+1,char);
1128 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1130 /* might not be null terminated */
1131 newaddr[len] = '\0';
1132 return (char *) CopyD(pv,newaddr,len,char);
1135 return (char *) ZeroD(newaddr,len+1,char);
1140 =for apidoc savesharedpv
1142 A version of C<savepv()> which allocates the duplicate string in memory
1143 which is shared between threads.
1148 Perl_savesharedpv(pTHX_ const char *pv)
1150 register char *newaddr;
1155 pvlen = strlen(pv)+1;
1156 newaddr = (char*)PerlMemShared_malloc(pvlen);
1158 return write_no_mem();
1160 return (char*)memcpy(newaddr, pv, pvlen);
1164 =for apidoc savesharedpvn
1166 A version of C<savepvn()> which allocates the duplicate string in memory
1167 which is shared between threads. (With the specific difference that a NULL
1168 pointer is not acceptable)
1173 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1175 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1177 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1180 return write_no_mem();
1182 newaddr[len] = '\0';
1183 return (char*)memcpy(newaddr, pv, len);
1187 =for apidoc savesvpv
1189 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1190 the passed in SV using C<SvPV()>
1196 Perl_savesvpv(pTHX_ SV *sv)
1199 const char * const pv = SvPV_const(sv, len);
1200 register char *newaddr;
1202 PERL_ARGS_ASSERT_SAVESVPV;
1205 Newx(newaddr,len,char);
1206 return (char *) CopyD(pv,newaddr,len,char);
1210 =for apidoc savesharedsvpv
1212 A version of C<savesharedpv()> which allocates the duplicate string in
1213 memory which is shared between threads.
1219 Perl_savesharedsvpv(pTHX_ SV *sv)
1222 const char * const pv = SvPV_const(sv, len);
1224 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1226 return savesharedpvn(pv, len);
1229 /* the SV for Perl_form() and mess() is not kept in an arena */
1238 if (PL_phase != PERL_PHASE_DESTRUCT)
1239 return newSVpvs_flags("", SVs_TEMP);
1244 /* Create as PVMG now, to avoid any upgrading later */
1246 Newxz(any, 1, XPVMG);
1247 SvFLAGS(sv) = SVt_PVMG;
1248 SvANY(sv) = (void*)any;
1250 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1255 #if defined(PERL_IMPLICIT_CONTEXT)
1257 Perl_form_nocontext(const char* pat, ...)
1262 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1263 va_start(args, pat);
1264 retval = vform(pat, &args);
1268 #endif /* PERL_IMPLICIT_CONTEXT */
1271 =head1 Miscellaneous Functions
1274 Takes a sprintf-style format pattern and conventional
1275 (non-SV) arguments and returns the formatted string.
1277 (char *) Perl_form(pTHX_ const char* pat, ...)
1279 can be used any place a string (char *) is required:
1281 char * s = Perl_form("%d.%d",major,minor);
1283 Uses a single private buffer so if you want to format several strings you
1284 must explicitly copy the earlier strings away (and free the copies when you
1291 Perl_form(pTHX_ const char* pat, ...)
1295 PERL_ARGS_ASSERT_FORM;
1296 va_start(args, pat);
1297 retval = vform(pat, &args);
1303 Perl_vform(pTHX_ const char *pat, va_list *args)
1305 SV * const sv = mess_alloc();
1306 PERL_ARGS_ASSERT_VFORM;
1307 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1312 =for apidoc Am|SV *|mess|const char *pat|...
1314 Take a sprintf-style format pattern and argument list. These are used to
1315 generate a string message. If the message does not end with a newline,
1316 then it will be extended with some indication of the current location
1317 in the code, as described for L</mess_sv>.
1319 Normally, the resulting message is returned in a new mortal SV.
1320 During global destruction a single SV may be shared between uses of
1326 #if defined(PERL_IMPLICIT_CONTEXT)
1328 Perl_mess_nocontext(const char *pat, ...)
1333 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1334 va_start(args, pat);
1335 retval = vmess(pat, &args);
1339 #endif /* PERL_IMPLICIT_CONTEXT */
1342 Perl_mess(pTHX_ const char *pat, ...)
1346 PERL_ARGS_ASSERT_MESS;
1347 va_start(args, pat);
1348 retval = vmess(pat, &args);
1354 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1357 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1359 PERL_ARGS_ASSERT_CLOSEST_COP;
1361 if (!o || o == PL_op)
1364 if (o->op_flags & OPf_KIDS) {
1366 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1369 /* If the OP_NEXTSTATE has been optimised away we can still use it
1370 * the get the file and line number. */
1372 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1373 cop = (const COP *)kid;
1375 /* Keep searching, and return when we've found something. */
1377 new_cop = closest_cop(cop, kid);
1383 /* Nothing found. */
1389 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1391 Expands a message, intended for the user, to include an indication of
1392 the current location in the code, if the message does not already appear
1395 C<basemsg> is the initial message or object. If it is a reference, it
1396 will be used as-is and will be the result of this function. Otherwise it
1397 is used as a string, and if it already ends with a newline, it is taken
1398 to be complete, and the result of this function will be the same string.
1399 If the message does not end with a newline, then a segment such as C<at
1400 foo.pl line 37> will be appended, and possibly other clauses indicating
1401 the current state of execution. The resulting message will end with a
1404 Normally, the resulting message is returned in a new mortal SV.
1405 During global destruction a single SV may be shared between uses of this
1406 function. If C<consume> is true, then the function is permitted (but not
1407 required) to modify and return C<basemsg> instead of allocating a new SV.
1413 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1418 PERL_ARGS_ASSERT_MESS_SV;
1420 if (SvROK(basemsg)) {
1426 sv_setsv(sv, basemsg);
1431 if (SvPOK(basemsg) && consume) {
1436 sv_copypv(sv, basemsg);
1439 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1441 * Try and find the file and line for PL_op. This will usually be
1442 * PL_curcop, but it might be a cop that has been optimised away. We
1443 * can try to find such a cop by searching through the optree starting
1444 * from the sibling of PL_curcop.
1447 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1452 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1453 OutCopFILE(cop), (IV)CopLINE(cop));
1454 /* Seems that GvIO() can be untrustworthy during global destruction. */
1455 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1456 && IoLINES(GvIOp(PL_last_in_gv)))
1458 const bool line_mode = (RsSIMPLE(PL_rs) &&
1459 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1460 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1461 SVfARG(PL_last_in_gv == PL_argvgv
1463 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1464 line_mode ? "line" : "chunk",
1465 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1467 if (PL_phase == PERL_PHASE_DESTRUCT)
1468 sv_catpvs(sv, " during global destruction");
1469 sv_catpvs(sv, ".\n");
1475 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1477 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1478 argument list. These are used to generate a string message. If the
1479 message does not end with a newline, then it will be extended with
1480 some indication of the current location in the code, as described for
1483 Normally, the resulting message is returned in a new mortal SV.
1484 During global destruction a single SV may be shared between uses of
1491 Perl_vmess(pTHX_ const char *pat, va_list *args)
1494 SV * const sv = mess_alloc();
1496 PERL_ARGS_ASSERT_VMESS;
1498 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1499 return mess_sv(sv, 1);
1503 Perl_write_to_stderr(pTHX_ SV* msv)
1509 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1511 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1512 && (io = GvIO(PL_stderrgv))
1513 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1514 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
1515 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1518 /* SFIO can really mess with your errno */
1521 PerlIO * const serr = Perl_error_log;
1523 do_print(msv, serr);
1524 (void)PerlIO_flush(serr);
1532 =head1 Warning and Dieing
1535 /* Common code used in dieing and warning */
1538 S_with_queued_errors(pTHX_ SV *ex)
1540 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1541 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1542 sv_catsv(PL_errors, ex);
1543 ex = sv_mortalcopy(PL_errors);
1544 SvCUR_set(PL_errors, 0);
1550 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1556 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1557 /* sv_2cv might call Perl_croak() or Perl_warner() */
1558 SV * const oldhook = *hook;
1566 cv = sv_2cv(oldhook, &stash, &gv, 0);
1568 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1578 exarg = newSVsv(ex);
1579 SvREADONLY_on(exarg);
1582 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1586 call_sv(MUTABLE_SV(cv), G_DISCARD);
1595 =for apidoc Am|OP *|die_sv|SV *baseex
1597 Behaves the same as L</croak_sv>, except for the return type.
1598 It should be used only where the C<OP *> return type is required.
1599 The function never actually returns.
1605 Perl_die_sv(pTHX_ SV *baseex)
1607 PERL_ARGS_ASSERT_DIE_SV;
1614 =for apidoc Am|OP *|die|const char *pat|...
1616 Behaves the same as L</croak>, except for the return type.
1617 It should be used only where the C<OP *> return type is required.
1618 The function never actually returns.
1623 #if defined(PERL_IMPLICIT_CONTEXT)
1625 Perl_die_nocontext(const char* pat, ...)
1629 va_start(args, pat);
1635 #endif /* PERL_IMPLICIT_CONTEXT */
1638 Perl_die(pTHX_ const char* pat, ...)
1641 va_start(args, pat);
1649 =for apidoc Am|void|croak_sv|SV *baseex
1651 This is an XS interface to Perl's C<die> function.
1653 C<baseex> is the error message or object. If it is a reference, it
1654 will be used as-is. Otherwise it is used as a string, and if it does
1655 not end with a newline then it will be extended with some indication of
1656 the current location in the code, as described for L</mess_sv>.
1658 The error message or object 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_sv>
1661 function never returns normally.
1663 To die with a simple string message, the L</croak> function may be
1670 Perl_croak_sv(pTHX_ SV *baseex)
1672 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1673 PERL_ARGS_ASSERT_CROAK_SV;
1674 invoke_exception_hook(ex, FALSE);
1679 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1681 This is an XS interface to Perl's C<die> function.
1683 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1684 argument list. These are used to generate a string message. If the
1685 message does not end with a newline, then it will be extended with
1686 some indication of the current location in the code, as described for
1689 The error message will be used as an exception, by default
1690 returning control to the nearest enclosing C<eval>, but subject to
1691 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1692 function never returns normally.
1694 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1695 (C<$@>) will be used as an error message or object instead of building an
1696 error message from arguments. If you want to throw a non-string object,
1697 or build an error message in an SV yourself, it is preferable to use
1698 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1704 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1706 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1707 invoke_exception_hook(ex, FALSE);
1712 =for apidoc Am|void|croak|const char *pat|...
1714 This is an XS interface to Perl's C<die> function.
1716 Take a sprintf-style format pattern and argument list. These are used to
1717 generate a string message. If the message does not end with a newline,
1718 then it will be extended with some indication of the current location
1719 in the code, as described for L</mess_sv>.
1721 The error message will be used as an exception, by default
1722 returning control to the nearest enclosing C<eval>, but subject to
1723 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1724 function never returns normally.
1726 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1727 (C<$@>) will be used as an error message or object instead of building an
1728 error message from arguments. If you want to throw a non-string object,
1729 or build an error message in an SV yourself, it is preferable to use
1730 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1735 #if defined(PERL_IMPLICIT_CONTEXT)
1737 Perl_croak_nocontext(const char *pat, ...)
1741 va_start(args, pat);
1746 #endif /* PERL_IMPLICIT_CONTEXT */
1749 Perl_croak(pTHX_ const char *pat, ...)
1752 va_start(args, pat);
1759 =for apidoc Am|void|croak_no_modify
1761 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1762 terser object code than using C<Perl_croak>. Less code used on exception code
1763 paths reduces CPU cache pressure.
1769 Perl_croak_no_modify(pTHX)
1771 Perl_croak(aTHX_ "%s", PL_no_modify);
1775 =for apidoc Am|void|warn_sv|SV *baseex
1777 This is an XS interface to Perl's C<warn> function.
1779 C<baseex> is the error message or object. If it is a reference, it
1780 will be used as-is. Otherwise it is used as a string, and if it does
1781 not end with a newline then it will be extended with some indication of
1782 the current location in the code, as described for L</mess_sv>.
1784 The error message or object will by default be written to standard error,
1785 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1787 To warn with a simple string message, the L</warn> function may be
1794 Perl_warn_sv(pTHX_ SV *baseex)
1796 SV *ex = mess_sv(baseex, 0);
1797 PERL_ARGS_ASSERT_WARN_SV;
1798 if (!invoke_exception_hook(ex, TRUE))
1799 write_to_stderr(ex);
1803 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1805 This is an XS interface to Perl's C<warn> function.
1807 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1808 argument list. These are used to generate a string message. If the
1809 message does not end with a newline, then it will be extended with
1810 some indication of the current location in the code, as described for
1813 The error message or object will by default be written to standard error,
1814 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1816 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1822 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1824 SV *ex = vmess(pat, args);
1825 PERL_ARGS_ASSERT_VWARN;
1826 if (!invoke_exception_hook(ex, TRUE))
1827 write_to_stderr(ex);
1831 =for apidoc Am|void|warn|const char *pat|...
1833 This is an XS interface to Perl's C<warn> function.
1835 Take a sprintf-style format pattern and argument list. These are used to
1836 generate a string message. If the message does not end with a newline,
1837 then it will be extended with some indication of the current location
1838 in the code, as described for L</mess_sv>.
1840 The error message or object will by default be written to standard error,
1841 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1843 Unlike with L</croak>, C<pat> is not permitted to be null.
1848 #if defined(PERL_IMPLICIT_CONTEXT)
1850 Perl_warn_nocontext(const char *pat, ...)
1854 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1855 va_start(args, pat);
1859 #endif /* PERL_IMPLICIT_CONTEXT */
1862 Perl_warn(pTHX_ const char *pat, ...)
1865 PERL_ARGS_ASSERT_WARN;
1866 va_start(args, pat);
1871 #if defined(PERL_IMPLICIT_CONTEXT)
1873 Perl_warner_nocontext(U32 err, const char *pat, ...)
1877 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1878 va_start(args, pat);
1879 vwarner(err, pat, &args);
1882 #endif /* PERL_IMPLICIT_CONTEXT */
1885 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1887 PERL_ARGS_ASSERT_CK_WARNER_D;
1889 if (Perl_ckwarn_d(aTHX_ err)) {
1891 va_start(args, pat);
1892 vwarner(err, pat, &args);
1898 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1900 PERL_ARGS_ASSERT_CK_WARNER;
1902 if (Perl_ckwarn(aTHX_ err)) {
1904 va_start(args, pat);
1905 vwarner(err, pat, &args);
1911 Perl_warner(pTHX_ U32 err, const char* pat,...)
1914 PERL_ARGS_ASSERT_WARNER;
1915 va_start(args, pat);
1916 vwarner(err, pat, &args);
1921 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1924 PERL_ARGS_ASSERT_VWARNER;
1925 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1926 SV * const msv = vmess(pat, args);
1928 invoke_exception_hook(msv, FALSE);
1932 Perl_vwarn(aTHX_ pat, args);
1936 /* implements the ckWARN? macros */
1939 Perl_ckwarn(pTHX_ U32 w)
1942 /* If lexical warnings have not been set, use $^W. */
1944 return PL_dowarn & G_WARN_ON;
1946 return ckwarn_common(w);
1949 /* implements the ckWARN?_d macro */
1952 Perl_ckwarn_d(pTHX_ U32 w)
1955 /* If lexical warnings have not been set then default classes warn. */
1959 return ckwarn_common(w);
1963 S_ckwarn_common(pTHX_ U32 w)
1965 if (PL_curcop->cop_warnings == pWARN_ALL)
1968 if (PL_curcop->cop_warnings == pWARN_NONE)
1971 /* Check the assumption that at least the first slot is non-zero. */
1972 assert(unpackWARN1(w));
1974 /* Check the assumption that it is valid to stop as soon as a zero slot is
1976 if (!unpackWARN2(w)) {
1977 assert(!unpackWARN3(w));
1978 assert(!unpackWARN4(w));
1979 } else if (!unpackWARN3(w)) {
1980 assert(!unpackWARN4(w));
1983 /* Right, dealt with all the special cases, which are implemented as non-
1984 pointers, so there is a pointer to a real warnings mask. */
1986 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1988 } while (w >>= WARNshift);
1993 /* Set buffer=NULL to get a new one. */
1995 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1997 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1998 PERL_UNUSED_CONTEXT;
1999 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2002 (specialWARN(buffer) ?
2003 PerlMemShared_malloc(len_wanted) :
2004 PerlMemShared_realloc(buffer, len_wanted));
2006 Copy(bits, (buffer + 1), size, char);
2010 /* since we've already done strlen() for both nam and val
2011 * we can use that info to make things faster than
2012 * sprintf(s, "%s=%s", nam, val)
2014 #define my_setenv_format(s, nam, nlen, val, vlen) \
2015 Copy(nam, s, nlen, char); \
2017 Copy(val, s+(nlen+1), vlen, char); \
2018 *(s+(nlen+1+vlen)) = '\0'
2020 #ifdef USE_ENVIRON_ARRAY
2021 /* VMS' my_setenv() is in vms.c */
2022 #if !defined(WIN32) && !defined(NETWARE)
2024 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2028 /* only parent thread can modify process environment */
2029 if (PL_curinterp == aTHX)
2032 #ifndef PERL_USE_SAFE_PUTENV
2033 if (!PL_use_safe_putenv) {
2034 /* most putenv()s leak, so we manipulate environ directly */
2036 register const I32 len = strlen(nam);
2039 /* where does it go? */
2040 for (i = 0; environ[i]; i++) {
2041 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2045 if (environ == PL_origenviron) { /* need we copy environment? */
2051 while (environ[max])
2053 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2054 for (j=0; j<max; j++) { /* copy environment */
2055 const int len = strlen(environ[j]);
2056 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2057 Copy(environ[j], tmpenv[j], len+1, char);
2060 environ = tmpenv; /* tell exec where it is now */
2063 safesysfree(environ[i]);
2064 while (environ[i]) {
2065 environ[i] = environ[i+1];
2070 if (!environ[i]) { /* does not exist yet */
2071 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2072 environ[i+1] = NULL; /* make sure it's null terminated */
2075 safesysfree(environ[i]);
2079 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2080 /* all that work just for this */
2081 my_setenv_format(environ[i], nam, nlen, val, vlen);
2084 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
2085 # if defined(HAS_UNSETENV)
2087 (void)unsetenv(nam);
2089 (void)setenv(nam, val, 1);
2091 # else /* ! HAS_UNSETENV */
2092 (void)setenv(nam, val, 1);
2093 # endif /* HAS_UNSETENV */
2095 # if defined(HAS_UNSETENV)
2097 (void)unsetenv(nam);
2099 const int nlen = strlen(nam);
2100 const int vlen = strlen(val);
2101 char * const new_env =
2102 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2103 my_setenv_format(new_env, nam, nlen, val, vlen);
2104 (void)putenv(new_env);
2106 # else /* ! HAS_UNSETENV */
2108 const int nlen = strlen(nam);
2114 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2115 /* all that work just for this */
2116 my_setenv_format(new_env, nam, nlen, val, vlen);
2117 (void)putenv(new_env);
2118 # endif /* HAS_UNSETENV */
2119 # endif /* __CYGWIN__ */
2120 #ifndef PERL_USE_SAFE_PUTENV
2126 #else /* WIN32 || NETWARE */
2129 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2132 register char *envstr;
2133 const int nlen = strlen(nam);
2140 Newx(envstr, nlen+vlen+2, char);
2141 my_setenv_format(envstr, nam, nlen, val, vlen);
2142 (void)PerlEnv_putenv(envstr);
2146 #endif /* WIN32 || NETWARE */
2148 #endif /* !VMS && !EPOC*/
2150 #ifdef UNLINK_ALL_VERSIONS
2152 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2156 PERL_ARGS_ASSERT_UNLNK;
2158 while (PerlLIO_unlink(f) >= 0)
2160 return retries ? 0 : -1;
2164 /* this is a drop-in replacement for bcopy() */
2165 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2167 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2169 char * const retval = to;
2171 PERL_ARGS_ASSERT_MY_BCOPY;
2173 if (from - to >= 0) {
2181 *(--to) = *(--from);
2187 /* this is a drop-in replacement for memset() */
2190 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2192 char * const retval = loc;
2194 PERL_ARGS_ASSERT_MY_MEMSET;
2202 /* this is a drop-in replacement for bzero() */
2203 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2205 Perl_my_bzero(register char *loc, register I32 len)
2207 char * const retval = loc;
2209 PERL_ARGS_ASSERT_MY_BZERO;
2217 /* this is a drop-in replacement for memcmp() */
2218 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2220 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2222 register const U8 *a = (const U8 *)s1;
2223 register const U8 *b = (const U8 *)s2;
2226 PERL_ARGS_ASSERT_MY_MEMCMP;
2229 if ((tmp = *a++ - *b++))
2234 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2237 /* This vsprintf replacement should generally never get used, since
2238 vsprintf was available in both System V and BSD 2.11. (There may
2239 be some cross-compilation or embedded set-ups where it is needed,
2242 If you encounter a problem in this function, it's probably a symptom
2243 that Configure failed to detect your system's vprintf() function.
2244 See the section on "item vsprintf" in the INSTALL file.
2246 This version may compile on systems with BSD-ish <stdio.h>,
2247 but probably won't on others.
2250 #ifdef USE_CHAR_VSPRINTF
2255 vsprintf(char *dest, const char *pat, void *args)
2259 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2260 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2261 FILE_cnt(&fakebuf) = 32767;
2263 /* These probably won't compile -- If you really need
2264 this, you'll have to figure out some other method. */
2265 fakebuf._ptr = dest;
2266 fakebuf._cnt = 32767;
2271 fakebuf._flag = _IOWRT|_IOSTRG;
2272 _doprnt(pat, args, &fakebuf); /* what a kludge */
2273 #if defined(STDIO_PTR_LVALUE)
2274 *(FILE_ptr(&fakebuf)++) = '\0';
2276 /* PerlIO has probably #defined away fputc, but we want it here. */
2278 # undef fputc /* XXX Should really restore it later */
2280 (void)fputc('\0', &fakebuf);
2282 #ifdef USE_CHAR_VSPRINTF
2285 return 0; /* perl doesn't use return value */
2289 #endif /* HAS_VPRINTF */
2292 #if BYTEORDER != 0x4321
2294 Perl_my_swap(pTHX_ short s)
2296 #if (BYTEORDER & 1) == 0
2299 result = ((s & 255) << 8) + ((s >> 8) & 255);
2307 Perl_my_htonl(pTHX_ long l)
2311 char c[sizeof(long)];
2314 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2315 #if BYTEORDER == 0x12345678
2318 u.c[0] = (l >> 24) & 255;
2319 u.c[1] = (l >> 16) & 255;
2320 u.c[2] = (l >> 8) & 255;
2324 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2325 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2330 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2331 u.c[o & 0xf] = (l >> s) & 255;
2339 Perl_my_ntohl(pTHX_ long l)
2343 char c[sizeof(long)];
2346 #if BYTEORDER == 0x1234
2347 u.c[0] = (l >> 24) & 255;
2348 u.c[1] = (l >> 16) & 255;
2349 u.c[2] = (l >> 8) & 255;
2353 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2354 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2361 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2362 l |= (u.c[o & 0xf] & 255) << s;
2369 #endif /* BYTEORDER != 0x4321 */
2373 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2374 * If these functions are defined,
2375 * the BYTEORDER is neither 0x1234 nor 0x4321.
2376 * However, this is not assumed.
2380 #define HTOLE(name,type) \
2382 name (register type n) \
2386 char c[sizeof(type)]; \
2389 register U32 s = 0; \
2390 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2391 u.c[i] = (n >> s) & 0xFF; \
2396 #define LETOH(name,type) \
2398 name (register type n) \
2402 char c[sizeof(type)]; \
2405 register U32 s = 0; \
2408 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2409 n |= ((type)(u.c[i] & 0xFF)) << s; \
2415 * Big-endian byte order functions.
2418 #define HTOBE(name,type) \
2420 name (register type n) \
2424 char c[sizeof(type)]; \
2427 register U32 s = 8*(sizeof(u.c)-1); \
2428 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2429 u.c[i] = (n >> s) & 0xFF; \
2434 #define BETOH(name,type) \
2436 name (register type n) \
2440 char c[sizeof(type)]; \
2443 register U32 s = 8*(sizeof(u.c)-1); \
2446 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2447 n |= ((type)(u.c[i] & 0xFF)) << s; \
2453 * If we just can't do it...
2456 #define NOT_AVAIL(name,type) \
2458 name (register type n) \
2460 Perl_croak_nocontext(#name "() not available"); \
2461 return n; /* not reached */ \
2465 #if defined(HAS_HTOVS) && !defined(htovs)
2468 #if defined(HAS_HTOVL) && !defined(htovl)
2471 #if defined(HAS_VTOHS) && !defined(vtohs)
2474 #if defined(HAS_VTOHL) && !defined(vtohl)
2478 #ifdef PERL_NEED_MY_HTOLE16
2480 HTOLE(Perl_my_htole16,U16)
2482 NOT_AVAIL(Perl_my_htole16,U16)
2485 #ifdef PERL_NEED_MY_LETOH16
2487 LETOH(Perl_my_letoh16,U16)
2489 NOT_AVAIL(Perl_my_letoh16,U16)
2492 #ifdef PERL_NEED_MY_HTOBE16
2494 HTOBE(Perl_my_htobe16,U16)
2496 NOT_AVAIL(Perl_my_htobe16,U16)
2499 #ifdef PERL_NEED_MY_BETOH16
2501 BETOH(Perl_my_betoh16,U16)
2503 NOT_AVAIL(Perl_my_betoh16,U16)
2507 #ifdef PERL_NEED_MY_HTOLE32
2509 HTOLE(Perl_my_htole32,U32)
2511 NOT_AVAIL(Perl_my_htole32,U32)
2514 #ifdef PERL_NEED_MY_LETOH32
2516 LETOH(Perl_my_letoh32,U32)
2518 NOT_AVAIL(Perl_my_letoh32,U32)
2521 #ifdef PERL_NEED_MY_HTOBE32
2523 HTOBE(Perl_my_htobe32,U32)
2525 NOT_AVAIL(Perl_my_htobe32,U32)
2528 #ifdef PERL_NEED_MY_BETOH32
2530 BETOH(Perl_my_betoh32,U32)
2532 NOT_AVAIL(Perl_my_betoh32,U32)
2536 #ifdef PERL_NEED_MY_HTOLE64
2538 HTOLE(Perl_my_htole64,U64)
2540 NOT_AVAIL(Perl_my_htole64,U64)
2543 #ifdef PERL_NEED_MY_LETOH64
2545 LETOH(Perl_my_letoh64,U64)
2547 NOT_AVAIL(Perl_my_letoh64,U64)
2550 #ifdef PERL_NEED_MY_HTOBE64
2552 HTOBE(Perl_my_htobe64,U64)
2554 NOT_AVAIL(Perl_my_htobe64,U64)
2557 #ifdef PERL_NEED_MY_BETOH64
2559 BETOH(Perl_my_betoh64,U64)
2561 NOT_AVAIL(Perl_my_betoh64,U64)
2565 #ifdef PERL_NEED_MY_HTOLES
2566 HTOLE(Perl_my_htoles,short)
2568 #ifdef PERL_NEED_MY_LETOHS
2569 LETOH(Perl_my_letohs,short)
2571 #ifdef PERL_NEED_MY_HTOBES
2572 HTOBE(Perl_my_htobes,short)
2574 #ifdef PERL_NEED_MY_BETOHS
2575 BETOH(Perl_my_betohs,short)
2578 #ifdef PERL_NEED_MY_HTOLEI
2579 HTOLE(Perl_my_htolei,int)
2581 #ifdef PERL_NEED_MY_LETOHI
2582 LETOH(Perl_my_letohi,int)
2584 #ifdef PERL_NEED_MY_HTOBEI
2585 HTOBE(Perl_my_htobei,int)
2587 #ifdef PERL_NEED_MY_BETOHI
2588 BETOH(Perl_my_betohi,int)
2591 #ifdef PERL_NEED_MY_HTOLEL
2592 HTOLE(Perl_my_htolel,long)
2594 #ifdef PERL_NEED_MY_LETOHL
2595 LETOH(Perl_my_letohl,long)
2597 #ifdef PERL_NEED_MY_HTOBEL
2598 HTOBE(Perl_my_htobel,long)
2600 #ifdef PERL_NEED_MY_BETOHL
2601 BETOH(Perl_my_betohl,long)
2605 Perl_my_swabn(void *ptr, int n)
2607 register char *s = (char *)ptr;
2608 register char *e = s + (n-1);
2611 PERL_ARGS_ASSERT_MY_SWABN;
2613 for (n /= 2; n > 0; s++, e--, n--) {
2621 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2623 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2626 register I32 This, that;
2632 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2634 PERL_FLUSHALL_FOR_CHILD;
2635 This = (*mode == 'w');
2639 taint_proper("Insecure %s%s", "EXEC");
2641 if (PerlProc_pipe(p) < 0)
2643 /* Try for another pipe pair for error return */
2644 if (PerlProc_pipe(pp) >= 0)
2646 while ((pid = PerlProc_fork()) < 0) {
2647 if (errno != EAGAIN) {
2648 PerlLIO_close(p[This]);
2649 PerlLIO_close(p[that]);
2651 PerlLIO_close(pp[0]);
2652 PerlLIO_close(pp[1]);
2656 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2665 /* Close parent's end of error status pipe (if any) */
2667 PerlLIO_close(pp[0]);
2668 #if defined(HAS_FCNTL) && defined(F_SETFD)
2669 /* Close error pipe automatically if exec works */
2670 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2673 /* Now dup our end of _the_ pipe to right position */
2674 if (p[THIS] != (*mode == 'r')) {
2675 PerlLIO_dup2(p[THIS], *mode == 'r');
2676 PerlLIO_close(p[THIS]);
2677 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2678 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2681 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2682 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2683 /* No automatic close - do it by hand */
2690 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2696 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2702 do_execfree(); /* free any memory malloced by child on fork */
2704 PerlLIO_close(pp[1]);
2705 /* Keep the lower of the two fd numbers */
2706 if (p[that] < p[This]) {
2707 PerlLIO_dup2(p[This], p[that]);
2708 PerlLIO_close(p[This]);
2712 PerlLIO_close(p[that]); /* close child's end of pipe */
2714 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2715 SvUPGRADE(sv,SVt_IV);
2717 PL_forkprocess = pid;
2718 /* If we managed to get status pipe check for exec fail */
2719 if (did_pipes && pid > 0) {
2724 while (n < sizeof(int)) {
2725 n1 = PerlLIO_read(pp[0],
2726 (void*)(((char*)&errkid)+n),
2732 PerlLIO_close(pp[0]);
2734 if (n) { /* Error */
2736 PerlLIO_close(p[This]);
2737 if (n != sizeof(int))
2738 Perl_croak(aTHX_ "panic: kid popen errno read");
2740 pid2 = wait4pid(pid, &status, 0);
2741 } while (pid2 == -1 && errno == EINTR);
2742 errno = errkid; /* Propagate errno from kid */
2747 PerlLIO_close(pp[0]);
2748 return PerlIO_fdopen(p[This], mode);
2750 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2751 return my_syspopen4(aTHX_ NULL, mode, n, args);
2753 Perl_croak(aTHX_ "List form of piped open not implemented");
2754 return (PerlIO *) NULL;
2759 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2760 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2762 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2766 register I32 This, that;
2769 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2773 PERL_ARGS_ASSERT_MY_POPEN;
2775 PERL_FLUSHALL_FOR_CHILD;
2778 return my_syspopen(aTHX_ cmd,mode);
2781 This = (*mode == 'w');
2783 if (doexec && PL_tainting) {
2785 taint_proper("Insecure %s%s", "EXEC");
2787 if (PerlProc_pipe(p) < 0)
2789 if (doexec && PerlProc_pipe(pp) >= 0)
2791 while ((pid = PerlProc_fork()) < 0) {
2792 if (errno != EAGAIN) {
2793 PerlLIO_close(p[This]);
2794 PerlLIO_close(p[that]);
2796 PerlLIO_close(pp[0]);
2797 PerlLIO_close(pp[1]);
2800 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2803 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2813 PerlLIO_close(pp[0]);
2814 #if defined(HAS_FCNTL) && defined(F_SETFD)
2815 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2818 if (p[THIS] != (*mode == 'r')) {
2819 PerlLIO_dup2(p[THIS], *mode == 'r');
2820 PerlLIO_close(p[THIS]);
2821 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2822 PerlLIO_close(p[THAT]);
2825 PerlLIO_close(p[THAT]);
2828 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2835 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2840 /* may or may not use the shell */
2841 do_exec3(cmd, pp[1], did_pipes);
2844 #endif /* defined OS2 */
2846 #ifdef PERLIO_USING_CRLF
2847 /* Since we circumvent IO layers when we manipulate low-level
2848 filedescriptors directly, need to manually switch to the
2849 default, binary, low-level mode; see PerlIOBuf_open(). */
2850 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2852 #ifdef THREADS_HAVE_PIDS
2853 PL_ppid = (IV)getppid();
2856 #ifdef PERL_USES_PL_PIDSTATUS
2857 hv_clear(PL_pidstatus); /* we have no children */
2863 do_execfree(); /* free any memory malloced by child on vfork */
2865 PerlLIO_close(pp[1]);
2866 if (p[that] < p[This]) {
2867 PerlLIO_dup2(p[This], p[that]);
2868 PerlLIO_close(p[This]);
2872 PerlLIO_close(p[that]);
2874 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2875 SvUPGRADE(sv,SVt_IV);
2877 PL_forkprocess = pid;
2878 if (did_pipes && pid > 0) {
2883 while (n < sizeof(int)) {
2884 n1 = PerlLIO_read(pp[0],
2885 (void*)(((char*)&errkid)+n),
2891 PerlLIO_close(pp[0]);
2893 if (n) { /* Error */
2895 PerlLIO_close(p[This]);
2896 if (n != sizeof(int))
2897 Perl_croak(aTHX_ "panic: kid popen errno read");
2899 pid2 = wait4pid(pid, &status, 0);
2900 } while (pid2 == -1 && errno == EINTR);
2901 errno = errkid; /* Propagate errno from kid */
2906 PerlLIO_close(pp[0]);
2907 return PerlIO_fdopen(p[This], mode);
2910 #if defined(atarist) || defined(EPOC)
2913 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2915 PERL_ARGS_ASSERT_MY_POPEN;
2916 PERL_FLUSHALL_FOR_CHILD;
2917 /* Call system's popen() to get a FILE *, then import it.
2918 used 0 for 2nd parameter to PerlIO_importFILE;
2921 return PerlIO_importFILE(popen(cmd, mode), 0);
2925 FILE *djgpp_popen();
2927 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2929 PERL_FLUSHALL_FOR_CHILD;
2930 /* Call system's popen() to get a FILE *, then import it.
2931 used 0 for 2nd parameter to PerlIO_importFILE;
2934 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2937 #if defined(__LIBCATAMOUNT__)
2939 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2947 #endif /* !DOSISH */
2949 /* this is called in parent before the fork() */
2951 Perl_atfork_lock(void)
2954 #if defined(USE_ITHREADS)
2955 /* locks must be held in locking order (if any) */
2957 MUTEX_LOCK(&PL_malloc_mutex);
2963 /* this is called in both parent and child after the fork() */
2965 Perl_atfork_unlock(void)
2968 #if defined(USE_ITHREADS)
2969 /* locks must be released in same order as in atfork_lock() */
2971 MUTEX_UNLOCK(&PL_malloc_mutex);
2980 #if defined(HAS_FORK)
2982 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2987 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2988 * handlers elsewhere in the code */
2993 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2994 Perl_croak_nocontext("fork() not available");
2996 #endif /* HAS_FORK */
3001 Perl_dump_fds(pTHX_ const char *const s)
3006 PERL_ARGS_ASSERT_DUMP_FDS;
3008 PerlIO_printf(Perl_debug_log,"%s", s);
3009 for (fd = 0; fd < 32; fd++) {
3010 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
3011 PerlIO_printf(Perl_debug_log," %d",fd);
3013 PerlIO_printf(Perl_debug_log,"\n");
3016 #endif /* DUMP_FDS */
3020 dup2(int oldfd, int newfd)
3022 #if defined(HAS_FCNTL) && defined(F_DUPFD)
3025 PerlLIO_close(newfd);
3026 return fcntl(oldfd, F_DUPFD, newfd);
3028 #define DUP2_MAX_FDS 256
3029 int fdtmp[DUP2_MAX_FDS];
3035 PerlLIO_close(newfd);
3036 /* good enough for low fd's... */
3037 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
3038 if (fdx >= DUP2_MAX_FDS) {
3046 PerlLIO_close(fdtmp[--fdx]);
3053 #ifdef HAS_SIGACTION
3056 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3059 struct sigaction act, oact;
3062 /* only "parent" interpreter can diddle signals */
3063 if (PL_curinterp != aTHX)
3064 return (Sighandler_t) SIG_ERR;
3067 act.sa_handler = (void(*)(int))handler;
3068 sigemptyset(&act.sa_mask);
3071 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3072 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3074 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3075 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3076 act.sa_flags |= SA_NOCLDWAIT;
3078 if (sigaction(signo, &act, &oact) == -1)
3079 return (Sighandler_t) SIG_ERR;
3081 return (Sighandler_t) oact.sa_handler;
3085 Perl_rsignal_state(pTHX_ int signo)
3087 struct sigaction oact;
3088 PERL_UNUSED_CONTEXT;
3090 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3091 return (Sighandler_t) SIG_ERR;
3093 return (Sighandler_t) oact.sa_handler;
3097 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3100 struct sigaction act;
3102 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3105 /* only "parent" interpreter can diddle signals */
3106 if (PL_curinterp != aTHX)
3110 act.sa_handler = (void(*)(int))handler;
3111 sigemptyset(&act.sa_mask);
3114 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3115 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3117 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3118 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3119 act.sa_flags |= SA_NOCLDWAIT;
3121 return sigaction(signo, &act, save);
3125 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3129 /* only "parent" interpreter can diddle signals */
3130 if (PL_curinterp != aTHX)
3134 return sigaction(signo, save, (struct sigaction *)NULL);
3137 #else /* !HAS_SIGACTION */
3140 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3142 #if defined(USE_ITHREADS) && !defined(WIN32)
3143 /* only "parent" interpreter can diddle signals */
3144 if (PL_curinterp != aTHX)
3145 return (Sighandler_t) SIG_ERR;
3148 return PerlProc_signal(signo, handler);
3159 Perl_rsignal_state(pTHX_ int signo)
3162 Sighandler_t oldsig;
3164 #if defined(USE_ITHREADS) && !defined(WIN32)
3165 /* only "parent" interpreter can diddle signals */
3166 if (PL_curinterp != aTHX)
3167 return (Sighandler_t) SIG_ERR;
3171 oldsig = PerlProc_signal(signo, sig_trap);
3172 PerlProc_signal(signo, oldsig);
3174 PerlProc_kill(PerlProc_getpid(), signo);
3179 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3181 #if defined(USE_ITHREADS) && !defined(WIN32)
3182 /* only "parent" interpreter can diddle signals */
3183 if (PL_curinterp != aTHX)
3186 *save = PerlProc_signal(signo, handler);
3187 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3191 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3193 #if defined(USE_ITHREADS) && !defined(WIN32)
3194 /* only "parent" interpreter can diddle signals */
3195 if (PL_curinterp != aTHX)
3198 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3201 #endif /* !HAS_SIGACTION */
3202 #endif /* !PERL_MICRO */
3204 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3205 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3207 Perl_my_pclose(pTHX_ PerlIO *ptr)
3210 Sigsave_t hstat, istat, qstat;
3217 const int fd = PerlIO_fileno(ptr);
3220 /* Find out whether the refcount is low enough for us to wait for the
3221 child proc without blocking. */
3222 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3224 const bool should_wait = 1;
3227 svp = av_fetch(PL_fdpid,fd,TRUE);
3228 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3230 *svp = &PL_sv_undef;
3232 if (pid == -1) { /* Opened by popen. */
3233 return my_syspclose(ptr);
3236 close_failed = (PerlIO_close(ptr) == EOF);
3239 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
3242 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3243 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3244 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3246 if (should_wait) do {
3247 pid2 = wait4pid(pid, &status, 0);
3248 } while (pid2 == -1 && errno == EINTR);
3250 rsignal_restore(SIGHUP, &hstat);
3251 rsignal_restore(SIGINT, &istat);
3252 rsignal_restore(SIGQUIT, &qstat);
3260 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3265 #if defined(__LIBCATAMOUNT__)
3267 Perl_my_pclose(pTHX_ PerlIO *ptr)
3272 #endif /* !DOSISH */
3274 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3276 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3280 PERL_ARGS_ASSERT_WAIT4PID;
3283 #ifdef PERL_USES_PL_PIDSTATUS
3286 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3287 pid, rather than a string form. */
3288 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3289 if (svp && *svp != &PL_sv_undef) {
3290 *statusp = SvIVX(*svp);
3291 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3299 hv_iterinit(PL_pidstatus);
3300 if ((entry = hv_iternext(PL_pidstatus))) {
3301 SV * const sv = hv_iterval(PL_pidstatus,entry);
3303 const char * const spid = hv_iterkey(entry,&len);
3305 assert (len == sizeof(Pid_t));
3306 memcpy((char *)&pid, spid, len);
3307 *statusp = SvIVX(sv);
3308 /* The hash iterator is currently on this entry, so simply
3309 calling hv_delete would trigger the lazy delete, which on
3310 aggregate does more work, beacuse next call to hv_iterinit()
3311 would spot the flag, and have to call the delete routine,
3312 while in the meantime any new entries can't re-use that
3314 hv_iterinit(PL_pidstatus);
3315 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3322 # ifdef HAS_WAITPID_RUNTIME
3323 if (!HAS_WAITPID_RUNTIME)
3326 result = PerlProc_waitpid(pid,statusp,flags);
3329 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3330 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3333 #ifdef PERL_USES_PL_PIDSTATUS
3334 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3339 Perl_croak(aTHX_ "Can't do waitpid with flags");
3341 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3342 pidgone(result,*statusp);
3348 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3351 if (result < 0 && errno == EINTR) {
3353 errno = EINTR; /* reset in case a signal handler changed $! */
3357 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3359 #ifdef PERL_USES_PL_PIDSTATUS
3361 S_pidgone(pTHX_ Pid_t pid, int status)
3365 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3366 SvUPGRADE(sv,SVt_IV);
3367 SvIV_set(sv, status);
3372 #if defined(atarist) || defined(OS2) || defined(EPOC)
3375 int /* Cannot prototype with I32
3377 my_syspclose(PerlIO *ptr)
3380 Perl_my_pclose(pTHX_ PerlIO *ptr)
3383 /* Needs work for PerlIO ! */
3384 FILE * const f = PerlIO_findFILE(ptr);
3385 const I32 result = pclose(f);
3386 PerlIO_releaseFILE(ptr,f);
3394 Perl_my_pclose(pTHX_ PerlIO *ptr)
3396 /* Needs work for PerlIO ! */
3397 FILE * const f = PerlIO_findFILE(ptr);
3398 I32 result = djgpp_pclose(f);
3399 result = (result << 8) & 0xff00;
3400 PerlIO_releaseFILE(ptr,f);
3405 #define PERL_REPEATCPY_LINEAR 4
3407 Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count)
3409 PERL_ARGS_ASSERT_REPEATCPY;
3412 memset(to, *from, count);
3414 register char *p = to;
3415 IV items, linear, half;
3417 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3418 for (items = 0; items < linear; ++items) {
3419 register const char *q = from;
3421 for (todo = len; todo > 0; todo--)
3426 while (items <= half) {
3427 IV size = items * len;
3428 memcpy(p, to, size);
3434 memcpy(p, to, (count - items) * len);
3440 Perl_same_dirent(pTHX_ const char *a, const char *b)
3442 char *fa = strrchr(a,'/');
3443 char *fb = strrchr(b,'/');
3446 SV * const tmpsv = sv_newmortal();
3448 PERL_ARGS_ASSERT_SAME_DIRENT;
3461 sv_setpvs(tmpsv, ".");
3463 sv_setpvn(tmpsv, a, fa - a);
3464 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3467 sv_setpvs(tmpsv, ".");
3469 sv_setpvn(tmpsv, b, fb - b);
3470 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3472 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3473 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3475 #endif /* !HAS_RENAME */
3478 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3479 const char *const *const search_ext, I32 flags)
3482 const char *xfound = NULL;
3483 char *xfailed = NULL;
3484 char tmpbuf[MAXPATHLEN];
3489 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3490 # define SEARCH_EXTS ".bat", ".cmd", NULL
3491 # define MAX_EXT_LEN 4
3494 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3495 # define MAX_EXT_LEN 4
3498 # define SEARCH_EXTS ".pl", ".com", NULL
3499 # define MAX_EXT_LEN 4
3501 /* additional extensions to try in each dir if scriptname not found */
3503 static const char *const exts[] = { SEARCH_EXTS };
3504 const char *const *const ext = search_ext ? search_ext : exts;
3505 int extidx = 0, i = 0;
3506 const char *curext = NULL;
3508 PERL_UNUSED_ARG(search_ext);
3509 # define MAX_EXT_LEN 0
3512 PERL_ARGS_ASSERT_FIND_SCRIPT;
3515 * If dosearch is true and if scriptname does not contain path
3516 * delimiters, search the PATH for scriptname.
3518 * If SEARCH_EXTS is also defined, will look for each
3519 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3520 * while searching the PATH.
3522 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3523 * proceeds as follows:
3524 * If DOSISH or VMSISH:
3525 * + look for ./scriptname{,.foo,.bar}
3526 * + search the PATH for scriptname{,.foo,.bar}
3529 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3530 * this will not look in '.' if it's not in the PATH)
3535 # ifdef ALWAYS_DEFTYPES
3536 len = strlen(scriptname);
3537 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3538 int idx = 0, deftypes = 1;
3541 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3544 int idx = 0, deftypes = 1;
3547 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3549 /* The first time through, just add SEARCH_EXTS to whatever we
3550 * already have, so we can check for default file types. */
3552 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3558 if ((strlen(tmpbuf) + strlen(scriptname)
3559 + MAX_EXT_LEN) >= sizeof tmpbuf)
3560 continue; /* don't search dir with too-long name */
3561 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3565 if (strEQ(scriptname, "-"))
3567 if (dosearch) { /* Look in '.' first. */
3568 const char *cur = scriptname;
3570 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3572 if (strEQ(ext[i++],curext)) {
3573 extidx = -1; /* already has an ext */
3578 DEBUG_p(PerlIO_printf(Perl_debug_log,
3579 "Looking for %s\n",cur));
3580 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3581 && !S_ISDIR(PL_statbuf.st_mode)) {
3589 if (cur == scriptname) {
3590 len = strlen(scriptname);
3591 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3593 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3596 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3597 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3602 if (dosearch && !strchr(scriptname, '/')
3604 && !strchr(scriptname, '\\')
3606 && (s = PerlEnv_getenv("PATH")))
3610 bufend = s + strlen(s);
3611 while (s < bufend) {
3612 #if defined(atarist) || defined(DOSISH)
3617 && *s != ';'; len++, s++) {
3618 if (len < sizeof tmpbuf)
3621 if (len < sizeof tmpbuf)
3623 #else /* ! (atarist || DOSISH) */
3624 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3627 #endif /* ! (atarist || DOSISH) */
3630 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3631 continue; /* don't search dir with too-long name */
3633 # if defined(atarist) || defined(DOSISH)
3634 && tmpbuf[len - 1] != '/'
3635 && tmpbuf[len - 1] != '\\'
3638 tmpbuf[len++] = '/';
3639 if (len == 2 && tmpbuf[0] == '.')
3641 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3645 len = strlen(tmpbuf);
3646 if (extidx > 0) /* reset after previous loop */
3650 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3651 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3652 if (S_ISDIR(PL_statbuf.st_mode)) {
3656 } while ( retval < 0 /* not there */
3657 && extidx>=0 && ext[extidx] /* try an extension? */
3658 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3663 if (S_ISREG(PL_statbuf.st_mode)
3664 && cando(S_IRUSR,TRUE,&PL_statbuf)
3665 #if !defined(DOSISH)
3666 && cando(S_IXUSR,TRUE,&PL_statbuf)
3670 xfound = tmpbuf; /* bingo! */
3674 xfailed = savepv(tmpbuf);
3677 if (!xfound && !seen_dot && !xfailed &&
3678 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3679 || S_ISDIR(PL_statbuf.st_mode)))
3681 seen_dot = 1; /* Disable message. */
3683 if (flags & 1) { /* do or die? */
3684 Perl_croak(aTHX_ "Can't %s %s%s%s",
3685 (xfailed ? "execute" : "find"),
3686 (xfailed ? xfailed : scriptname),
3687 (xfailed ? "" : " on PATH"),
3688 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3693 scriptname = xfound;
3695 return (scriptname ? savepv(scriptname) : NULL);
3698 #ifndef PERL_GET_CONTEXT_DEFINED
3701 Perl_get_context(void)
3704 #if defined(USE_ITHREADS)
3705 # ifdef OLD_PTHREADS_API
3707 if (pthread_getspecific(PL_thr_key, &t))
3708 Perl_croak_nocontext("panic: pthread_getspecific");
3711 # ifdef I_MACH_CTHREADS
3712 return (void*)cthread_data(cthread_self());
3714 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3723 Perl_set_context(void *t)
3726 PERL_ARGS_ASSERT_SET_CONTEXT;
3727 #if defined(USE_ITHREADS)
3728 # ifdef I_MACH_CTHREADS
3729 cthread_set_data(cthread_self(), t);
3731 if (pthread_setspecific(PL_thr_key, t))
3732 Perl_croak_nocontext("panic: pthread_setspecific");
3739 #endif /* !PERL_GET_CONTEXT_DEFINED */
3741 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3750 Perl_get_op_names(pTHX)
3752 PERL_UNUSED_CONTEXT;
3753 return (char **)PL_op_name;
3757 Perl_get_op_descs(pTHX)
3759 PERL_UNUSED_CONTEXT;
3760 return (char **)PL_op_desc;
3764 Perl_get_no_modify(pTHX)
3766 PERL_UNUSED_CONTEXT;
3767 return PL_no_modify;
3771 Perl_get_opargs(pTHX)
3773 PERL_UNUSED_CONTEXT;
3774 return (U32 *)PL_opargs;
3778 Perl_get_ppaddr(pTHX)
3781 PERL_UNUSED_CONTEXT;
3782 return (PPADDR_t*)PL_ppaddr;
3785 #ifndef HAS_GETENV_LEN
3787 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3789 char * const env_trans = PerlEnv_getenv(env_elem);
3790 PERL_UNUSED_CONTEXT;
3791 PERL_ARGS_ASSERT_GETENV_LEN;
3793 *len = strlen(env_trans);
3800 Perl_get_vtbl(pTHX_ int vtbl_id)
3802 PERL_UNUSED_CONTEXT;
3804 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3805 ? NULL : PL_magic_vtables + vtbl_id;
3809 Perl_my_fflush_all(pTHX)
3811 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3812 return PerlIO_flush(NULL);
3814 # if defined(HAS__FWALK)
3815 extern int fflush(FILE *);
3816 /* undocumented, unprototyped, but very useful BSDism */
3817 extern void _fwalk(int (*)(FILE *));
3821 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3823 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3824 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3826 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3827 open_max = sysconf(_SC_OPEN_MAX);
3830 open_max = FOPEN_MAX;
3833 open_max = OPEN_MAX;
3844 for (i = 0; i < open_max; i++)
3845 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3846 STDIO_STREAM_ARRAY[i]._file < open_max &&
3847 STDIO_STREAM_ARRAY[i]._flag)
3848 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3852 SETERRNO(EBADF,RMS_IFI);
3859 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3861 if (ckWARN(WARN_IO)) {
3863 = gv && (isGV(gv) || isGV_with_GP(gv))
3864 ? sv_2mortal(newSVhek(GvENAME_HEK((gv))))
3866 const char * const direction = have == '>' ? "out" : "in";
3868 if (name && SvPOK(name) && *SvPV_nolen(name))
3869 Perl_warner(aTHX_ packWARN(WARN_IO),
3870 "Filehandle %"SVf" opened only for %sput",
3873 Perl_warner(aTHX_ packWARN(WARN_IO),
3874 "Filehandle opened only for %sput", direction);
3879 Perl_report_evil_fh(pTHX_ const GV *gv)
3881 const IO *io = gv ? GvIO(gv) : NULL;
3882 const PERL_BITFIELD16 op = PL_op->op_type;
3886 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3888 warn_type = WARN_CLOSED;
3892 warn_type = WARN_UNOPENED;
3895 if (ckWARN(warn_type)) {
3897 = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ?
3898 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3899 const char * const pars =
3900 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3901 const char * const func =
3903 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3904 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3906 const char * const type =
3908 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3909 ? "socket" : "filehandle");
3910 if (name && SvPOK(name) && *SvPV_nolen(name)) {
3911 Perl_warner(aTHX_ packWARN(warn_type),
3912 "%s%s on %s %s %"SVf, func, pars, vile, type, SVfARG(name));
3913 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3915 aTHX_ packWARN(warn_type),
3916 "\t(Are you trying to call %s%s on dirhandle %"SVf"?)\n",
3917 func, pars, SVfARG(name)
3921 Perl_warner(aTHX_ packWARN(warn_type),
3922 "%s%s on %s %s", func, pars, vile, type);
3923 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3925 aTHX_ packWARN(warn_type),
3926 "\t(Are you trying to call %s%s on dirhandle?)\n",
3933 /* To workaround core dumps from the uninitialised tm_zone we get the
3934 * system to give us a reasonable struct to copy. This fix means that
3935 * strftime uses the tm_zone and tm_gmtoff values returned by
3936 * localtime(time()). That should give the desired result most of the
3937 * time. But probably not always!
3939 * This does not address tzname aspects of NETaa14816.
3944 # ifndef STRUCT_TM_HASZONE
3945 # define STRUCT_TM_HASZONE
3949 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3950 # ifndef HAS_TM_TM_ZONE
3951 # define HAS_TM_TM_ZONE
3956 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3958 #ifdef HAS_TM_TM_ZONE
3960 const struct tm* my_tm;
3961 PERL_ARGS_ASSERT_INIT_TM;
3963 my_tm = localtime(&now);
3965 Copy(my_tm, ptm, 1, struct tm);
3967 PERL_ARGS_ASSERT_INIT_TM;
3968 PERL_UNUSED_ARG(ptm);
3973 * mini_mktime - normalise struct tm values without the localtime()
3974 * semantics (and overhead) of mktime().
3977 Perl_mini_mktime(pTHX_ struct tm *ptm)
3981 int month, mday, year, jday;
3982 int odd_cent, odd_year;
3983 PERL_UNUSED_CONTEXT;
3985 PERL_ARGS_ASSERT_MINI_MKTIME;
3987 #define DAYS_PER_YEAR 365
3988 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3989 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3990 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3991 #define SECS_PER_HOUR (60*60)
3992 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3993 /* parentheses deliberately absent on these two, otherwise they don't work */
3994 #define MONTH_TO_DAYS 153/5
3995 #define DAYS_TO_MONTH 5/153
3996 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3997 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3998 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3999 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
4002 * Year/day algorithm notes:
4004 * With a suitable offset for numeric value of the month, one can find
4005 * an offset into the year by considering months to have 30.6 (153/5) days,
4006 * using integer arithmetic (i.e., with truncation). To avoid too much
4007 * messing about with leap days, we consider January and February to be
4008 * the 13th and 14th month of the previous year. After that transformation,
4009 * we need the month index we use to be high by 1 from 'normal human' usage,
4010 * so the month index values we use run from 4 through 15.
4012 * Given that, and the rules for the Gregorian calendar (leap years are those
4013 * divisible by 4 unless also divisible by 100, when they must be divisible
4014 * by 400 instead), we can simply calculate the number of days since some
4015 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4016 * the days we derive from our month index, and adding in the day of the
4017 * month. The value used here is not adjusted for the actual origin which
4018 * it normally would use (1 January A.D. 1), since we're not exposing it.
4019 * We're only building the value so we can turn around and get the
4020 * normalised values for the year, month, day-of-month, and day-of-year.
4022 * For going backward, we need to bias the value we're using so that we find
4023 * the right year value. (Basically, we don't want the contribution of
4024 * March 1st to the number to apply while deriving the year). Having done
4025 * that, we 'count up' the contribution to the year number by accounting for
4026 * full quadracenturies (400-year periods) with their extra leap days, plus
4027 * the contribution from full centuries (to avoid counting in the lost leap
4028 * days), plus the contribution from full quad-years (to count in the normal
4029 * leap days), plus the leftover contribution from any non-leap years.
4030 * At this point, if we were working with an actual leap day, we'll have 0
4031 * days left over. This is also true for March 1st, however. So, we have
4032 * to special-case that result, and (earlier) keep track of the 'odd'
4033 * century and year contributions. If we got 4 extra centuries in a qcent,
4034 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4035 * Otherwise, we add back in the earlier bias we removed (the 123 from
4036 * figuring in March 1st), find the month index (integer division by 30.6),
4037 * and the remainder is the day-of-month. We then have to convert back to
4038 * 'real' months (including fixing January and February from being 14/15 in
4039 * the previous year to being in the proper year). After that, to get
4040 * tm_yday, we work with the normalised year and get a new yearday value for
4041 * January 1st, which we subtract from the yearday value we had earlier,
4042 * representing the date we've re-built. This is done from January 1
4043 * because tm_yday is 0-origin.
4045 * Since POSIX time routines are only guaranteed to work for times since the
4046 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4047 * applies Gregorian calendar rules even to dates before the 16th century
4048 * doesn't bother me. Besides, you'd need cultural context for a given
4049 * date to know whether it was Julian or Gregorian calendar, and that's
4050 * outside the scope for this routine. Since we convert back based on the
4051 * same rules we used to build the yearday, you'll only get strange results
4052 * for input which needed normalising, or for the 'odd' century years which
4053 * were leap years in the Julian calendar but not in the Gregorian one.
4054 * I can live with that.
4056 * This algorithm also fails to handle years before A.D. 1 gracefully, but
4057 * that's still outside the scope for POSIX time manipulation, so I don't
4061 year = 1900 + ptm->tm_year;
4062 month = ptm->tm_mon;
4063 mday = ptm->tm_mday;
4064 /* allow given yday with no month & mday to dominate the result */
4065 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4068 jday = 1 + ptm->tm_yday;
4077 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4078 yearday += month*MONTH_TO_DAYS + mday + jday;
4080 * Note that we don't know when leap-seconds were or will be,
4081 * so we have to trust the user if we get something which looks
4082 * like a sensible leap-second. Wild values for seconds will
4083 * be rationalised, however.
4085 if ((unsigned) ptm->tm_sec <= 60) {
4092 secs += 60 * ptm->tm_min;
4093 secs += SECS_PER_HOUR * ptm->tm_hour;
4095 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4096 /* got negative remainder, but need positive time */
4097 /* back off an extra day to compensate */
4098 yearday += (secs/SECS_PER_DAY)-1;
4099 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4102 yearday += (secs/SECS_PER_DAY);
4103 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4106 else if (secs >= SECS_PER_DAY) {
4107 yearday += (secs/SECS_PER_DAY);
4108 secs %= SECS_PER_DAY;
4110 ptm->tm_hour = secs/SECS_PER_HOUR;
4111 secs %= SECS_PER_HOUR;
4112 ptm->tm_min = secs/60;
4114 ptm->tm_sec += secs;
4115 /* done with time of day effects */
4117 * The algorithm for yearday has (so far) left it high by 428.
4118 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4119 * bias it by 123 while trying to figure out what year it
4120 * really represents. Even with this tweak, the reverse
4121 * translation fails for years before A.D. 0001.
4122 * It would still fail for Feb 29, but we catch that one below.
4124 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
4125 yearday -= YEAR_ADJUST;
4126 year = (yearday / DAYS_PER_QCENT) * 400;
4127 yearday %= DAYS_PER_QCENT;
4128 odd_cent = yearday / DAYS_PER_CENT;
4129 year += odd_cent * 100;
4130 yearday %= DAYS_PER_CENT;
4131 year += (yearday / DAYS_PER_QYEAR) * 4;
4132 yearday %= DAYS_PER_QYEAR;
4133 odd_year = yearday / DAYS_PER_YEAR;
4135 yearday %= DAYS_PER_YEAR;
4136 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4141 yearday += YEAR_ADJUST; /* recover March 1st crock */
4142 month = yearday*DAYS_TO_MONTH;
4143 yearday -= month*MONTH_TO_DAYS;
4144 /* recover other leap-year adjustment */
4153 ptm->tm_year = year - 1900;
4155 ptm->tm_mday = yearday;
4156 ptm->tm_mon = month;
4160 ptm->tm_mon = month - 1;
4162 /* re-build yearday based on Jan 1 to get tm_yday */
4164 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4165 yearday += 14*MONTH_TO_DAYS + 1;
4166 ptm->tm_yday = jday - yearday;
4167 /* fix tm_wday if not overridden by caller */
4168 if ((unsigned)ptm->tm_wday > 6)
4169 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4173 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)
4181 PERL_ARGS_ASSERT_MY_STRFTIME;
4183 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4186 mytm.tm_hour = hour;
4187 mytm.tm_mday = mday;
4189 mytm.tm_year = year;
4190 mytm.tm_wday = wday;
4191 mytm.tm_yday = yday;
4192 mytm.tm_isdst = isdst;
4194 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4195 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4200 #ifdef HAS_TM_TM_GMTOFF
4201 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4203 #ifdef HAS_TM_TM_ZONE
4204 mytm.tm_zone = mytm2.tm_zone;
4209 Newx(buf, buflen, char);
4210 len = strftime(buf, buflen, fmt, &mytm);
4212 ** The following is needed to handle to the situation where
4213 ** tmpbuf overflows. Basically we want to allocate a buffer
4214 ** and try repeatedly. The reason why it is so complicated
4215 ** is that getting a return value of 0 from strftime can indicate
4216 ** one of the following:
4217 ** 1. buffer overflowed,
4218 ** 2. illegal conversion specifier, or
4219 ** 3. the format string specifies nothing to be returned(not
4220 ** an error). This could be because format is an empty string
4221 ** or it specifies %p that yields an empty string in some locale.
4222 ** If there is a better way to make it portable, go ahead by
4225 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4228 /* Possibly buf overflowed - try again with a bigger buf */
4229 const int fmtlen = strlen(fmt);
4230 int bufsize = fmtlen + buflen;
4232 Renew(buf, bufsize, char);
4234 buflen = strftime(buf, bufsize, fmt, &mytm);
4235 if (buflen > 0 && buflen < bufsize)
4237 /* heuristic to prevent out-of-memory errors */
4238 if (bufsize > 100*fmtlen) {
4244 Renew(buf, bufsize, char);
4249 Perl_croak(aTHX_ "panic: no strftime");
4255 #define SV_CWD_RETURN_UNDEF \
4256 sv_setsv(sv, &PL_sv_undef); \
4259 #define SV_CWD_ISDOT(dp) \
4260 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4261 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4264 =head1 Miscellaneous Functions
4266 =for apidoc getcwd_sv
4268 Fill the sv with current working directory
4273 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4274 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4275 * getcwd(3) if available
4276 * Comments from the orignal:
4277 * This is a faster version of getcwd. It's also more dangerous
4278 * because you might chdir out of a directory that you can't chdir
4282 Perl_getcwd_sv(pTHX_ register SV *sv)
4286 #ifndef INCOMPLETE_TAINTS
4290 PERL_ARGS_ASSERT_GETCWD_SV;
4294 char buf[MAXPATHLEN];
4296 /* Some getcwd()s automatically allocate a buffer of the given
4297 * size from the heap if they are given a NULL buffer pointer.
4298 * The problem is that this behaviour is not portable. */
4299 if (getcwd(buf, sizeof(buf) - 1)) {
4304 sv_setsv(sv, &PL_sv_undef);
4312 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4316 SvUPGRADE(sv, SVt_PV);
4318 if (PerlLIO_lstat(".", &statbuf) < 0) {
4319 SV_CWD_RETURN_UNDEF;
4322 orig_cdev = statbuf.st_dev;
4323 orig_cino = statbuf.st_ino;
4333 if (PerlDir_chdir("..") < 0) {
4334 SV_CWD_RETURN_UNDEF;
4336 if (PerlLIO_stat(".", &statbuf) < 0) {
4337 SV_CWD_RETURN_UNDEF;
4340 cdev = statbuf.st_dev;
4341 cino = statbuf.st_ino;
4343 if (odev == cdev && oino == cino) {
4346 if (!(dir = PerlDir_open("."))) {
4347 SV_CWD_RETURN_UNDEF;
4350 while ((dp = PerlDir_read(dir)) != NULL) {
4352 namelen = dp->d_namlen;
4354 namelen = strlen(dp->d_name);
4357 if (SV_CWD_ISDOT(dp)) {
4361 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4362 SV_CWD_RETURN_UNDEF;
4365 tdev = statbuf.st_dev;
4366 tino = statbuf.st_ino;
4367 if (tino == oino && tdev == odev) {
4373 SV_CWD_RETURN_UNDEF;
4376 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4377 SV_CWD_RETURN_UNDEF;
4380 SvGROW(sv, pathlen + namelen + 1);
4384 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4387 /* prepend current directory to the front */
4389 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4390 pathlen += (namelen + 1);
4392 #ifdef VOID_CLOSEDIR
4395 if (PerlDir_close(dir) < 0) {
4396 SV_CWD_RETURN_UNDEF;
4402 SvCUR_set(sv, pathlen);
4406 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4407 SV_CWD_RETURN_UNDEF;
4410 if (PerlLIO_stat(".", &statbuf) < 0) {
4411 SV_CWD_RETURN_UNDEF;
4414 cdev = statbuf.st_dev;
4415 cino = statbuf.st_ino;
4417 if (cdev != orig_cdev || cino != orig_cino) {
4418 Perl_croak(aTHX_ "Unstable directory path, "
4419 "current directory changed unexpectedly");
4430 #define VERSION_MAX 0x7FFFFFFF
4433 =for apidoc prescan_version
4435 Validate that a given string can be parsed as a version object, but doesn't
4436 actually perform the parsing. Can use either strict or lax validation rules.
4437 Can optionally set a number of hint variables to save the parsing code
4438 some time when tokenizing.
4443 Perl_prescan_version(pTHX_ const char *s, bool strict,
4444 const char **errstr,
4445 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4446 bool qv = (sqv ? *sqv : FALSE);
4448 int saw_decimal = 0;
4452 PERL_ARGS_ASSERT_PRESCAN_VERSION;
4454 if (qv && isDIGIT(*d))
4455 goto dotted_decimal_version;
4457 if (*d == 'v') { /* explicit v-string */
4462 else { /* degenerate v-string */
4463 /* requires v1.2.3 */
4464 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4467 dotted_decimal_version:
4468 if (strict && d[0] == '0' && isDIGIT(d[1])) {
4469 /* no leading zeros allowed */
4470 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4473 while (isDIGIT(*d)) /* integer part */
4479 d++; /* decimal point */
4484 /* require v1.2.3 */
4485 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4488 goto version_prescan_finish;
4495 while (isDIGIT(*d)) { /* just keep reading */
4497 while (isDIGIT(*d)) {
4499 /* maximum 3 digits between decimal */
4500 if (strict && j > 3) {
4501 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4506 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4509 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4514 else if (*d == '.') {
4516 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4521 else if (!isDIGIT(*d)) {
4527 if (strict && i < 2) {
4528 /* requires v1.2.3 */
4529 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4532 } /* end if dotted-decimal */
4534 { /* decimal versions */
4535 /* special strict case for leading '.' or '0' */
4538 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4540 if (*d == '0' && isDIGIT(d[1])) {
4541 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4545 /* and we never support negative versions */
4547 BADVERSION(s,errstr,"Invalid version format (negative version number)");
4550 /* consume all of the integer part */
4554 /* look for a fractional part */
4556 /* we found it, so consume it */
4560 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4563 BADVERSION(s,errstr,"Invalid version format (version required)");
4565 /* found just an integer */
4566 goto version_prescan_finish;
4568 else if ( d == s ) {
4569 /* didn't find either integer or period */
4570 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4572 else if (*d == '_') {
4573 /* underscore can't come after integer part */
4575 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4577 else if (isDIGIT(d[1])) {
4578 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4581 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4585 /* anything else after integer part is just invalid data */
4586 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4589 /* scan the fractional part after the decimal point*/
4591 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4592 /* strict or lax-but-not-the-end */
4593 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4596 while (isDIGIT(*d)) {
4598 if (*d == '.' && isDIGIT(d[-1])) {
4600 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4603 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4605 d = (char *)s; /* start all over again */
4607 goto dotted_decimal_version;
4611 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4614 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4616 if ( ! isDIGIT(d[1]) ) {
4617 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4625 version_prescan_finish:
4629 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4630 /* trailing non-numeric data */
4631 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4639 *ssaw_decimal = saw_decimal;
4646 =for apidoc scan_version
4648 Returns a pointer to the next character after the parsed
4649 version string, as well as upgrading the passed in SV to
4652 Function must be called with an already existing SV like
4655 s = scan_version(s, SV *sv, bool qv);
4657 Performs some preprocessing to the string to ensure that
4658 it has the correct characteristics of a version. Flags the
4659 object if it contains an underscore (which denotes this
4660 is an alpha version). The boolean qv denotes that the version
4661 should be interpreted as if it had multiple decimals, even if
4668 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4673 const char *errstr = NULL;
4674 int saw_decimal = 0;
4678 AV * const av = newAV();
4679 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4681 PERL_ARGS_ASSERT_SCAN_VERSION;
4683 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4685 #ifndef NODEFAULT_SHAREKEYS
4686 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4689 while (isSPACE(*s)) /* leading whitespace is OK */
4692 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4694 /* "undef" is a special case and not an error */
4695 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4696 Perl_croak(aTHX_ "%s", errstr);
4706 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4708 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4709 if ( !qv && width < 3 )
4710 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4712 while (isDIGIT(*pos))
4714 if (!isALPHA(*pos)) {
4720 /* this is atoi() that delimits on underscores */
4721 const char *end = pos;
4725 /* the following if() will only be true after the decimal
4726 * point of a version originally created with a bare
4727 * floating point number, i.e. not quoted in any way
4729 if ( !qv && s > start && saw_decimal == 1 ) {
4733 rev += (*s - '0') * mult;
4735 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4736 || (PERL_ABS(rev) > VERSION_MAX )) {
4737 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4738 "Integer overflow in version %d",VERSION_MAX);
4749 while (--end >= s) {
4751 rev += (*end - '0') * mult;
4753 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4754 || (PERL_ABS(rev) > VERSION_MAX )) {
4755 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4756 "Integer overflow in version");
4765 /* Append revision */
4766 av_push(av, newSViv(rev));
4771 else if ( *pos == '.' )
4773 else if ( *pos == '_' && isDIGIT(pos[1]) )
4775 else if ( *pos == ',' && isDIGIT(pos[1]) )
4777 else if ( isDIGIT(*pos) )
4784 while ( isDIGIT(*pos) )
4789 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4797 if ( qv ) { /* quoted versions always get at least three terms*/
4798 I32 len = av_len(av);
4799 /* This for loop appears to trigger a compiler bug on OS X, as it
4800 loops infinitely. Yes, len is negative. No, it makes no sense.
4801 Compiler in question is:
4802 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4803 for ( len = 2 - len; len > 0; len-- )
4804 av_push(MUTABLE_AV(sv), newSViv(0));
4808 av_push(av, newSViv(0));
4811 /* need to save off the current version string for later */
4813 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4814 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4815 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4817 else if ( s > start ) {
4818 SV * orig = newSVpvn(start,s-start);
4819 if ( qv && saw_decimal == 1 && *start != 'v' ) {
4820 /* need to insert a v to be consistent */
4821 sv_insert(orig, 0, 0, "v", 1);
4823 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4826 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4827 av_push(av, newSViv(0));
4830 /* And finally, store the AV in the hash */
4831 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4833 /* fix RT#19517 - special case 'undef' as string */
4834 if ( *s == 'u' && strEQ(s,"undef") ) {
4842 =for apidoc new_version
4844 Returns a new version object based on the passed in SV:
4846 SV *sv = new_version(SV *ver);
4848 Does not alter the passed in ver SV. See "upg_version" if you
4849 want to upgrade the SV.
4855 Perl_new_version(pTHX_ SV *ver)
4858 SV * const rv = newSV(0);
4859 PERL_ARGS_ASSERT_NEW_VERSION;
4860 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4863 AV * const av = newAV();
4865 /* This will get reblessed later if a derived class*/
4866 SV * const hv = newSVrv(rv, "version");
4867 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4868 #ifndef NODEFAULT_SHAREKEYS
4869 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4875 /* Begin copying all of the elements */
4876 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4877 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4879 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4880 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4882 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4884 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4885 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4888 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4890 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4891 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4894 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4895 /* This will get reblessed later if a derived class*/
4896 for ( key = 0; key <= av_len(sav); key++ )
4898 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4899 av_push(av, newSViv(rev));
4902 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4907 const MAGIC* const mg = SvVSTRING_mg(ver);
4908 if ( mg ) { /* already a v-string */
4909 const STRLEN len = mg->mg_len;
4910 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4911 sv_setpvn(rv,version,len);
4912 /* this is for consistency with the pure Perl class */
4913 if ( isDIGIT(*version) )
4914 sv_insert(rv, 0, 0, "v", 1);
4919 sv_setsv(rv,ver); /* make a duplicate */
4924 return upg_version(rv, FALSE);
4928 =for apidoc upg_version
4930 In-place upgrade of the supplied SV to a version object.
4932 SV *sv = upg_version(SV *sv, bool qv);
4934 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4935 to force this SV to be interpreted as an "extended" version.
4941 Perl_upg_version(pTHX_ SV *ver, bool qv)
4943 const char *version, *s;
4948 PERL_ARGS_ASSERT_UPG_VERSION;
4950 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4952 /* may get too much accuracy */
4954 #ifdef USE_LOCALE_NUMERIC
4955 char *loc = setlocale(LC_NUMERIC, "C");
4957 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4958 #ifdef USE_LOCALE_NUMERIC
4959 setlocale(LC_NUMERIC, loc);
4961 while (tbuf[len-1] == '0' && len > 0) len--;
4962 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4963 version = savepvn(tbuf, len);
4966 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4967 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4971 else /* must be a string or something like a string */
4974 version = savepv(SvPV(ver,len));
4976 # if PERL_VERSION > 5
4977 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4978 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4979 /* may be a v-string */
4980 char *testv = (char *)version;
4982 for (tlen=0; tlen < len; tlen++, testv++) {
4983 /* if one of the characters is non-text assume v-string */
4984 if (testv[0] < ' ') {
4985 SV * const nsv = sv_newmortal();
4988 int saw_decimal = 0;
4989 sv_setpvf(nsv,"v%vd",ver);
4990 pos = nver = savepv(SvPV_nolen(nsv));
4992 /* scan the resulting formatted string */
4993 pos++; /* skip the leading 'v' */
4994 while ( *pos == '.' || isDIGIT(*pos) ) {
5000 /* is definitely a v-string */
5001 if ( saw_decimal >= 2 ) {
5013 s = scan_version(version, ver, qv);
5015 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5016 "Version string '%s' contains invalid data; "
5017 "ignoring: '%s'", version, s);
5025 Validates that the SV contains valid internal structure for a version object.
5026 It may be passed either the version object (RV) or the hash itself (HV). If
5027 the structure is valid, it returns the HV. If the structure is invalid,
5030 SV *hv = vverify(sv);
5032 Note that it only confirms the bare minimum structure (so as not to get
5033 confused by derived classes which may contain additional hash entries):
5037 =item * The SV is an HV or a reference to an HV
5039 =item * The hash contains a "version" key
5041 =item * The "version" key has a reference to an AV as its value
5049 Perl_vverify(pTHX_ SV *vs)
5053 PERL_ARGS_ASSERT_VVERIFY;
5058 /* see if the appropriate elements exist */
5059 if ( SvTYPE(vs) == SVt_PVHV
5060 && hv_exists(MUTABLE_HV(vs), "version", 7)
5061 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
5062 && SvTYPE(sv) == SVt_PVAV )
5071 Accepts a version object and returns the normalized floating
5072 point representation. Call like:
5076 NOTE: you can pass either the object directly or the SV
5077 contained within the RV.
5079 The SV returned has a refcount of 1.
5085 Perl_vnumify(pTHX_ SV *vs)
5093 PERL_ARGS_ASSERT_VNUMIFY;
5095 /* extract the HV from the object */
5098 Perl_croak(aTHX_ "Invalid version object");
5100 /* see if various flags exist */
5101 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5103 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5104 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5109 /* attempt to retrieve the version array */
5110 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5111 return newSVpvs("0");
5117 return newSVpvs("0");
5120 digit = SvIV(*av_fetch(av, 0, 0));
5121 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5122 for ( i = 1 ; i < len ; i++ )
5124 digit = SvIV(*av_fetch(av, i, 0));
5126 const int denom = (width == 2 ? 10 : 100);
5127 const div_t term = div((int)PERL_ABS(digit),denom);
5128 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5131 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5137 digit = SvIV(*av_fetch(av, len, 0));
5138 if ( alpha && width == 3 ) /* alpha version */
5140 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5144 sv_catpvs(sv, "000");
5152 Accepts a version object and returns the normalized string
5153 representation. Call like:
5157 NOTE: you can pass either the object directly or the SV
5158 contained within the RV.
5160 The SV returned has a refcount of 1.
5166 Perl_vnormal(pTHX_ SV *vs)
5173 PERL_ARGS_ASSERT_VNORMAL;
5175 /* extract the HV from the object */
5178 Perl_croak(aTHX_ "Invalid version object");
5180 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5182 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5187 return newSVpvs("");
5189 digit = SvIV(*av_fetch(av, 0, 0));
5190 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5191 for ( i = 1 ; i < len ; i++ ) {
5192 digit = SvIV(*av_fetch(av, i, 0));
5193 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5198 /* handle last digit specially */
5199 digit = SvIV(*av_fetch(av, len, 0));
5201 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5203 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5206 if ( len <= 2 ) { /* short version, must be at least three */
5207 for ( len = 2 - len; len != 0; len-- )
5214 =for apidoc vstringify
5216 In order to maintain maximum compatibility with earlier versions
5217 of Perl, this function will return either the floating point
5218 notation or the multiple dotted notation, depending on whether
5219 the original version contained 1 or more dots, respectively.
5221 The SV returned has a refcount of 1.
5227 Perl_vstringify(pTHX_ SV *vs)
5229 PERL_ARGS_ASSERT_VSTRINGIFY;
5231 /* extract the HV from the object */
5234 Perl_croak(aTHX_ "Invalid version object");
5236 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
5238 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5242 return &PL_sv_undef;
5245 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5255 Version object aware cmp. Both operands must already have been
5256 converted into version objects.
5262 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5265 bool lalpha = FALSE;
5266 bool ralpha = FALSE;
5271 PERL_ARGS_ASSERT_VCMP;
5273 /* extract the HVs from the objects */
5276 if ( ! ( lhv && rhv ) )
5277 Perl_croak(aTHX_ "Invalid version object");
5279 /* get the left hand term */
5280 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5281 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5284 /* and the right hand term */
5285 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5286 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5294 while ( i <= m && retval == 0 )
5296 left = SvIV(*av_fetch(lav,i,0));
5297 right = SvIV(*av_fetch(rav,i,0));
5305 /* tiebreaker for alpha with identical terms */
5306 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5308 if ( lalpha && !ralpha )
5312 else if ( ralpha && !lalpha)
5318 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5322 while ( i <= r && retval == 0 )
5324 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5325 retval = -1; /* not a match after all */
5331 while ( i <= l && retval == 0 )
5333 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5334 retval = +1; /* not a match after all */
5342 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5343 # define EMULATE_SOCKETPAIR_UDP
5346 #ifdef EMULATE_SOCKETPAIR_UDP
5348 S_socketpair_udp (int fd[2]) {
5350 /* Fake a datagram socketpair using UDP to localhost. */
5351 int sockets[2] = {-1, -1};
5352 struct sockaddr_in addresses[2];
5354 Sock_size_t size = sizeof(struct sockaddr_in);
5355 unsigned short port;
5358 memset(&addresses, 0, sizeof(addresses));
5361 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5362 if (sockets[i] == -1)
5363 goto tidy_up_and_fail;
5365 addresses[i].sin_family = AF_INET;
5366 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5367 addresses[i].sin_port = 0; /* kernel choses port. */
5368 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5369 sizeof(struct sockaddr_in)) == -1)
5370 goto tidy_up_and_fail;
5373 /* Now have 2 UDP sockets. Find out which port each is connected to, and
5374 for each connect the other socket to it. */
5377 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5379 goto tidy_up_and_fail;
5380 if (size != sizeof(struct sockaddr_in))
5381 goto abort_tidy_up_and_fail;
5382 /* !1 is 0, !0 is 1 */
5383 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5384 sizeof(struct sockaddr_in)) == -1)
5385 goto tidy_up_and_fail;
5388 /* Now we have 2 sockets connected to each other. I don't trust some other
5389 process not to have already sent a packet to us (by random) so send
5390 a packet from each to the other. */
5393 /* I'm going to send my own port number. As a short.
5394 (Who knows if someone somewhere has sin_port as a bitfield and needs
5395 this routine. (I'm assuming crays have socketpair)) */
5396 port = addresses[i].sin_port;
5397 got = PerlLIO_write(sockets[i], &port, sizeof(port));
5398 if (got != sizeof(port)) {
5400 goto tidy_up_and_fail;
5401 goto abort_tidy_up_and_fail;
5405 /* Packets sent. I don't trust them to have arrived though.
5406 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5407 connect to localhost will use a second kernel thread. In 2.6 the
5408 first thread running the connect() returns before the second completes,
5409 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5410 returns 0. Poor programs have tripped up. One poor program's authors'
5411 had a 50-1 reverse stock split. Not sure how connected these were.)
5412 So I don't trust someone not to have an unpredictable UDP stack.
5416 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5417 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5421 FD_SET((unsigned int)sockets[0], &rset);
5422 FD_SET((unsigned int)sockets[1], &rset);
5424 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5425 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5426 || !FD_ISSET(sockets[1], &rset)) {
5427 /* I hope this is portable and appropriate. */
5429 goto tidy_up_and_fail;
5430 goto abort_tidy_up_and_fail;
5434 /* And the paranoia department even now doesn't trust it to have arrive
5435 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5437 struct sockaddr_in readfrom;
5438 unsigned short buffer[2];
5443 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5444 sizeof(buffer), MSG_DONTWAIT,
5445 (struct sockaddr *) &readfrom, &size);
5447 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5449 (struct sockaddr *) &readfrom, &size);
5453 goto tidy_up_and_fail;
5454 if (got != sizeof(port)
5455 || size != sizeof(struct sockaddr_in)
5456 /* Check other socket sent us its port. */
5457 || buffer[0] != (unsigned short) addresses[!i].sin_port
5458 /* Check kernel says we got the datagram from that socket */
5459 || readfrom.sin_family != addresses[!i].sin_family
5460 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5461 || readfrom.sin_port != addresses[!i].sin_port)
5462 goto abort_tidy_up_and_fail;
5465 /* My caller (my_socketpair) has validated that this is non-NULL */
5468 /* I hereby declare this connection open. May God bless all who cross
5472 abort_tidy_up_and_fail:
5473 errno = ECONNABORTED;
5477 if (sockets[0] != -1)
5478 PerlLIO_close(sockets[0]);
5479 if (sockets[1] != -1)
5480 PerlLIO_close(sockets[1]);
5485 #endif /* EMULATE_SOCKETPAIR_UDP */
5487 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5489 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5490 /* Stevens says that family must be AF_LOCAL, protocol 0.
5491 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
5496 struct sockaddr_in listen_addr;
5497 struct sockaddr_in connect_addr;
5502 || family != AF_UNIX
5505 errno = EAFNOSUPPORT;
5513 #ifdef EMULATE_SOCKETPAIR_UDP
5514 if (type == SOCK_DGRAM)
5515 return S_socketpair_udp(fd);
5518 listener = PerlSock_socket(AF_INET, type, 0);
5521 memset(&listen_addr, 0, sizeof(listen_addr));
5522 listen_addr.sin_family = AF_INET;
5523 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5524 listen_addr.sin_port = 0; /* kernel choses port. */
5525 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5526 sizeof(listen_addr)) == -1)
5527 goto tidy_up_and_fail;
5528 if (PerlSock_listen(listener, 1) == -1)
5529 goto tidy_up_and_fail;
5531 connector = PerlSock_socket(AF_INET, type, 0);
5532 if (connector == -1)
5533 goto tidy_up_and_fail;
5534 /* We want to find out the port number to connect to. */
5535 size = sizeof(connect_addr);
5536 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5538 goto tidy_up_and_fail;
5539 if (size != sizeof(connect_addr))
5540 goto abort_tidy_up_and_fail;
5541 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5542 sizeof(connect_addr)) == -1)
5543 goto tidy_up_and_fail;
5545 size = sizeof(listen_addr);
5546 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5549 goto tidy_up_and_fail;
5550 if (size != sizeof(listen_addr))
5551 goto abort_tidy_up_and_fail;
5552 PerlLIO_close(listener);
5553 /* Now check we are talking to ourself by matching port and host on the
5555 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5557 goto tidy_up_and_fail;
5558 if (size != sizeof(connect_addr)
5559 || listen_addr.sin_family != connect_addr.sin_family
5560 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5561 || listen_addr.sin_port != connect_addr.sin_port) {
5562 goto abort_tidy_up_and_fail;
5568 abort_tidy_up_and_fail:
5570 errno = ECONNABORTED; /* This would be the standard thing to do. */
5572 # ifdef ECONNREFUSED
5573 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5575 errno = ETIMEDOUT; /* Desperation time. */
5582 PerlLIO_close(listener);
5583 if (connector != -1)
5584 PerlLIO_close(connector);
5586 PerlLIO_close(acceptor);
5592 /* In any case have a stub so that there's code corresponding
5593 * to the my_socketpair in embed.fnc. */
5595 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5596 #ifdef HAS_SOCKETPAIR
5597 return socketpair(family, type, protocol, fd);
5606 =for apidoc sv_nosharing
5608 Dummy routine which "shares" an SV when there is no sharing module present.
5609 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5610 Exists to avoid test for a NULL function pointer and because it could
5611 potentially warn under some level of strict-ness.
5617 Perl_sv_nosharing(pTHX_ SV *sv)
5619 PERL_UNUSED_CONTEXT;
5620 PERL_UNUSED_ARG(sv);
5625 =for apidoc sv_destroyable
5627 Dummy routine which reports that object can be destroyed when there is no
5628 sharing module present. It ignores its single SV argument, and returns
5629 'true'. Exists to avoid test for a NULL function pointer and because it
5630 could potentially warn under some level of strict-ness.
5636 Perl_sv_destroyable(pTHX_ SV *sv)
5638 PERL_UNUSED_CONTEXT;
5639 PERL_UNUSED_ARG(sv);
5644 Perl_parse_unicode_opts(pTHX_ const char **popt)
5646 const char *p = *popt;
5649 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5653 opt = (U32) atoi(p);
5656 if (*p && *p != '\n' && *p != '\r') {
5657 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5659 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5665 case PERL_UNICODE_STDIN:
5666 opt |= PERL_UNICODE_STDIN_FLAG; break;
5667 case PERL_UNICODE_STDOUT:
5668 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5669 case PERL_UNICODE_STDERR:
5670 opt |= PERL_UNICODE_STDERR_FLAG; break;
5671 case PERL_UNICODE_STD:
5672 opt |= PERL_UNICODE_STD_FLAG; break;
5673 case PERL_UNICODE_IN:
5674 opt |= PERL_UNICODE_IN_FLAG; break;
5675 case PERL_UNICODE_OUT:
5676 opt |= PERL_UNICODE_OUT_FLAG; break;
5677 case PERL_UNICODE_INOUT:
5678 opt |= PERL_UNICODE_INOUT_FLAG; break;
5679 case PERL_UNICODE_LOCALE:
5680 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5681 case PERL_UNICODE_ARGV:
5682 opt |= PERL_UNICODE_ARGV_FLAG; break;
5683 case PERL_UNICODE_UTF8CACHEASSERT:
5684 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5686 if (*p != '\n' && *p != '\r') {
5687 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5690 "Unknown Unicode option letter '%c'", *p);
5697 opt = PERL_UNICODE_DEFAULT_FLAGS;
5699 the_end_of_the_opts_parser:
5701 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5702 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5703 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5715 * This is really just a quick hack which grabs various garbage
5716 * values. It really should be a real hash algorithm which
5717 * spreads the effect of every input bit onto every output bit,
5718 * if someone who knows about such things would bother to write it.
5719 * Might be a good idea to add that function to CORE as well.
5720 * No numbers below come from careful analysis or anything here,
5721 * except they are primes and SEED_C1 > 1E6 to get a full-width
5722 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5723 * probably be bigger too.
5726 # define SEED_C1 1000003
5727 #define SEED_C4 73819
5729 # define SEED_C1 25747
5730 #define SEED_C4 20639
5734 #define SEED_C5 26107
5736 #ifndef PERL_NO_DEV_RANDOM
5741 # include <starlet.h>
5742 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5743 * in 100-ns units, typically incremented ever 10 ms. */
5744 unsigned int when[2];
5746 # ifdef HAS_GETTIMEOFDAY
5747 struct timeval when;
5753 /* This test is an escape hatch, this symbol isn't set by Configure. */
5754 #ifndef PERL_NO_DEV_RANDOM
5755 #ifndef PERL_RANDOM_DEVICE
5756 /* /dev/random isn't used by default because reads from it will block
5757 * if there isn't enough entropy available. You can compile with
5758 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5759 * is enough real entropy to fill the seed. */
5760 # define PERL_RANDOM_DEVICE "/dev/urandom"
5762 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5764 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5773 _ckvmssts(sys$gettim(when));
5774 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5776 # ifdef HAS_GETTIMEOFDAY
5777 PerlProc_gettimeofday(&when,NULL);
5778 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5781 u = (U32)SEED_C1 * when;
5784 u += SEED_C3 * (U32)PerlProc_getpid();
5785 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5786 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5787 u += SEED_C5 * (U32)PTR2UV(&when);
5793 Perl_get_hash_seed(pTHX)
5796 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5802 if (s && isDIGIT(*s))
5803 myseed = (UV)Atoul(s);
5805 #ifdef USE_HASH_SEED_EXPLICIT
5809 /* Compute a random seed */
5810 (void)seedDrand01((Rand_seed_t)seed());
5811 myseed = (UV)(Drand01() * (NV)UV_MAX);
5812 #if RANDBITS < (UVSIZE * 8)
5813 /* Since there are not enough randbits to to reach all
5814 * the bits of a UV, the low bits might need extra
5815 * help. Sum in another random number that will
5816 * fill in the low bits. */
5818 (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5819 #endif /* RANDBITS < (UVSIZE * 8) */
5820 if (myseed == 0) { /* Superparanoia. */
5821 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5823 Perl_croak(aTHX_ "Your random numbers are not that random");
5826 PL_rehash_seed_set = TRUE;
5833 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5835 const char * stashpv = CopSTASHPV(c);
5836 const char * name = HvNAME_get(hv);
5837 PERL_UNUSED_CONTEXT;
5838 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5840 if (!stashpv || !name)
5841 return stashpv == name;
5842 if ( HvNAMEUTF8(hv) && !(CopSTASH_flags(c) & SVf_UTF8 ? 1 : 0) ) {
5843 if (CopSTASH_flags(c) & SVf_UTF8) {
5844 return (bytes_cmp_utf8(
5845 (const U8*)stashpv, strlen(stashpv),
5846 (const U8*)name, HEK_LEN(HvNAME_HEK(hv))) == 0);
5848 return (bytes_cmp_utf8(
5849 (const U8*)name, HEK_LEN(HvNAME_HEK(hv)),
5850 (const U8*)stashpv, strlen(stashpv)) == 0);
5854 return (stashpv == name
5855 || strEQ(stashpv, name));
5861 #ifdef PERL_GLOBAL_STRUCT
5863 #define PERL_GLOBAL_STRUCT_INIT
5864 #include "opcode.h" /* the ppaddr and check */
5867 Perl_init_global_struct(pTHX)
5869 struct perl_vars *plvarsp = NULL;
5870 # ifdef PERL_GLOBAL_STRUCT
5871 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5872 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5873 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5874 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5875 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5879 plvarsp = PL_VarsPtr;
5880 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5885 # define PERLVAR(prefix,var,type) /**/
5886 # define PERLVARA(prefix,var,n,type) /**/
5887 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5888 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5889 # include "perlvars.h"
5894 # ifdef PERL_GLOBAL_STRUCT
5897 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5898 if (!plvarsp->Gppaddr)
5902 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5903 if (!plvarsp->Gcheck)
5905 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5906 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5908 # ifdef PERL_SET_VARS
5909 PERL_SET_VARS(plvarsp);
5911 # undef PERL_GLOBAL_STRUCT_INIT
5916 #endif /* PERL_GLOBAL_STRUCT */
5918 #ifdef PERL_GLOBAL_STRUCT
5921 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5923 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5924 # ifdef PERL_GLOBAL_STRUCT
5925 # ifdef PERL_UNSET_VARS
5926 PERL_UNSET_VARS(plvarsp);
5928 free(plvarsp->Gppaddr);
5929 free(plvarsp->Gcheck);
5930 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5936 #endif /* PERL_GLOBAL_STRUCT */
5940 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5941 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5942 * given, and you supply your own implementation.
5944 * The default implementation reads a single env var, PERL_MEM_LOG,
5945 * expecting one or more of the following:
5947 * \d+ - fd fd to write to : must be 1st (atoi)
5948 * 'm' - memlog was PERL_MEM_LOG=1
5949 * 's' - svlog was PERL_SV_LOG=1
5950 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5952 * This makes the logger controllable enough that it can reasonably be
5953 * added to the system perl.
5956 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5957 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5959 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5961 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5962 * writes to. In the default logger, this is settable at runtime.
5964 #ifndef PERL_MEM_LOG_FD
5965 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5968 #ifndef PERL_MEM_LOG_NOIMPL
5970 # ifdef DEBUG_LEAKING_SCALARS
5971 # define SV_LOG_SERIAL_FMT " [%lu]"
5972 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5974 # define SV_LOG_SERIAL_FMT
5975 # define _SV_LOG_SERIAL_ARG(sv)
5979 S_mem_log_common(enum mem_log_type mlt, const UV n,
5980 const UV typesize, const char *type_name, const SV *sv,
5981 Malloc_t oldalloc, Malloc_t newalloc,
5982 const char *filename, const int linenumber,
5983 const char *funcname)
5987 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5989 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5992 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5994 /* We can't use SVs or PerlIO for obvious reasons,
5995 * so we'll use stdio and low-level IO instead. */
5996 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5998 # ifdef HAS_GETTIMEOFDAY
5999 # define MEM_LOG_TIME_FMT "%10d.%06d: "
6000 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
6002 gettimeofday(&tv, 0);
6004 # define MEM_LOG_TIME_FMT "%10d: "
6005 # define MEM_LOG_TIME_ARG (int)when
6009 /* If there are other OS specific ways of hires time than
6010 * gettimeofday() (see ext/Time-HiRes), the easiest way is
6011 * probably that they would be used to fill in the struct
6015 int fd = atoi(pmlenv);
6017 fd = PERL_MEM_LOG_FD;
6019 if (strchr(pmlenv, 't')) {
6020 len = my_snprintf(buf, sizeof(buf),
6021 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
6022 PerlLIO_write(fd, buf, len);
6026 len = my_snprintf(buf, sizeof(buf),
6027 "alloc: %s:%d:%s: %"IVdf" %"UVuf
6028 " %s = %"IVdf": %"UVxf"\n",
6029 filename, linenumber, funcname, n, typesize,
6030 type_name, n * typesize, PTR2UV(newalloc));
6033 len = my_snprintf(buf, sizeof(buf),
6034 "realloc: %s:%d:%s: %"IVdf" %"UVuf
6035 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
6036 filename, linenumber, funcname, n, typesize,
6037 type_name, n * typesize, PTR2UV(oldalloc),
6041 len = my_snprintf(buf, sizeof(buf),
6042 "free: %s:%d:%s: %"UVxf"\n",
6043 filename, linenumber, funcname,
6048 len = my_snprintf(buf, sizeof(buf),
6049 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
6050 mlt == MLT_NEW_SV ? "new" : "del",
6051 filename, linenumber, funcname,
6052 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
6057 PerlLIO_write(fd, buf, len);
6061 #endif /* !PERL_MEM_LOG_NOIMPL */
6063 #ifndef PERL_MEM_LOG_NOIMPL
6065 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
6066 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
6068 /* this is suboptimal, but bug compatible. User is providing their
6069 own implementation, but is getting these functions anyway, and they
6070 do nothing. But _NOIMPL users should be able to cope or fix */
6072 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
6073 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
6077 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
6079 const char *filename, const int linenumber,
6080 const char *funcname)
6082 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6083 NULL, NULL, newalloc,
6084 filename, linenumber, funcname);
6089 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6090 Malloc_t oldalloc, Malloc_t newalloc,
6091 const char *filename, const int linenumber,
6092 const char *funcname)
6094 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6095 NULL, oldalloc, newalloc,
6096 filename, linenumber, funcname);
6101 Perl_mem_log_free(Malloc_t oldalloc,
6102 const char *filename, const int linenumber,
6103 const char *funcname)
6105 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6106 filename, linenumber, funcname);
6111 Perl_mem_log_new_sv(const SV *sv,
6112 const char *filename, const int linenumber,
6113 const char *funcname)
6115 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6116 filename, linenumber, funcname);
6120 Perl_mem_log_del_sv(const SV *sv,
6121 const char *filename, const int linenumber,
6122 const char *funcname)
6124 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6125 filename, linenumber, funcname);
6128 #endif /* PERL_MEM_LOG */
6131 =for apidoc my_sprintf
6133 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6134 the length of the string written to the buffer. Only rare pre-ANSI systems
6135 need the wrapper function - usually this is a direct call to C<sprintf>.
6139 #ifndef SPRINTF_RETURNS_STRLEN
6141 Perl_my_sprintf(char *buffer, const char* pat, ...)
6144 PERL_ARGS_ASSERT_MY_SPRINTF;
6145 va_start(args, pat);
6146 vsprintf(buffer, pat, args);
6148 return strlen(buffer);
6153 =for apidoc my_snprintf
6155 The C library C<snprintf> functionality, if available and
6156 standards-compliant (uses C<vsnprintf>, actually). However, if the
6157 C<vsnprintf> is not available, will unfortunately use the unsafe
6158 C<vsprintf> which can overrun the buffer (there is an overrun check,
6159 but that may be too late). Consider using C<sv_vcatpvf> instead, or
6160 getting C<vsnprintf>.
6165 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6170 PERL_ARGS_ASSERT_MY_SNPRINTF;
6171 va_start(ap, format);
6172 #ifdef HAS_VSNPRINTF
6173 retval = vsnprintf(buffer, len, format, ap);
6175 retval = vsprintf(buffer, format, ap);
6178 /* vsprintf() shows failure with < 0 */
6180 #ifdef HAS_VSNPRINTF
6181 /* vsnprintf() shows failure with >= len */
6183 (len > 0 && (Size_t)retval >= len)
6186 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6191 =for apidoc my_vsnprintf
6193 The C library C<vsnprintf> if available and standards-compliant.
6194 However, if if the C<vsnprintf> is not available, will unfortunately
6195 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6196 overrun check, but that may be too late). Consider using
6197 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6202 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6209 PERL_ARGS_ASSERT_MY_VSNPRINTF;
6211 Perl_va_copy(ap, apc);
6212 # ifdef HAS_VSNPRINTF
6213 retval = vsnprintf(buffer, len, format, apc);
6215 retval = vsprintf(buffer, format, apc);
6218 # ifdef HAS_VSNPRINTF
6219 retval = vsnprintf(buffer, len, format, ap);
6221 retval = vsprintf(buffer, format, ap);
6223 #endif /* #ifdef NEED_VA_COPY */
6224 /* vsprintf() shows failure with < 0 */
6226 #ifdef HAS_VSNPRINTF
6227 /* vsnprintf() shows failure with >= len */
6229 (len > 0 && (Size_t)retval >= len)
6232 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6237 Perl_my_clearenv(pTHX)
6240 #if ! defined(PERL_MICRO)
6241 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6243 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6244 # if defined(USE_ENVIRON_ARRAY)
6245 # if defined(USE_ITHREADS)
6246 /* only the parent thread can clobber the process environment */
6247 if (PL_curinterp == aTHX)
6248 # endif /* USE_ITHREADS */
6250 # if ! defined(PERL_USE_SAFE_PUTENV)
6251 if ( !PL_use_safe_putenv) {
6253 if (environ == PL_origenviron)
6254 environ = (char**)safesysmalloc(sizeof(char*));
6256 for (i = 0; environ[i]; i++)
6257 (void)safesysfree(environ[i]);
6260 # else /* PERL_USE_SAFE_PUTENV */
6261 # if defined(HAS_CLEARENV)
6263 # elif defined(HAS_UNSETENV)
6264 int bsiz = 80; /* Most envvar names will be shorter than this. */
6265 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6266 char *buf = (char*)safesysmalloc(bufsiz);
6267 while (*environ != NULL) {
6268 char *e = strchr(*environ, '=');
6269 int l = e ? e - *environ : (int)strlen(*environ);
6271 (void)safesysfree(buf);
6272 bsiz = l + 1; /* + 1 for the \0. */
6273 buf = (char*)safesysmalloc(bufsiz);
6275 memcpy(buf, *environ, l);
6277 (void)unsetenv(buf);
6279 (void)safesysfree(buf);
6280 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6281 /* Just null environ and accept the leakage. */
6283 # endif /* HAS_CLEARENV || HAS_UNSETENV */
6284 # endif /* ! PERL_USE_SAFE_PUTENV */
6286 # endif /* USE_ENVIRON_ARRAY */
6287 # endif /* PERL_IMPLICIT_SYS || WIN32 */
6288 #endif /* PERL_MICRO */
6291 #ifdef PERL_IMPLICIT_CONTEXT
6293 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6294 the global PL_my_cxt_index is incremented, and that value is assigned to
6295 that module's static my_cxt_index (who's address is passed as an arg).
6296 Then, for each interpreter this function is called for, it makes sure a
6297 void* slot is available to hang the static data off, by allocating or
6298 extending the interpreter's PL_my_cxt_list array */
6300 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6302 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6306 PERL_ARGS_ASSERT_MY_CXT_INIT;
6308 /* this module hasn't been allocated an index yet */
6309 #if defined(USE_ITHREADS)
6310 MUTEX_LOCK(&PL_my_ctx_mutex);
6312 *index = PL_my_cxt_index++;
6313 #if defined(USE_ITHREADS)
6314 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6318 /* make sure the array is big enough */
6319 if (PL_my_cxt_size <= *index) {
6320 if (PL_my_cxt_size) {
6321 while (PL_my_cxt_size <= *index)
6322 PL_my_cxt_size *= 2;
6323 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6326 PL_my_cxt_size = 16;
6327 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6330 /* newSV() allocates one more than needed */
6331 p = (void*)SvPVX(newSV(size-1));
6332 PL_my_cxt_list[*index] = p;
6333 Zero(p, size, char);
6337 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6340 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6345 PERL_ARGS_ASSERT_MY_CXT_INDEX;
6347 for (index = 0; index < PL_my_cxt_index; index++) {
6348 const char *key = PL_my_cxt_keys[index];
6349 /* try direct pointer compare first - there are chances to success,
6350 * and it's much faster.
6352 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6359 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6365 PERL_ARGS_ASSERT_MY_CXT_INIT;
6367 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6369 /* this module hasn't been allocated an index yet */
6370 #if defined(USE_ITHREADS)
6371 MUTEX_LOCK(&PL_my_ctx_mutex);
6373 index = PL_my_cxt_index++;
6374 #if defined(USE_ITHREADS)
6375 MUTEX_UNLOCK(&PL_my_ctx_mutex);
6379 /* make sure the array is big enough */
6380 if (PL_my_cxt_size <= index) {
6381 int old_size = PL_my_cxt_size;
6383 if (PL_my_cxt_size) {
6384 while (PL_my_cxt_size <= index)
6385 PL_my_cxt_size *= 2;
6386 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6387 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6390 PL_my_cxt_size = 16;
6391 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6392 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6394 for (i = old_size; i < PL_my_cxt_size; i++) {
6395 PL_my_cxt_keys[i] = 0;
6396 PL_my_cxt_list[i] = 0;
6399 PL_my_cxt_keys[index] = my_cxt_key;
6400 /* newSV() allocates one more than needed */
6401 p = (void*)SvPVX(newSV(size-1));
6402 PL_my_cxt_list[index] = p;
6403 Zero(p, size, char);
6406 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6407 #endif /* PERL_IMPLICIT_CONTEXT */
6410 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
6414 const char *vn = NULL;
6415 SV *const module = PL_stack_base[ax];
6417 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
6419 if (items >= 2) /* version supplied as bootstrap arg */
6420 sv = PL_stack_base[ax + 1];
6422 /* XXX GV_ADDWARN */
6424 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6425 if (!sv || !SvOK(sv)) {
6427 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6431 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
6432 SV *pmsv = sv_derived_from(sv, "version")
6433 ? sv : sv_2mortal(new_version(sv));
6434 xssv = upg_version(xssv, 0);
6435 if ( vcmp(pmsv,xssv) ) {
6436 SV *string = vstringify(xssv);
6437 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
6438 " does not match ", module, string);
6440 SvREFCNT_dec(string);
6441 string = vstringify(pmsv);
6444 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
6447 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6449 SvREFCNT_dec(string);
6451 Perl_sv_2mortal(aTHX_ xpt);
6452 Perl_croak_sv(aTHX_ xpt);
6458 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6462 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6465 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6467 /* This might croak */
6468 compver = upg_version(compver, 0);
6469 /* This should never croak */
6470 runver = new_version(PL_apiversion);
6471 if (vcmp(compver, runver)) {
6472 SV *compver_string = vstringify(compver);
6473 SV *runver_string = vstringify(runver);
6474 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6475 " of %"SVf" does not match %"SVf,
6476 compver_string, module, runver_string);
6477 Perl_sv_2mortal(aTHX_ xpt);
6479 SvREFCNT_dec(compver_string);
6480 SvREFCNT_dec(runver_string);
6482 SvREFCNT_dec(runver);
6484 Perl_croak_sv(aTHX_ xpt);
6489 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6491 Size_t used, length, copy;
6494 length = strlen(src);
6495 if (size > 0 && used < size - 1) {
6496 copy = (length >= size - used) ? size - used - 1 : length;
6497 memcpy(dst + used, src, copy);
6498 dst[used + copy] = '\0';
6500 return used + length;
6506 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6508 Size_t length, copy;
6510 length = strlen(src);
6512 copy = (length >= size) ? size - 1 : length;
6513 memcpy(dst, src, copy);
6520 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6521 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6522 long _ftol( double ); /* Defined by VC6 C libs. */
6523 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6527 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6530 SV * const dbsv = GvSVn(PL_DBsub);
6531 const bool save_taint = PL_tainted;
6533 /* We do not care about using sv to call CV;
6534 * it's for informational purposes only.
6537 PERL_ARGS_ASSERT_GET_DB_SUB;
6541 if (!PERLDB_SUB_NN) {
6544 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6545 || strEQ(GvNAME(gv), "END")
6546 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6547 !( (SvTYPE(*svp) == SVt_PVGV)
6548 && (GvCV((const GV *)*svp) == cv)
6549 && (gv = (GV *)*svp)
6553 /* Use GV from the stack as a fallback. */
6554 /* GV is potentially non-unique, or contain different CV. */
6555 SV * const tmp = newRV(MUTABLE_SV(cv));
6556 sv_setsv(dbsv, tmp);
6560 gv_efullname3(dbsv, gv, NULL);
6564 const int type = SvTYPE(dbsv);
6565 if (type < SVt_PVIV && type != SVt_IV)
6566 sv_upgrade(dbsv, SVt_PVIV);
6567 (void)SvIOK_on(dbsv);
6568 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6570 TAINT_IF(save_taint);
6574 Perl_my_dirfd(pTHX_ DIR * dir) {
6576 /* Most dirfd implementations have problems when passed NULL. */
6581 #elif defined(HAS_DIR_DD_FD)
6584 Perl_die(aTHX_ PL_no_func, "dirfd");
6591 Perl_get_re_arg(pTHX_ SV *sv) {
6597 sv = MUTABLE_SV(SvRV(sv));
6598 if (SvTYPE(sv) == SVt_REGEXP)
6599 return (REGEXP*) sv;
6607 * c-indentation-style: bsd
6609 * indent-tabs-mode: t
6612 * ex: set ts=8 sts=4 sw=4 noet: