3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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
16 /* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
23 #define PERL_IN_UTIL_C
29 # define SIG_ERR ((Sighandler_t) -1)
34 /* Missing protos on LynxOS */
39 # include <sys/wait.h>
44 # include <sys/select.h>
50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51 # define FD_CLOEXEC 1 /* NeXT needs this */
54 /* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
64 /* Can't use PerlIO to write as it allocates memory */
65 PerlLIO_write(PerlIO_fileno(Perl_error_log),
66 PL_no_mem, strlen(PL_no_mem));
68 NORETURN_FUNCTION_END;
71 /* paranoid version of system's malloc() */
74 Perl_safesysmalloc(MEM_SIZE size)
80 PerlIO_printf(Perl_error_log,
81 "Allocation too large: %lx\n", size) FLUSH;
84 #endif /* HAS_64K_LIMIT */
85 #ifdef PERL_TRACK_MEMPOOL
90 Perl_croak_nocontext("panic: malloc");
92 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
93 PERL_ALLOC_CHECK(ptr);
94 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
96 #ifdef PERL_TRACK_MEMPOOL
97 struct perl_memory_debug_header *const header
98 = (struct perl_memory_debug_header *)ptr;
102 PoisonNew(((char *)ptr), size, char);
105 #ifdef PERL_TRACK_MEMPOOL
106 header->interpreter = aTHX;
107 /* Link us into the list. */
108 header->prev = &PL_memory_debug_header;
109 header->next = PL_memory_debug_header.next;
110 PL_memory_debug_header.next = header;
111 header->next->prev = header;
115 ptr = (Malloc_t)((char*)ptr+sTHX);
122 return write_no_mem();
127 /* paranoid version of system's realloc() */
130 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
134 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
135 Malloc_t PerlMem_realloc();
136 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
140 PerlIO_printf(Perl_error_log,
141 "Reallocation too large: %lx\n", size) FLUSH;
144 #endif /* HAS_64K_LIMIT */
151 return safesysmalloc(size);
152 #ifdef PERL_TRACK_MEMPOOL
153 where = (Malloc_t)((char*)where-sTHX);
156 struct perl_memory_debug_header *const header
157 = (struct perl_memory_debug_header *)where;
159 if (header->interpreter != aTHX) {
160 Perl_croak_nocontext("panic: realloc from wrong pool");
162 assert(header->next->prev == header);
163 assert(header->prev->next == header);
165 if (header->size > size) {
166 const MEM_SIZE freed_up = header->size - size;
167 char *start_of_freed = ((char *)where) + size;
168 PoisonFree(start_of_freed, freed_up, char);
176 Perl_croak_nocontext("panic: realloc");
178 ptr = (Malloc_t)PerlMem_realloc(where,size);
179 PERL_ALLOC_CHECK(ptr);
181 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
182 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
185 #ifdef PERL_TRACK_MEMPOOL
186 struct perl_memory_debug_header *const header
187 = (struct perl_memory_debug_header *)ptr;
190 if (header->size < size) {
191 const MEM_SIZE fresh = size - header->size;
192 char *start_of_fresh = ((char *)ptr) + size;
193 PoisonNew(start_of_fresh, fresh, char);
197 header->next->prev = header;
198 header->prev->next = header;
200 ptr = (Malloc_t)((char*)ptr+sTHX);
207 return write_no_mem();
212 /* safe version of system's free() */
215 Perl_safesysfree(Malloc_t where)
217 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
222 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
224 #ifdef PERL_TRACK_MEMPOOL
225 where = (Malloc_t)((char*)where-sTHX);
227 struct perl_memory_debug_header *const header
228 = (struct perl_memory_debug_header *)where;
230 if (header->interpreter != aTHX) {
231 Perl_croak_nocontext("panic: free from wrong pool");
234 Perl_croak_nocontext("panic: duplicate free");
236 if (!(header->next) || header->next->prev != header
237 || header->prev->next != header) {
238 Perl_croak_nocontext("panic: bad free");
240 /* Unlink us from the chain. */
241 header->next->prev = header->prev;
242 header->prev->next = header->next;
244 PoisonNew(where, header->size, char);
246 /* Trigger the duplicate free warning. */
254 /* safe version of system's calloc() */
257 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
261 MEM_SIZE total_size = 0;
263 /* Even though calloc() for zero bytes is strange, be robust. */
264 if (size && (count <= MEM_SIZE_MAX / size))
265 total_size = size * count;
267 Perl_croak_nocontext(PL_memory_wrap);
268 #ifdef PERL_TRACK_MEMPOOL
269 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
272 Perl_croak_nocontext(PL_memory_wrap);
275 if (total_size > 0xffff) {
276 PerlIO_printf(Perl_error_log,
277 "Allocation too large: %lx\n", total_size) FLUSH;
280 #endif /* HAS_64K_LIMIT */
282 if ((long)size < 0 || (long)count < 0)
283 Perl_croak_nocontext("panic: calloc");
285 #ifdef PERL_TRACK_MEMPOOL
286 /* Have to use malloc() because we've added some space for our tracking
288 /* malloc(0) is non-portable. */
289 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
291 /* Use calloc() because it might save a memset() if the memory is fresh
292 and clean from the OS. */
294 ptr = (Malloc_t)PerlMem_calloc(count, size);
295 else /* calloc(0) is non-portable. */
296 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
298 PERL_ALLOC_CHECK(ptr);
299 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));
301 #ifdef PERL_TRACK_MEMPOOL
303 struct perl_memory_debug_header *const header
304 = (struct perl_memory_debug_header *)ptr;
306 memset((void*)ptr, 0, total_size);
307 header->interpreter = aTHX;
308 /* Link us into the list. */
309 header->prev = &PL_memory_debug_header;
310 header->next = PL_memory_debug_header.next;
311 PL_memory_debug_header.next = header;
312 header->next->prev = header;
314 header->size = total_size;
316 ptr = (Malloc_t)((char*)ptr+sTHX);
323 return write_no_mem();
326 /* These must be defined when not using Perl's malloc for binary
331 Malloc_t Perl_malloc (MEM_SIZE nbytes)
334 return (Malloc_t)PerlMem_malloc(nbytes);
337 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
340 return (Malloc_t)PerlMem_calloc(elements, size);
343 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
346 return (Malloc_t)PerlMem_realloc(where, nbytes);
349 Free_t Perl_mfree (Malloc_t where)
357 /* copy a string up to some (non-backslashed) delimiter, if any */
360 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
365 for (tolen = 0; from < fromend; from++, tolen++) {
367 if (from[1] != delim) {
374 else if (*from == delim)
385 /* return ptr to little string in big string, NULL if not found */
386 /* This routine was donated by Corey Satten. */
389 Perl_instr(pTHX_ register const char *big, register const char *little)
400 register const char *s, *x;
403 for (x=big,s=little; *s; /**/ ) {
414 return (char*)(big-1);
419 /* same as instr but allow embedded nulls */
422 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
428 char first = *little++;
430 bigend -= lend - little;
432 while (big <= bigend) {
433 if (*big++ == first) {
434 for (x=big,s=little; s < lend; x++,s++) {
438 return (char*)(big-1);
445 /* reverse of the above--find last substring */
448 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
450 register const char *bigbeg;
451 register const I32 first = *little;
452 register const char * const littleend = lend;
455 if (little >= littleend)
456 return (char*)bigend;
458 big = bigend - (littleend - little++);
459 while (big >= bigbeg) {
460 register const char *s, *x;
463 for (x=big+2,s=little; s < littleend; /**/ ) {
472 return (char*)(big+1);
477 /* As a space optimization, we do not compile tables for strings of length
478 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
479 special-cased in fbm_instr().
481 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
484 =head1 Miscellaneous Functions
486 =for apidoc fbm_compile
488 Analyses the string in order to make fast searches on it using fbm_instr()
489 -- the Boyer-Moore algorithm.
495 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
498 register const U8 *s;
504 if (flags & FBMcf_TAIL) {
505 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
506 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
507 if (mg && mg->mg_len >= 0)
510 s = (U8*)SvPV_force_mutable(sv, len);
511 if (len == 0) /* TAIL might be on a zero-length string. */
513 SvUPGRADE(sv, SVt_PVGV);
518 const unsigned char *sb;
519 const U8 mlen = (len>255) ? 255 : (U8)len;
522 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
524 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
525 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
526 memset((void*)table, mlen, 256);
528 sb = s - mlen + 1; /* first char (maybe) */
530 if (table[*s] == mlen)
535 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
537 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
539 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
540 for (i = 0; i < len; i++) {
541 if (PL_freq[s[i]] < frequency) {
543 frequency = PL_freq[s[i]];
546 BmFLAGS(sv) = (U8)flags;
547 BmRARE(sv) = s[rarest];
548 BmPREVIOUS(sv) = rarest;
549 BmUSEFUL(sv) = 100; /* Initial value */
550 if (flags & FBMcf_TAIL)
552 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
553 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
556 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
557 /* If SvTAIL is actually due to \Z or \z, this gives false positives
561 =for apidoc fbm_instr
563 Returns the location of the SV in the string delimited by C<str> and
564 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
565 does not have to be fbm_compiled, but the search will not be as fast
572 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
574 register unsigned char *s;
576 register const unsigned char *little
577 = (const unsigned char *)SvPV_const(littlestr,l);
578 register STRLEN littlelen = l;
579 register const I32 multiline = flags & FBMrf_MULTILINE;
581 if ((STRLEN)(bigend - big) < littlelen) {
582 if ( SvTAIL(littlestr)
583 && ((STRLEN)(bigend - big) == littlelen - 1)
585 || (*big == *little &&
586 memEQ((char *)big, (char *)little, littlelen - 1))))
591 if (littlelen <= 2) { /* Special-cased */
593 if (littlelen == 1) {
594 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
595 /* Know that bigend != big. */
596 if (bigend[-1] == '\n')
597 return (char *)(bigend - 1);
598 return (char *) bigend;
606 if (SvTAIL(littlestr))
607 return (char *) bigend;
611 return (char*)big; /* Cannot be SvTAIL! */
614 if (SvTAIL(littlestr) && !multiline) {
615 if (bigend[-1] == '\n' && bigend[-2] == *little)
616 return (char*)bigend - 2;
617 if (bigend[-1] == *little)
618 return (char*)bigend - 1;
622 /* This should be better than FBM if c1 == c2, and almost
623 as good otherwise: maybe better since we do less indirection.
624 And we save a lot of memory by caching no table. */
625 const unsigned char c1 = little[0];
626 const unsigned char c2 = little[1];
631 while (s <= bigend) {
641 goto check_1char_anchor;
652 goto check_1char_anchor;
655 while (s <= bigend) {
660 goto check_1char_anchor;
669 check_1char_anchor: /* One char and anchor! */
670 if (SvTAIL(littlestr) && (*bigend == *little))
671 return (char *)bigend; /* bigend is already decremented. */
674 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
675 s = bigend - littlelen;
676 if (s >= big && bigend[-1] == '\n' && *s == *little
677 /* Automatically of length > 2 */
678 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
680 return (char*)s; /* how sweet it is */
683 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
685 return (char*)s + 1; /* how sweet it is */
689 if (!SvVALID(littlestr)) {
690 char * const b = ninstr((char*)big,(char*)bigend,
691 (char*)little, (char*)little + littlelen);
693 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
694 /* Chop \n from littlestr: */
695 s = bigend - littlelen + 1;
697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
707 if (littlelen > (STRLEN)(bigend - big))
711 register const unsigned char * const table
712 = little + littlelen + PERL_FBM_TABLE_OFFSET;
713 register const unsigned char *oldlittle;
715 --littlelen; /* Last char found by table lookup */
718 little += littlelen; /* last char */
724 if ((tmp = table[*s])) {
725 if ((s += tmp) < bigend)
729 else { /* less expensive than calling strncmp() */
730 register unsigned char * const olds = s;
735 if (*--s == *--little)
737 s = olds + 1; /* here we pay the price for failure */
739 if (s < bigend) /* fake up continue to outer loop */
748 && (BmFLAGS(littlestr) & FBMcf_TAIL)
749 && memEQ((char *)(bigend - littlelen),
750 (char *)(oldlittle - littlelen), littlelen) )
751 return (char*)bigend - littlelen;
756 /* start_shift, end_shift are positive quantities which give offsets
757 of ends of some substring of bigstr.
758 If "last" we want the last occurrence.
759 old_posp is the way of communication between consequent calls if
760 the next call needs to find the .
761 The initial *old_posp should be -1.
763 Note that we take into account SvTAIL, so one can get extra
764 optimizations if _ALL flag is set.
767 /* If SvTAIL is actually due to \Z or \z, this gives false positives
768 if PL_multiline. In fact if !PL_multiline the authoritative answer
769 is not supported yet. */
772 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
775 register const unsigned char *big;
777 register I32 previous;
779 register const unsigned char *little;
780 register I32 stop_pos;
781 register const unsigned char *littleend;
784 assert(SvTYPE(littlestr) == SVt_PVGV);
785 assert(SvVALID(littlestr));
788 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
789 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
791 if ( BmRARE(littlestr) == '\n'
792 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
793 little = (const unsigned char *)(SvPVX_const(littlestr));
794 littleend = little + SvCUR(littlestr);
801 little = (const unsigned char *)(SvPVX_const(littlestr));
802 littleend = little + SvCUR(littlestr);
804 /* The value of pos we can start at: */
805 previous = BmPREVIOUS(littlestr);
806 big = (const unsigned char *)(SvPVX_const(bigstr));
807 /* The value of pos we can stop at: */
808 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
809 if (previous + start_shift > stop_pos) {
811 stop_pos does not include SvTAIL in the count, so this check is incorrect
812 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
815 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
820 while (pos < previous + start_shift) {
821 if (!(pos += PL_screamnext[pos]))
826 register const unsigned char *s, *x;
827 if (pos >= stop_pos) break;
828 if (big[pos] != first)
830 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
836 if (s == littleend) {
838 if (!last) return (char *)(big+pos);
841 } while ( pos += PL_screamnext[pos] );
843 return (char *)(big+(*old_posp));
845 if (!SvTAIL(littlestr) || (end_shift > 0))
847 /* Ignore the trailing "\n". This code is not microoptimized */
848 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
849 stop_pos = littleend - little; /* Actual littlestr len */
854 && ((stop_pos == 1) ||
855 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
861 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
863 register const U8 *a = (const U8 *)s1;
864 register const U8 *b = (const U8 *)s2;
868 if (*a != *b && *a != PL_fold[*b])
876 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
879 register const U8 *a = (const U8 *)s1;
880 register const U8 *b = (const U8 *)s2;
884 if (*a != *b && *a != PL_fold_locale[*b])
891 /* copy a string to a safe spot */
894 =head1 Memory Management
898 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
899 string which is a duplicate of C<pv>. The size of the string is
900 determined by C<strlen()>. The memory allocated for the new string can
901 be freed with the C<Safefree()> function.
907 Perl_savepv(pTHX_ const char *pv)
914 const STRLEN pvlen = strlen(pv)+1;
915 Newx(newaddr, pvlen, char);
916 return (char*)memcpy(newaddr, pv, pvlen);
920 /* same thing but with a known length */
925 Perl's version of what C<strndup()> would be if it existed. Returns a
926 pointer to a newly allocated string which is a duplicate of the first
927 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
928 the new string can be freed with the C<Safefree()> function.
934 Perl_savepvn(pTHX_ const char *pv, register I32 len)
936 register char *newaddr;
939 Newx(newaddr,len+1,char);
940 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
942 /* might not be null terminated */
944 return (char *) CopyD(pv,newaddr,len,char);
947 return (char *) ZeroD(newaddr,len+1,char);
952 =for apidoc savesharedpv
954 A version of C<savepv()> which allocates the duplicate string in memory
955 which is shared between threads.
960 Perl_savesharedpv(pTHX_ const char *pv)
962 register char *newaddr;
967 pvlen = strlen(pv)+1;
968 newaddr = (char*)PerlMemShared_malloc(pvlen);
970 return write_no_mem();
972 return (char*)memcpy(newaddr, pv, pvlen);
976 =for apidoc savesharedpvn
978 A version of C<savepvn()> which allocates the duplicate string in memory
979 which is shared between threads. (With the specific difference that a NULL
980 pointer is not acceptable)
985 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
987 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
990 return write_no_mem();
993 return (char*)memcpy(newaddr, pv, len);
999 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1000 the passed in SV using C<SvPV()>
1006 Perl_savesvpv(pTHX_ SV *sv)
1009 const char * const pv = SvPV_const(sv, len);
1010 register char *newaddr;
1013 Newx(newaddr,len,char);
1014 return (char *) CopyD(pv,newaddr,len,char);
1018 /* the SV for Perl_form() and mess() is not kept in an arena */
1028 return sv_2mortal(newSVpvs(""));
1033 /* Create as PVMG now, to avoid any upgrading later */
1035 Newxz(any, 1, XPVMG);
1036 SvFLAGS(sv) = SVt_PVMG;
1037 SvANY(sv) = (void*)any;
1039 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1044 #if defined(PERL_IMPLICIT_CONTEXT)
1046 Perl_form_nocontext(const char* pat, ...)
1051 va_start(args, pat);
1052 retval = vform(pat, &args);
1056 #endif /* PERL_IMPLICIT_CONTEXT */
1059 =head1 Miscellaneous Functions
1062 Takes a sprintf-style format pattern and conventional
1063 (non-SV) arguments and returns the formatted string.
1065 (char *) Perl_form(pTHX_ const char* pat, ...)
1067 can be used any place a string (char *) is required:
1069 char * s = Perl_form("%d.%d",major,minor);
1071 Uses a single private buffer so if you want to format several strings you
1072 must explicitly copy the earlier strings away (and free the copies when you
1079 Perl_form(pTHX_ const char* pat, ...)
1083 va_start(args, pat);
1084 retval = vform(pat, &args);
1090 Perl_vform(pTHX_ const char *pat, va_list *args)
1092 SV * const sv = mess_alloc();
1093 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1097 #if defined(PERL_IMPLICIT_CONTEXT)
1099 Perl_mess_nocontext(const char *pat, ...)
1104 va_start(args, pat);
1105 retval = vmess(pat, &args);
1109 #endif /* PERL_IMPLICIT_CONTEXT */
1112 Perl_mess(pTHX_ const char *pat, ...)
1116 va_start(args, pat);
1117 retval = vmess(pat, &args);
1123 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1126 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1128 if (!o || o == PL_op)
1131 if (o->op_flags & OPf_KIDS) {
1133 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1136 /* If the OP_NEXTSTATE has been optimised away we can still use it
1137 * the get the file and line number. */
1139 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1140 cop = (const COP *)kid;
1142 /* Keep searching, and return when we've found something. */
1144 new_cop = closest_cop(cop, kid);
1150 /* Nothing found. */
1156 Perl_vmess(pTHX_ const char *pat, va_list *args)
1159 SV * const sv = mess_alloc();
1161 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1162 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1164 * Try and find the file and line for PL_op. This will usually be
1165 * PL_curcop, but it might be a cop that has been optimised away. We
1166 * can try to find such a cop by searching through the optree starting
1167 * from the sibling of PL_curcop.
1170 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1175 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1176 OutCopFILE(cop), (IV)CopLINE(cop));
1177 /* Seems that GvIO() can be untrustworthy during global destruction. */
1178 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1179 && IoLINES(GvIOp(PL_last_in_gv)))
1181 const bool line_mode = (RsSIMPLE(PL_rs) &&
1182 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1183 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1184 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1185 line_mode ? "line" : "chunk",
1186 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1189 sv_catpvs(sv, " during global destruction");
1190 sv_catpvs(sv, ".\n");
1196 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1202 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1203 && (io = GvIO(PL_stderrgv))
1204 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1211 SAVESPTR(PL_stderrgv);
1214 PUSHSTACKi(PERLSI_MAGIC);
1218 PUSHs(SvTIED_obj((SV*)io, mg));
1219 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1221 call_method("PRINT", G_SCALAR);
1229 /* SFIO can really mess with your errno */
1230 const int e = errno;
1232 PerlIO * const serr = Perl_error_log;
1234 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1235 (void)PerlIO_flush(serr);
1242 /* Common code used by vcroak, vdie, vwarn and vwarner */
1245 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
1251 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1252 /* sv_2cv might call Perl_croak() or Perl_warner() */
1253 SV * const oldhook = *hook;
1260 cv = sv_2cv(oldhook, &stash, &gv, 0);
1262 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1272 if (warn || message) {
1273 msg = newSVpvn(message, msglen);
1274 SvFLAGS(msg) |= utf8;
1282 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1286 call_sv((SV*)cv, G_DISCARD);
1295 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1299 const char *message;
1302 SV * const msv = vmess(pat, args);
1303 if (PL_errors && SvCUR(PL_errors)) {
1304 sv_catsv(PL_errors, msv);
1305 message = SvPV_const(PL_errors, *msglen);
1306 SvCUR_set(PL_errors, 0);
1309 message = SvPV_const(msv,*msglen);
1310 *utf8 = SvUTF8(msv);
1316 DEBUG_S(PerlIO_printf(Perl_debug_log,
1317 "%p: die/croak: message = %s\ndiehook = %p\n",
1318 (void*)thr, message, (void*)PL_diehook));
1320 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1326 Perl_vdie(pTHX_ const char* pat, va_list *args)
1329 const char *message;
1330 const int was_in_eval = PL_in_eval;
1334 DEBUG_S(PerlIO_printf(Perl_debug_log,
1335 "%p: die: curstack = %p, mainstack = %p\n",
1336 (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
1338 message = vdie_croak_common(pat, args, &msglen, &utf8);
1340 PL_restartop = die_where(message, msglen);
1341 SvFLAGS(ERRSV) |= utf8;
1342 DEBUG_S(PerlIO_printf(Perl_debug_log,
1343 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1344 (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env));
1345 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1347 return PL_restartop;
1350 #if defined(PERL_IMPLICIT_CONTEXT)
1352 Perl_die_nocontext(const char* pat, ...)
1357 va_start(args, pat);
1358 o = vdie(pat, &args);
1362 #endif /* PERL_IMPLICIT_CONTEXT */
1365 Perl_die(pTHX_ const char* pat, ...)
1369 va_start(args, pat);
1370 o = vdie(pat, &args);
1376 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1379 const char *message;
1383 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1386 PL_restartop = die_where(message, msglen);
1387 SvFLAGS(ERRSV) |= utf8;
1391 message = SvPVx_const(ERRSV, msglen);
1393 write_to_stderr(message, msglen);
1397 #if defined(PERL_IMPLICIT_CONTEXT)
1399 Perl_croak_nocontext(const char *pat, ...)
1403 va_start(args, pat);
1408 #endif /* PERL_IMPLICIT_CONTEXT */
1411 =head1 Warning and Dieing
1415 This is the XSUB-writer's interface to Perl's C<die> function.
1416 Normally call this function the same way you call the C C<printf>
1417 function. Calling C<croak> returns control directly to Perl,
1418 sidestepping the normal C order of execution. See C<warn>.
1420 If you want to throw an exception object, assign the object to
1421 C<$@> and then pass C<NULL> to croak():
1423 errsv = get_sv("@", TRUE);
1424 sv_setsv(errsv, exception_object);
1431 Perl_croak(pTHX_ const char *pat, ...)
1434 va_start(args, pat);
1441 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1445 SV * const msv = vmess(pat, args);
1446 const I32 utf8 = SvUTF8(msv);
1447 const char * const message = SvPV_const(msv, msglen);
1450 if (vdie_common(message, msglen, utf8, TRUE))
1454 write_to_stderr(message, msglen);
1457 #if defined(PERL_IMPLICIT_CONTEXT)
1459 Perl_warn_nocontext(const char *pat, ...)
1463 va_start(args, pat);
1467 #endif /* PERL_IMPLICIT_CONTEXT */
1472 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1473 function the same way you call the C C<printf> function. See C<croak>.
1479 Perl_warn(pTHX_ const char *pat, ...)
1482 va_start(args, pat);
1487 #if defined(PERL_IMPLICIT_CONTEXT)
1489 Perl_warner_nocontext(U32 err, const char *pat, ...)
1493 va_start(args, pat);
1494 vwarner(err, pat, &args);
1497 #endif /* PERL_IMPLICIT_CONTEXT */
1500 Perl_warner(pTHX_ U32 err, const char* pat,...)
1503 va_start(args, pat);
1504 vwarner(err, pat, &args);
1509 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1512 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1513 SV * const msv = vmess(pat, args);
1515 const char * const message = SvPV_const(msv, msglen);
1516 const I32 utf8 = SvUTF8(msv);
1520 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1523 PL_restartop = die_where(message, msglen);
1524 SvFLAGS(ERRSV) |= utf8;
1527 write_to_stderr(message, msglen);
1531 Perl_vwarn(aTHX_ pat, args);
1535 /* implements the ckWARN? macros */
1538 Perl_ckwarn(pTHX_ U32 w)
1544 && PL_curcop->cop_warnings != pWARN_NONE
1546 PL_curcop->cop_warnings == pWARN_ALL
1547 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1548 || (unpackWARN2(w) &&
1549 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1550 || (unpackWARN3(w) &&
1551 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1552 || (unpackWARN4(w) &&
1553 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1558 isLEXWARN_off && PL_dowarn & G_WARN_ON
1563 /* implements the ckWARN?_d macro */
1566 Perl_ckwarn_d(pTHX_ U32 w)
1571 || PL_curcop->cop_warnings == pWARN_ALL
1573 PL_curcop->cop_warnings != pWARN_NONE
1575 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1576 || (unpackWARN2(w) &&
1577 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1578 || (unpackWARN3(w) &&
1579 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1580 || (unpackWARN4(w) &&
1581 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1587 /* Set buffer=NULL to get a new one. */
1589 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1591 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1592 PERL_UNUSED_CONTEXT;
1595 (specialWARN(buffer) ?
1596 PerlMemShared_malloc(len_wanted) :
1597 PerlMemShared_realloc(buffer, len_wanted));
1599 Copy(bits, (buffer + 1), size, char);
1603 /* since we've already done strlen() for both nam and val
1604 * we can use that info to make things faster than
1605 * sprintf(s, "%s=%s", nam, val)
1607 #define my_setenv_format(s, nam, nlen, val, vlen) \
1608 Copy(nam, s, nlen, char); \
1610 Copy(val, s+(nlen+1), vlen, char); \
1611 *(s+(nlen+1+vlen)) = '\0'
1613 #ifdef USE_ENVIRON_ARRAY
1614 /* VMS' my_setenv() is in vms.c */
1615 #if !defined(WIN32) && !defined(NETWARE)
1617 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1621 /* only parent thread can modify process environment */
1622 if (PL_curinterp == aTHX)
1625 #ifndef PERL_USE_SAFE_PUTENV
1626 if (!PL_use_safe_putenv) {
1627 /* most putenv()s leak, so we manipulate environ directly */
1628 register I32 i=setenv_getix(nam); /* where does it go? */
1631 if (environ == PL_origenviron) { /* need we copy environment? */
1637 while (environ[max])
1639 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1640 for (j=0; j<max; j++) { /* copy environment */
1641 const int len = strlen(environ[j]);
1642 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1643 Copy(environ[j], tmpenv[j], len+1, char);
1646 environ = tmpenv; /* tell exec where it is now */
1649 safesysfree(environ[i]);
1650 while (environ[i]) {
1651 environ[i] = environ[i+1];
1656 if (!environ[i]) { /* does not exist yet */
1657 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1658 environ[i+1] = NULL; /* make sure it's null terminated */
1661 safesysfree(environ[i]);
1665 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1666 /* all that work just for this */
1667 my_setenv_format(environ[i], nam, nlen, val, vlen);
1670 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1671 # if defined(HAS_UNSETENV)
1673 (void)unsetenv(nam);
1675 (void)setenv(nam, val, 1);
1677 # else /* ! HAS_UNSETENV */
1678 (void)setenv(nam, val, 1);
1679 # endif /* HAS_UNSETENV */
1681 # if defined(HAS_UNSETENV)
1683 (void)unsetenv(nam);
1685 const int nlen = strlen(nam);
1686 const int vlen = strlen(val);
1687 char * const new_env =
1688 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1689 my_setenv_format(new_env, nam, nlen, val, vlen);
1690 (void)putenv(new_env);
1692 # else /* ! HAS_UNSETENV */
1694 const int nlen = strlen(nam);
1700 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1701 /* all that work just for this */
1702 my_setenv_format(new_env, nam, nlen, val, vlen);
1703 (void)putenv(new_env);
1704 # endif /* HAS_UNSETENV */
1705 # endif /* __CYGWIN__ */
1706 #ifndef PERL_USE_SAFE_PUTENV
1712 #else /* WIN32 || NETWARE */
1715 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1718 register char *envstr;
1719 const int nlen = strlen(nam);
1726 Newx(envstr, nlen+vlen+2, char);
1727 my_setenv_format(envstr, nam, nlen, val, vlen);
1728 (void)PerlEnv_putenv(envstr);
1732 #endif /* WIN32 || NETWARE */
1736 Perl_setenv_getix(pTHX_ const char *nam)
1739 register const I32 len = strlen(nam);
1740 PERL_UNUSED_CONTEXT;
1742 for (i = 0; environ[i]; i++) {
1745 strnicmp(environ[i],nam,len) == 0
1747 strnEQ(environ[i],nam,len)
1749 && environ[i][len] == '=')
1750 break; /* strnEQ must come first to avoid */
1751 } /* potential SEGV's */
1754 #endif /* !PERL_MICRO */
1756 #endif /* !VMS && !EPOC*/
1758 #ifdef UNLINK_ALL_VERSIONS
1760 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1764 while (PerlLIO_unlink(f) >= 0)
1766 return retries ? 0 : -1;
1770 /* this is a drop-in replacement for bcopy() */
1771 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1773 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1775 char * const retval = to;
1777 if (from - to >= 0) {
1785 *(--to) = *(--from);
1791 /* this is a drop-in replacement for memset() */
1794 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1796 char * const retval = loc;
1804 /* this is a drop-in replacement for bzero() */
1805 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1807 Perl_my_bzero(register char *loc, register I32 len)
1809 char * const retval = loc;
1817 /* this is a drop-in replacement for memcmp() */
1818 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1820 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1822 register const U8 *a = (const U8 *)s1;
1823 register const U8 *b = (const U8 *)s2;
1827 if ((tmp = *a++ - *b++))
1832 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1835 /* This vsprintf replacement should generally never get used, since
1836 vsprintf was available in both System V and BSD 2.11. (There may
1837 be some cross-compilation or embedded set-ups where it is needed,
1840 If you encounter a problem in this function, it's probably a symptom
1841 that Configure failed to detect your system's vprintf() function.
1842 See the section on "item vsprintf" in the INSTALL file.
1844 This version may compile on systems with BSD-ish <stdio.h>,
1845 but probably won't on others.
1848 #ifdef USE_CHAR_VSPRINTF
1853 vsprintf(char *dest, const char *pat, void *args)
1857 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1858 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1859 FILE_cnt(&fakebuf) = 32767;
1861 /* These probably won't compile -- If you really need
1862 this, you'll have to figure out some other method. */
1863 fakebuf._ptr = dest;
1864 fakebuf._cnt = 32767;
1869 fakebuf._flag = _IOWRT|_IOSTRG;
1870 _doprnt(pat, args, &fakebuf); /* what a kludge */
1871 #if defined(STDIO_PTR_LVALUE)
1872 *(FILE_ptr(&fakebuf)++) = '\0';
1874 /* PerlIO has probably #defined away fputc, but we want it here. */
1876 # undef fputc /* XXX Should really restore it later */
1878 (void)fputc('\0', &fakebuf);
1880 #ifdef USE_CHAR_VSPRINTF
1883 return 0; /* perl doesn't use return value */
1887 #endif /* HAS_VPRINTF */
1890 #if BYTEORDER != 0x4321
1892 Perl_my_swap(pTHX_ short s)
1894 #if (BYTEORDER & 1) == 0
1897 result = ((s & 255) << 8) + ((s >> 8) & 255);
1905 Perl_my_htonl(pTHX_ long l)
1909 char c[sizeof(long)];
1912 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1913 #if BYTEORDER == 0x12345678
1916 u.c[0] = (l >> 24) & 255;
1917 u.c[1] = (l >> 16) & 255;
1918 u.c[2] = (l >> 8) & 255;
1922 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1923 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1928 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1929 u.c[o & 0xf] = (l >> s) & 255;
1937 Perl_my_ntohl(pTHX_ long l)
1941 char c[sizeof(long)];
1944 #if BYTEORDER == 0x1234
1945 u.c[0] = (l >> 24) & 255;
1946 u.c[1] = (l >> 16) & 255;
1947 u.c[2] = (l >> 8) & 255;
1951 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1952 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1959 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1960 l |= (u.c[o & 0xf] & 255) << s;
1967 #endif /* BYTEORDER != 0x4321 */
1971 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1972 * If these functions are defined,
1973 * the BYTEORDER is neither 0x1234 nor 0x4321.
1974 * However, this is not assumed.
1978 #define HTOLE(name,type) \
1980 name (register type n) \
1984 char c[sizeof(type)]; \
1987 register U32 s = 0; \
1988 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1989 u.c[i] = (n >> s) & 0xFF; \
1994 #define LETOH(name,type) \
1996 name (register type n) \
2000 char c[sizeof(type)]; \
2003 register U32 s = 0; \
2006 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2007 n |= ((type)(u.c[i] & 0xFF)) << s; \
2013 * Big-endian byte order functions.
2016 #define HTOBE(name,type) \
2018 name (register type n) \
2022 char c[sizeof(type)]; \
2025 register U32 s = 8*(sizeof(u.c)-1); \
2026 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2027 u.c[i] = (n >> s) & 0xFF; \
2032 #define BETOH(name,type) \
2034 name (register type n) \
2038 char c[sizeof(type)]; \
2041 register U32 s = 8*(sizeof(u.c)-1); \
2044 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2045 n |= ((type)(u.c[i] & 0xFF)) << s; \
2051 * If we just can't do it...
2054 #define NOT_AVAIL(name,type) \
2056 name (register type n) \
2058 Perl_croak_nocontext(#name "() not available"); \
2059 return n; /* not reached */ \
2063 #if defined(HAS_HTOVS) && !defined(htovs)
2066 #if defined(HAS_HTOVL) && !defined(htovl)
2069 #if defined(HAS_VTOHS) && !defined(vtohs)
2072 #if defined(HAS_VTOHL) && !defined(vtohl)
2076 #ifdef PERL_NEED_MY_HTOLE16
2078 HTOLE(Perl_my_htole16,U16)
2080 NOT_AVAIL(Perl_my_htole16,U16)
2083 #ifdef PERL_NEED_MY_LETOH16
2085 LETOH(Perl_my_letoh16,U16)
2087 NOT_AVAIL(Perl_my_letoh16,U16)
2090 #ifdef PERL_NEED_MY_HTOBE16
2092 HTOBE(Perl_my_htobe16,U16)
2094 NOT_AVAIL(Perl_my_htobe16,U16)
2097 #ifdef PERL_NEED_MY_BETOH16
2099 BETOH(Perl_my_betoh16,U16)
2101 NOT_AVAIL(Perl_my_betoh16,U16)
2105 #ifdef PERL_NEED_MY_HTOLE32
2107 HTOLE(Perl_my_htole32,U32)
2109 NOT_AVAIL(Perl_my_htole32,U32)
2112 #ifdef PERL_NEED_MY_LETOH32
2114 LETOH(Perl_my_letoh32,U32)
2116 NOT_AVAIL(Perl_my_letoh32,U32)
2119 #ifdef PERL_NEED_MY_HTOBE32
2121 HTOBE(Perl_my_htobe32,U32)
2123 NOT_AVAIL(Perl_my_htobe32,U32)
2126 #ifdef PERL_NEED_MY_BETOH32
2128 BETOH(Perl_my_betoh32,U32)
2130 NOT_AVAIL(Perl_my_betoh32,U32)
2134 #ifdef PERL_NEED_MY_HTOLE64
2136 HTOLE(Perl_my_htole64,U64)
2138 NOT_AVAIL(Perl_my_htole64,U64)
2141 #ifdef PERL_NEED_MY_LETOH64
2143 LETOH(Perl_my_letoh64,U64)
2145 NOT_AVAIL(Perl_my_letoh64,U64)
2148 #ifdef PERL_NEED_MY_HTOBE64
2150 HTOBE(Perl_my_htobe64,U64)
2152 NOT_AVAIL(Perl_my_htobe64,U64)
2155 #ifdef PERL_NEED_MY_BETOH64
2157 BETOH(Perl_my_betoh64,U64)
2159 NOT_AVAIL(Perl_my_betoh64,U64)
2163 #ifdef PERL_NEED_MY_HTOLES
2164 HTOLE(Perl_my_htoles,short)
2166 #ifdef PERL_NEED_MY_LETOHS
2167 LETOH(Perl_my_letohs,short)
2169 #ifdef PERL_NEED_MY_HTOBES
2170 HTOBE(Perl_my_htobes,short)
2172 #ifdef PERL_NEED_MY_BETOHS
2173 BETOH(Perl_my_betohs,short)
2176 #ifdef PERL_NEED_MY_HTOLEI
2177 HTOLE(Perl_my_htolei,int)
2179 #ifdef PERL_NEED_MY_LETOHI
2180 LETOH(Perl_my_letohi,int)
2182 #ifdef PERL_NEED_MY_HTOBEI
2183 HTOBE(Perl_my_htobei,int)
2185 #ifdef PERL_NEED_MY_BETOHI
2186 BETOH(Perl_my_betohi,int)
2189 #ifdef PERL_NEED_MY_HTOLEL
2190 HTOLE(Perl_my_htolel,long)
2192 #ifdef PERL_NEED_MY_LETOHL
2193 LETOH(Perl_my_letohl,long)
2195 #ifdef PERL_NEED_MY_HTOBEL
2196 HTOBE(Perl_my_htobel,long)
2198 #ifdef PERL_NEED_MY_BETOHL
2199 BETOH(Perl_my_betohl,long)
2203 Perl_my_swabn(void *ptr, int n)
2205 register char *s = (char *)ptr;
2206 register char *e = s + (n-1);
2209 for (n /= 2; n > 0; s++, e--, n--) {
2217 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2219 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2222 register I32 This, that;
2228 PERL_FLUSHALL_FOR_CHILD;
2229 This = (*mode == 'w');
2233 taint_proper("Insecure %s%s", "EXEC");
2235 if (PerlProc_pipe(p) < 0)
2237 /* Try for another pipe pair for error return */
2238 if (PerlProc_pipe(pp) >= 0)
2240 while ((pid = PerlProc_fork()) < 0) {
2241 if (errno != EAGAIN) {
2242 PerlLIO_close(p[This]);
2243 PerlLIO_close(p[that]);
2245 PerlLIO_close(pp[0]);
2246 PerlLIO_close(pp[1]);
2258 /* Close parent's end of error status pipe (if any) */
2260 PerlLIO_close(pp[0]);
2261 #if defined(HAS_FCNTL) && defined(F_SETFD)
2262 /* Close error pipe automatically if exec works */
2263 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2266 /* Now dup our end of _the_ pipe to right position */
2267 if (p[THIS] != (*mode == 'r')) {
2268 PerlLIO_dup2(p[THIS], *mode == 'r');
2269 PerlLIO_close(p[THIS]);
2270 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2271 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2274 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2275 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2276 /* No automatic close - do it by hand */
2283 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2289 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2295 do_execfree(); /* free any memory malloced by child on fork */
2297 PerlLIO_close(pp[1]);
2298 /* Keep the lower of the two fd numbers */
2299 if (p[that] < p[This]) {
2300 PerlLIO_dup2(p[This], p[that]);
2301 PerlLIO_close(p[This]);
2305 PerlLIO_close(p[that]); /* close child's end of pipe */
2308 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2310 SvUPGRADE(sv,SVt_IV);
2312 PL_forkprocess = pid;
2313 /* If we managed to get status pipe check for exec fail */
2314 if (did_pipes && pid > 0) {
2319 while (n < sizeof(int)) {
2320 n1 = PerlLIO_read(pp[0],
2321 (void*)(((char*)&errkid)+n),
2327 PerlLIO_close(pp[0]);
2329 if (n) { /* Error */
2331 PerlLIO_close(p[This]);
2332 if (n != sizeof(int))
2333 Perl_croak(aTHX_ "panic: kid popen errno read");
2335 pid2 = wait4pid(pid, &status, 0);
2336 } while (pid2 == -1 && errno == EINTR);
2337 errno = errkid; /* Propagate errno from kid */
2342 PerlLIO_close(pp[0]);
2343 return PerlIO_fdopen(p[This], mode);
2345 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2346 return my_syspopen4(aTHX_ Nullch, mode, n, args);
2348 Perl_croak(aTHX_ "List form of piped open not implemented");
2349 return (PerlIO *) NULL;
2354 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2355 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2357 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2361 register I32 This, that;
2364 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2368 PERL_FLUSHALL_FOR_CHILD;
2371 return my_syspopen(aTHX_ cmd,mode);
2374 This = (*mode == 'w');
2376 if (doexec && PL_tainting) {
2378 taint_proper("Insecure %s%s", "EXEC");
2380 if (PerlProc_pipe(p) < 0)
2382 if (doexec && PerlProc_pipe(pp) >= 0)
2384 while ((pid = PerlProc_fork()) < 0) {
2385 if (errno != EAGAIN) {
2386 PerlLIO_close(p[This]);
2387 PerlLIO_close(p[that]);
2389 PerlLIO_close(pp[0]);
2390 PerlLIO_close(pp[1]);
2393 Perl_croak(aTHX_ "Can't fork");
2406 PerlLIO_close(pp[0]);
2407 #if defined(HAS_FCNTL) && defined(F_SETFD)
2408 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2411 if (p[THIS] != (*mode == 'r')) {
2412 PerlLIO_dup2(p[THIS], *mode == 'r');
2413 PerlLIO_close(p[THIS]);
2414 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2415 PerlLIO_close(p[THAT]);
2418 PerlLIO_close(p[THAT]);
2421 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2428 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2433 /* may or may not use the shell */
2434 do_exec3(cmd, pp[1], did_pipes);
2437 #endif /* defined OS2 */
2439 #ifdef PERLIO_USING_CRLF
2440 /* Since we circumvent IO layers when we manipulate low-level
2441 filedescriptors directly, need to manually switch to the
2442 default, binary, low-level mode; see PerlIOBuf_open(). */
2443 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2446 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2447 SvREADONLY_off(GvSV(tmpgv));
2448 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2449 SvREADONLY_on(GvSV(tmpgv));
2451 #ifdef THREADS_HAVE_PIDS
2452 PL_ppid = (IV)getppid();
2455 #ifdef PERL_USES_PL_PIDSTATUS
2456 hv_clear(PL_pidstatus); /* we have no children */
2462 do_execfree(); /* free any memory malloced by child on vfork */
2464 PerlLIO_close(pp[1]);
2465 if (p[that] < p[This]) {
2466 PerlLIO_dup2(p[This], p[that]);
2467 PerlLIO_close(p[This]);
2471 PerlLIO_close(p[that]);
2474 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2476 SvUPGRADE(sv,SVt_IV);
2478 PL_forkprocess = pid;
2479 if (did_pipes && pid > 0) {
2484 while (n < sizeof(int)) {
2485 n1 = PerlLIO_read(pp[0],
2486 (void*)(((char*)&errkid)+n),
2492 PerlLIO_close(pp[0]);
2494 if (n) { /* Error */
2496 PerlLIO_close(p[This]);
2497 if (n != sizeof(int))
2498 Perl_croak(aTHX_ "panic: kid popen errno read");
2500 pid2 = wait4pid(pid, &status, 0);
2501 } while (pid2 == -1 && errno == EINTR);
2502 errno = errkid; /* Propagate errno from kid */
2507 PerlLIO_close(pp[0]);
2508 return PerlIO_fdopen(p[This], mode);
2511 #if defined(atarist) || defined(EPOC)
2514 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2516 PERL_FLUSHALL_FOR_CHILD;
2517 /* Call system's popen() to get a FILE *, then import it.
2518 used 0 for 2nd parameter to PerlIO_importFILE;
2521 return PerlIO_importFILE(popen(cmd, mode), 0);
2525 FILE *djgpp_popen();
2527 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2529 PERL_FLUSHALL_FOR_CHILD;
2530 /* Call system's popen() to get a FILE *, then import it.
2531 used 0 for 2nd parameter to PerlIO_importFILE;
2534 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2539 #endif /* !DOSISH */
2541 /* this is called in parent before the fork() */
2543 Perl_atfork_lock(void)
2546 #if defined(USE_ITHREADS)
2547 /* locks must be held in locking order (if any) */
2549 MUTEX_LOCK(&PL_malloc_mutex);
2555 /* this is called in both parent and child after the fork() */
2557 Perl_atfork_unlock(void)
2560 #if defined(USE_ITHREADS)
2561 /* locks must be released in same order as in atfork_lock() */
2563 MUTEX_UNLOCK(&PL_malloc_mutex);
2572 #if defined(HAS_FORK)
2574 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2579 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2580 * handlers elsewhere in the code */
2585 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2586 Perl_croak_nocontext("fork() not available");
2588 #endif /* HAS_FORK */
2593 Perl_dump_fds(pTHX_ char *s)
2598 PerlIO_printf(Perl_debug_log,"%s", s);
2599 for (fd = 0; fd < 32; fd++) {
2600 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2601 PerlIO_printf(Perl_debug_log," %d",fd);
2603 PerlIO_printf(Perl_debug_log,"\n");
2606 #endif /* DUMP_FDS */
2610 dup2(int oldfd, int newfd)
2612 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2615 PerlLIO_close(newfd);
2616 return fcntl(oldfd, F_DUPFD, newfd);
2618 #define DUP2_MAX_FDS 256
2619 int fdtmp[DUP2_MAX_FDS];
2625 PerlLIO_close(newfd);
2626 /* good enough for low fd's... */
2627 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2628 if (fdx >= DUP2_MAX_FDS) {
2636 PerlLIO_close(fdtmp[--fdx]);
2643 #ifdef HAS_SIGACTION
2645 #ifdef MACOS_TRADITIONAL
2646 /* We don't want restart behavior on MacOS */
2651 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2654 struct sigaction act, oact;
2657 /* only "parent" interpreter can diddle signals */
2658 if (PL_curinterp != aTHX)
2659 return (Sighandler_t) SIG_ERR;
2662 act.sa_handler = (void(*)(int))handler;
2663 sigemptyset(&act.sa_mask);
2666 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2667 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2669 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2670 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2671 act.sa_flags |= SA_NOCLDWAIT;
2673 if (sigaction(signo, &act, &oact) == -1)
2674 return (Sighandler_t) SIG_ERR;
2676 return (Sighandler_t) oact.sa_handler;
2680 Perl_rsignal_state(pTHX_ int signo)
2682 struct sigaction oact;
2683 PERL_UNUSED_CONTEXT;
2685 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2686 return (Sighandler_t) SIG_ERR;
2688 return (Sighandler_t) oact.sa_handler;
2692 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2695 struct sigaction act;
2698 /* only "parent" interpreter can diddle signals */
2699 if (PL_curinterp != aTHX)
2703 act.sa_handler = (void(*)(int))handler;
2704 sigemptyset(&act.sa_mask);
2707 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2708 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2710 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2711 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2712 act.sa_flags |= SA_NOCLDWAIT;
2714 return sigaction(signo, &act, save);
2718 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2722 /* only "parent" interpreter can diddle signals */
2723 if (PL_curinterp != aTHX)
2727 return sigaction(signo, save, (struct sigaction *)NULL);
2730 #else /* !HAS_SIGACTION */
2733 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2735 #if defined(USE_ITHREADS) && !defined(WIN32)
2736 /* only "parent" interpreter can diddle signals */
2737 if (PL_curinterp != aTHX)
2738 return (Sighandler_t) SIG_ERR;
2741 return PerlProc_signal(signo, handler);
2752 Perl_rsignal_state(pTHX_ int signo)
2755 Sighandler_t oldsig;
2757 #if defined(USE_ITHREADS) && !defined(WIN32)
2758 /* only "parent" interpreter can diddle signals */
2759 if (PL_curinterp != aTHX)
2760 return (Sighandler_t) SIG_ERR;
2764 oldsig = PerlProc_signal(signo, sig_trap);
2765 PerlProc_signal(signo, oldsig);
2767 PerlProc_kill(PerlProc_getpid(), signo);
2772 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2774 #if defined(USE_ITHREADS) && !defined(WIN32)
2775 /* only "parent" interpreter can diddle signals */
2776 if (PL_curinterp != aTHX)
2779 *save = PerlProc_signal(signo, handler);
2780 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2784 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2786 #if defined(USE_ITHREADS) && !defined(WIN32)
2787 /* only "parent" interpreter can diddle signals */
2788 if (PL_curinterp != aTHX)
2791 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2794 #endif /* !HAS_SIGACTION */
2795 #endif /* !PERL_MICRO */
2797 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2798 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2800 Perl_my_pclose(pTHX_ PerlIO *ptr)
2803 Sigsave_t hstat, istat, qstat;
2809 int saved_errno = 0;
2811 int saved_win32_errno;
2815 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2817 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2819 *svp = &PL_sv_undef;
2821 if (pid == -1) { /* Opened by popen. */
2822 return my_syspclose(ptr);
2825 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2826 saved_errno = errno;
2828 saved_win32_errno = GetLastError();
2832 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2835 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2836 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2837 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2840 pid2 = wait4pid(pid, &status, 0);
2841 } while (pid2 == -1 && errno == EINTR);
2843 rsignal_restore(SIGHUP, &hstat);
2844 rsignal_restore(SIGINT, &istat);
2845 rsignal_restore(SIGQUIT, &qstat);
2848 SETERRNO(saved_errno, 0);
2851 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2853 #endif /* !DOSISH */
2855 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2857 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2863 #ifdef PERL_USES_PL_PIDSTATUS
2866 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2867 pid, rather than a string form. */
2868 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2869 if (svp && *svp != &PL_sv_undef) {
2870 *statusp = SvIVX(*svp);
2871 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2879 hv_iterinit(PL_pidstatus);
2880 if ((entry = hv_iternext(PL_pidstatus))) {
2881 SV * const sv = hv_iterval(PL_pidstatus,entry);
2883 const char * const spid = hv_iterkey(entry,&len);
2885 assert (len == sizeof(Pid_t));
2886 memcpy((char *)&pid, spid, len);
2887 *statusp = SvIVX(sv);
2888 /* The hash iterator is currently on this entry, so simply
2889 calling hv_delete would trigger the lazy delete, which on
2890 aggregate does more work, beacuse next call to hv_iterinit()
2891 would spot the flag, and have to call the delete routine,
2892 while in the meantime any new entries can't re-use that
2894 hv_iterinit(PL_pidstatus);
2895 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2902 # ifdef HAS_WAITPID_RUNTIME
2903 if (!HAS_WAITPID_RUNTIME)
2906 result = PerlProc_waitpid(pid,statusp,flags);
2909 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2910 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2913 #ifdef PERL_USES_PL_PIDSTATUS
2914 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2919 Perl_croak(aTHX_ "Can't do waitpid with flags");
2921 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2922 pidgone(result,*statusp);
2928 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2931 if (result < 0 && errno == EINTR) {
2936 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2938 #ifdef PERL_USES_PL_PIDSTATUS
2940 Perl_pidgone(pTHX_ Pid_t pid, int status)
2944 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2945 SvUPGRADE(sv,SVt_IV);
2946 SvIV_set(sv, status);
2951 #if defined(atarist) || defined(OS2) || defined(EPOC)
2954 int /* Cannot prototype with I32
2956 my_syspclose(PerlIO *ptr)
2959 Perl_my_pclose(pTHX_ PerlIO *ptr)
2962 /* Needs work for PerlIO ! */
2963 FILE * const f = PerlIO_findFILE(ptr);
2964 const I32 result = pclose(f);
2965 PerlIO_releaseFILE(ptr,f);
2973 Perl_my_pclose(pTHX_ PerlIO *ptr)
2975 /* Needs work for PerlIO ! */
2976 FILE * const f = PerlIO_findFILE(ptr);
2977 I32 result = djgpp_pclose(f);
2978 result = (result << 8) & 0xff00;
2979 PerlIO_releaseFILE(ptr,f);
2985 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2988 register const char * const frombase = from;
2989 PERL_UNUSED_CONTEXT;
2992 register const char c = *from;
2997 while (count-- > 0) {
2998 for (todo = len; todo > 0; todo--) {
3007 Perl_same_dirent(pTHX_ const char *a, const char *b)
3009 char *fa = strrchr(a,'/');
3010 char *fb = strrchr(b,'/');
3013 SV * const tmpsv = sv_newmortal();
3026 sv_setpvn(tmpsv, ".", 1);
3028 sv_setpvn(tmpsv, a, fa - a);
3029 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3032 sv_setpvn(tmpsv, ".", 1);
3034 sv_setpvn(tmpsv, b, fb - b);
3035 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3037 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3038 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3040 #endif /* !HAS_RENAME */
3043 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3044 const char *const *const search_ext, I32 flags)
3047 const char *xfound = NULL;
3048 char *xfailed = NULL;
3049 char tmpbuf[MAXPATHLEN];
3054 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3055 # define SEARCH_EXTS ".bat", ".cmd", NULL
3056 # define MAX_EXT_LEN 4
3059 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3060 # define MAX_EXT_LEN 4
3063 # define SEARCH_EXTS ".pl", ".com", NULL
3064 # define MAX_EXT_LEN 4
3066 /* additional extensions to try in each dir if scriptname not found */
3068 static const char *const exts[] = { SEARCH_EXTS };
3069 const char *const *const ext = search_ext ? search_ext : exts;
3070 int extidx = 0, i = 0;
3071 const char *curext = NULL;
3073 PERL_UNUSED_ARG(search_ext);
3074 # define MAX_EXT_LEN 0
3078 * If dosearch is true and if scriptname does not contain path
3079 * delimiters, search the PATH for scriptname.
3081 * If SEARCH_EXTS is also defined, will look for each
3082 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3083 * while searching the PATH.
3085 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3086 * proceeds as follows:
3087 * If DOSISH or VMSISH:
3088 * + look for ./scriptname{,.foo,.bar}
3089 * + search the PATH for scriptname{,.foo,.bar}
3092 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3093 * this will not look in '.' if it's not in the PATH)
3098 # ifdef ALWAYS_DEFTYPES
3099 len = strlen(scriptname);
3100 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3101 int idx = 0, deftypes = 1;
3104 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3107 int idx = 0, deftypes = 1;
3110 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3112 /* The first time through, just add SEARCH_EXTS to whatever we
3113 * already have, so we can check for default file types. */
3115 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3121 if ((strlen(tmpbuf) + strlen(scriptname)
3122 + MAX_EXT_LEN) >= sizeof tmpbuf)
3123 continue; /* don't search dir with too-long name */
3124 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3128 if (strEQ(scriptname, "-"))
3130 if (dosearch) { /* Look in '.' first. */
3131 const char *cur = scriptname;
3133 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3135 if (strEQ(ext[i++],curext)) {
3136 extidx = -1; /* already has an ext */
3141 DEBUG_p(PerlIO_printf(Perl_debug_log,
3142 "Looking for %s\n",cur));
3143 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3144 && !S_ISDIR(PL_statbuf.st_mode)) {
3152 if (cur == scriptname) {
3153 len = strlen(scriptname);
3154 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3156 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3159 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3160 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3165 #ifdef MACOS_TRADITIONAL
3166 if (dosearch && !strchr(scriptname, ':') &&
3167 (s = PerlEnv_getenv("Commands")))
3169 if (dosearch && !strchr(scriptname, '/')
3171 && !strchr(scriptname, '\\')
3173 && (s = PerlEnv_getenv("PATH")))
3178 bufend = s + strlen(s);
3179 while (s < bufend) {
3180 #ifdef MACOS_TRADITIONAL
3181 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3185 #if defined(atarist) || defined(DOSISH)
3190 && *s != ';'; len++, s++) {
3191 if (len < sizeof tmpbuf)
3194 if (len < sizeof tmpbuf)
3196 #else /* ! (atarist || DOSISH) */
3197 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3200 #endif /* ! (atarist || DOSISH) */
3201 #endif /* MACOS_TRADITIONAL */
3204 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3205 continue; /* don't search dir with too-long name */
3206 #ifdef MACOS_TRADITIONAL
3207 if (len && tmpbuf[len - 1] != ':')
3208 tmpbuf[len++] = ':';
3211 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3212 && tmpbuf[len - 1] != '/'
3213 && tmpbuf[len - 1] != '\\'
3216 tmpbuf[len++] = '/';
3217 if (len == 2 && tmpbuf[0] == '.')
3220 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3224 len = strlen(tmpbuf);
3225 if (extidx > 0) /* reset after previous loop */
3229 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3230 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3231 if (S_ISDIR(PL_statbuf.st_mode)) {
3235 } while ( retval < 0 /* not there */
3236 && extidx>=0 && ext[extidx] /* try an extension? */
3237 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3242 if (S_ISREG(PL_statbuf.st_mode)
3243 && cando(S_IRUSR,TRUE,&PL_statbuf)
3244 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3245 && cando(S_IXUSR,TRUE,&PL_statbuf)
3249 xfound = tmpbuf; /* bingo! */
3253 xfailed = savepv(tmpbuf);
3256 if (!xfound && !seen_dot && !xfailed &&
3257 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3258 || S_ISDIR(PL_statbuf.st_mode)))
3260 seen_dot = 1; /* Disable message. */
3262 if (flags & 1) { /* do or die? */
3263 Perl_croak(aTHX_ "Can't %s %s%s%s",
3264 (xfailed ? "execute" : "find"),
3265 (xfailed ? xfailed : scriptname),
3266 (xfailed ? "" : " on PATH"),
3267 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3272 scriptname = xfound;
3274 return (scriptname ? savepv(scriptname) : NULL);
3277 #ifndef PERL_GET_CONTEXT_DEFINED
3280 Perl_get_context(void)
3283 #if defined(USE_ITHREADS)
3284 # ifdef OLD_PTHREADS_API
3286 if (pthread_getspecific(PL_thr_key, &t))
3287 Perl_croak_nocontext("panic: pthread_getspecific");
3290 # ifdef I_MACH_CTHREADS
3291 return (void*)cthread_data(cthread_self());
3293 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3302 Perl_set_context(void *t)
3305 #if defined(USE_ITHREADS)
3306 # ifdef I_MACH_CTHREADS
3307 cthread_set_data(cthread_self(), t);
3309 if (pthread_setspecific(PL_thr_key, t))
3310 Perl_croak_nocontext("panic: pthread_setspecific");
3317 #endif /* !PERL_GET_CONTEXT_DEFINED */
3319 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3328 Perl_get_op_names(pTHX)
3330 PERL_UNUSED_CONTEXT;
3331 return (char **)PL_op_name;
3335 Perl_get_op_descs(pTHX)
3337 PERL_UNUSED_CONTEXT;
3338 return (char **)PL_op_desc;
3342 Perl_get_no_modify(pTHX)
3344 PERL_UNUSED_CONTEXT;
3345 return PL_no_modify;
3349 Perl_get_opargs(pTHX)
3351 PERL_UNUSED_CONTEXT;
3352 return (U32 *)PL_opargs;
3356 Perl_get_ppaddr(pTHX)
3359 PERL_UNUSED_CONTEXT;
3360 return (PPADDR_t*)PL_ppaddr;
3363 #ifndef HAS_GETENV_LEN
3365 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3367 char * const env_trans = PerlEnv_getenv(env_elem);
3368 PERL_UNUSED_CONTEXT;
3370 *len = strlen(env_trans);
3377 Perl_get_vtbl(pTHX_ int vtbl_id)
3379 const MGVTBL* result;
3380 PERL_UNUSED_CONTEXT;
3384 result = &PL_vtbl_sv;
3387 result = &PL_vtbl_env;
3389 case want_vtbl_envelem:
3390 result = &PL_vtbl_envelem;
3393 result = &PL_vtbl_sig;
3395 case want_vtbl_sigelem:
3396 result = &PL_vtbl_sigelem;
3398 case want_vtbl_pack:
3399 result = &PL_vtbl_pack;
3401 case want_vtbl_packelem:
3402 result = &PL_vtbl_packelem;
3404 case want_vtbl_dbline:
3405 result = &PL_vtbl_dbline;
3408 result = &PL_vtbl_isa;
3410 case want_vtbl_isaelem:
3411 result = &PL_vtbl_isaelem;
3413 case want_vtbl_arylen:
3414 result = &PL_vtbl_arylen;
3416 case want_vtbl_mglob:
3417 result = &PL_vtbl_mglob;
3419 case want_vtbl_nkeys:
3420 result = &PL_vtbl_nkeys;
3422 case want_vtbl_taint:
3423 result = &PL_vtbl_taint;
3425 case want_vtbl_substr:
3426 result = &PL_vtbl_substr;
3429 result = &PL_vtbl_vec;
3432 result = &PL_vtbl_pos;
3435 result = &PL_vtbl_bm;
3438 result = &PL_vtbl_fm;
3440 case want_vtbl_uvar:
3441 result = &PL_vtbl_uvar;
3443 case want_vtbl_defelem:
3444 result = &PL_vtbl_defelem;
3446 case want_vtbl_regexp:
3447 result = &PL_vtbl_regexp;
3449 case want_vtbl_regdata:
3450 result = &PL_vtbl_regdata;
3452 case want_vtbl_regdatum:
3453 result = &PL_vtbl_regdatum;
3455 #ifdef USE_LOCALE_COLLATE
3456 case want_vtbl_collxfrm:
3457 result = &PL_vtbl_collxfrm;
3460 case want_vtbl_amagic:
3461 result = &PL_vtbl_amagic;
3463 case want_vtbl_amagicelem:
3464 result = &PL_vtbl_amagicelem;
3466 case want_vtbl_backref:
3467 result = &PL_vtbl_backref;
3469 case want_vtbl_utf8:
3470 result = &PL_vtbl_utf8;
3476 return (MGVTBL*)result;
3480 Perl_my_fflush_all(pTHX)
3482 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3483 return PerlIO_flush(NULL);
3485 # if defined(HAS__FWALK)
3486 extern int fflush(FILE *);
3487 /* undocumented, unprototyped, but very useful BSDism */
3488 extern void _fwalk(int (*)(FILE *));
3492 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3494 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3495 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3497 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3498 open_max = sysconf(_SC_OPEN_MAX);
3501 open_max = FOPEN_MAX;
3504 open_max = OPEN_MAX;
3515 for (i = 0; i < open_max; i++)
3516 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3517 STDIO_STREAM_ARRAY[i]._file < open_max &&
3518 STDIO_STREAM_ARRAY[i]._flag)
3519 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3523 SETERRNO(EBADF,RMS_IFI);
3530 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3532 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3534 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3535 if (ckWARN(WARN_IO)) {
3536 const char * const direction =
3537 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3539 Perl_warner(aTHX_ packWARN(WARN_IO),
3540 "Filehandle %s opened only for %sput",
3543 Perl_warner(aTHX_ packWARN(WARN_IO),
3544 "Filehandle opened only for %sput", direction);
3551 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3553 warn_type = WARN_CLOSED;
3557 warn_type = WARN_UNOPENED;
3560 if (ckWARN(warn_type)) {
3561 const char * const pars =
3562 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3563 const char * const func =
3565 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3566 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3567 op < 0 ? "" : /* handle phoney cases */
3569 const char * const type =
3571 (OP_IS_SOCKET(op) ||
3572 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3573 "socket" : "filehandle");
3574 if (name && *name) {
3575 Perl_warner(aTHX_ packWARN(warn_type),
3576 "%s%s on %s %s %s", func, pars, vile, type, name);
3577 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3579 aTHX_ packWARN(warn_type),
3580 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3585 Perl_warner(aTHX_ packWARN(warn_type),
3586 "%s%s on %s %s", func, pars, vile, type);
3587 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3589 aTHX_ packWARN(warn_type),
3590 "\t(Are you trying to call %s%s on dirhandle?)\n",
3599 /* in ASCII order, not that it matters */
3600 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3603 Perl_ebcdic_control(pTHX_ int ch)
3611 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3612 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3615 if (ctlp == controllablechars)
3616 return('\177'); /* DEL */
3618 return((unsigned char)(ctlp - controllablechars - 1));
3619 } else { /* Want uncontrol */
3620 if (ch == '\177' || ch == -1)
3622 else if (ch == '\157')
3624 else if (ch == '\174')
3626 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3628 else if (ch == '\155')
3630 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3631 return(controllablechars[ch+1]);
3633 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3638 /* To workaround core dumps from the uninitialised tm_zone we get the
3639 * system to give us a reasonable struct to copy. This fix means that
3640 * strftime uses the tm_zone and tm_gmtoff values returned by
3641 * localtime(time()). That should give the desired result most of the
3642 * time. But probably not always!
3644 * This does not address tzname aspects of NETaa14816.
3649 # ifndef STRUCT_TM_HASZONE
3650 # define STRUCT_TM_HASZONE
3654 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3655 # ifndef HAS_TM_TM_ZONE
3656 # define HAS_TM_TM_ZONE
3661 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3663 #ifdef HAS_TM_TM_ZONE
3665 const struct tm* my_tm;
3667 my_tm = localtime(&now);
3669 Copy(my_tm, ptm, 1, struct tm);
3671 PERL_UNUSED_ARG(ptm);
3676 * mini_mktime - normalise struct tm values without the localtime()
3677 * semantics (and overhead) of mktime().
3680 Perl_mini_mktime(pTHX_ struct tm *ptm)
3684 int month, mday, year, jday;
3685 int odd_cent, odd_year;
3686 PERL_UNUSED_CONTEXT;
3688 #define DAYS_PER_YEAR 365
3689 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3690 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3691 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3692 #define SECS_PER_HOUR (60*60)
3693 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3694 /* parentheses deliberately absent on these two, otherwise they don't work */
3695 #define MONTH_TO_DAYS 153/5
3696 #define DAYS_TO_MONTH 5/153
3697 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3698 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3699 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3700 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3703 * Year/day algorithm notes:
3705 * With a suitable offset for numeric value of the month, one can find
3706 * an offset into the year by considering months to have 30.6 (153/5) days,
3707 * using integer arithmetic (i.e., with truncation). To avoid too much
3708 * messing about with leap days, we consider January and February to be
3709 * the 13th and 14th month of the previous year. After that transformation,
3710 * we need the month index we use to be high by 1 from 'normal human' usage,
3711 * so the month index values we use run from 4 through 15.
3713 * Given that, and the rules for the Gregorian calendar (leap years are those
3714 * divisible by 4 unless also divisible by 100, when they must be divisible
3715 * by 400 instead), we can simply calculate the number of days since some
3716 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3717 * the days we derive from our month index, and adding in the day of the
3718 * month. The value used here is not adjusted for the actual origin which
3719 * it normally would use (1 January A.D. 1), since we're not exposing it.
3720 * We're only building the value so we can turn around and get the
3721 * normalised values for the year, month, day-of-month, and day-of-year.
3723 * For going backward, we need to bias the value we're using so that we find
3724 * the right year value. (Basically, we don't want the contribution of
3725 * March 1st to the number to apply while deriving the year). Having done
3726 * that, we 'count up' the contribution to the year number by accounting for
3727 * full quadracenturies (400-year periods) with their extra leap days, plus
3728 * the contribution from full centuries (to avoid counting in the lost leap
3729 * days), plus the contribution from full quad-years (to count in the normal
3730 * leap days), plus the leftover contribution from any non-leap years.
3731 * At this point, if we were working with an actual leap day, we'll have 0
3732 * days left over. This is also true for March 1st, however. So, we have
3733 * to special-case that result, and (earlier) keep track of the 'odd'
3734 * century and year contributions. If we got 4 extra centuries in a qcent,
3735 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3736 * Otherwise, we add back in the earlier bias we removed (the 123 from
3737 * figuring in March 1st), find the month index (integer division by 30.6),
3738 * and the remainder is the day-of-month. We then have to convert back to
3739 * 'real' months (including fixing January and February from being 14/15 in
3740 * the previous year to being in the proper year). After that, to get
3741 * tm_yday, we work with the normalised year and get a new yearday value for
3742 * January 1st, which we subtract from the yearday value we had earlier,
3743 * representing the date we've re-built. This is done from January 1
3744 * because tm_yday is 0-origin.
3746 * Since POSIX time routines are only guaranteed to work for times since the
3747 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3748 * applies Gregorian calendar rules even to dates before the 16th century
3749 * doesn't bother me. Besides, you'd need cultural context for a given
3750 * date to know whether it was Julian or Gregorian calendar, and that's
3751 * outside the scope for this routine. Since we convert back based on the
3752 * same rules we used to build the yearday, you'll only get strange results
3753 * for input which needed normalising, or for the 'odd' century years which
3754 * were leap years in the Julian calander but not in the Gregorian one.
3755 * I can live with that.
3757 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3758 * that's still outside the scope for POSIX time manipulation, so I don't
3762 year = 1900 + ptm->tm_year;
3763 month = ptm->tm_mon;
3764 mday = ptm->tm_mday;
3765 /* allow given yday with no month & mday to dominate the result */
3766 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3769 jday = 1 + ptm->tm_yday;
3778 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3779 yearday += month*MONTH_TO_DAYS + mday + jday;
3781 * Note that we don't know when leap-seconds were or will be,
3782 * so we have to trust the user if we get something which looks
3783 * like a sensible leap-second. Wild values for seconds will
3784 * be rationalised, however.
3786 if ((unsigned) ptm->tm_sec <= 60) {
3793 secs += 60 * ptm->tm_min;
3794 secs += SECS_PER_HOUR * ptm->tm_hour;
3796 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3797 /* got negative remainder, but need positive time */
3798 /* back off an extra day to compensate */
3799 yearday += (secs/SECS_PER_DAY)-1;
3800 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3803 yearday += (secs/SECS_PER_DAY);
3804 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3807 else if (secs >= SECS_PER_DAY) {
3808 yearday += (secs/SECS_PER_DAY);
3809 secs %= SECS_PER_DAY;
3811 ptm->tm_hour = secs/SECS_PER_HOUR;
3812 secs %= SECS_PER_HOUR;
3813 ptm->tm_min = secs/60;
3815 ptm->tm_sec += secs;
3816 /* done with time of day effects */
3818 * The algorithm for yearday has (so far) left it high by 428.
3819 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3820 * bias it by 123 while trying to figure out what year it
3821 * really represents. Even with this tweak, the reverse
3822 * translation fails for years before A.D. 0001.
3823 * It would still fail for Feb 29, but we catch that one below.
3825 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3826 yearday -= YEAR_ADJUST;
3827 year = (yearday / DAYS_PER_QCENT) * 400;
3828 yearday %= DAYS_PER_QCENT;
3829 odd_cent = yearday / DAYS_PER_CENT;
3830 year += odd_cent * 100;
3831 yearday %= DAYS_PER_CENT;
3832 year += (yearday / DAYS_PER_QYEAR) * 4;
3833 yearday %= DAYS_PER_QYEAR;
3834 odd_year = yearday / DAYS_PER_YEAR;
3836 yearday %= DAYS_PER_YEAR;
3837 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3842 yearday += YEAR_ADJUST; /* recover March 1st crock */
3843 month = yearday*DAYS_TO_MONTH;
3844 yearday -= month*MONTH_TO_DAYS;
3845 /* recover other leap-year adjustment */
3854 ptm->tm_year = year - 1900;
3856 ptm->tm_mday = yearday;
3857 ptm->tm_mon = month;
3861 ptm->tm_mon = month - 1;
3863 /* re-build yearday based on Jan 1 to get tm_yday */
3865 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3866 yearday += 14*MONTH_TO_DAYS + 1;
3867 ptm->tm_yday = jday - yearday;
3868 /* fix tm_wday if not overridden by caller */
3869 if ((unsigned)ptm->tm_wday > 6)
3870 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3874 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)
3882 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3885 mytm.tm_hour = hour;
3886 mytm.tm_mday = mday;
3888 mytm.tm_year = year;
3889 mytm.tm_wday = wday;
3890 mytm.tm_yday = yday;
3891 mytm.tm_isdst = isdst;
3893 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3894 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3899 #ifdef HAS_TM_TM_GMTOFF
3900 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3902 #ifdef HAS_TM_TM_ZONE
3903 mytm.tm_zone = mytm2.tm_zone;
3908 Newx(buf, buflen, char);
3909 len = strftime(buf, buflen, fmt, &mytm);
3911 ** The following is needed to handle to the situation where
3912 ** tmpbuf overflows. Basically we want to allocate a buffer
3913 ** and try repeatedly. The reason why it is so complicated
3914 ** is that getting a return value of 0 from strftime can indicate
3915 ** one of the following:
3916 ** 1. buffer overflowed,
3917 ** 2. illegal conversion specifier, or
3918 ** 3. the format string specifies nothing to be returned(not
3919 ** an error). This could be because format is an empty string
3920 ** or it specifies %p that yields an empty string in some locale.
3921 ** If there is a better way to make it portable, go ahead by
3924 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3927 /* Possibly buf overflowed - try again with a bigger buf */
3928 const int fmtlen = strlen(fmt);
3929 int bufsize = fmtlen + buflen;
3931 Newx(buf, bufsize, char);
3933 buflen = strftime(buf, bufsize, fmt, &mytm);
3934 if (buflen > 0 && buflen < bufsize)
3936 /* heuristic to prevent out-of-memory errors */
3937 if (bufsize > 100*fmtlen) {
3943 Renew(buf, bufsize, char);
3948 Perl_croak(aTHX_ "panic: no strftime");
3954 #define SV_CWD_RETURN_UNDEF \
3955 sv_setsv(sv, &PL_sv_undef); \
3958 #define SV_CWD_ISDOT(dp) \
3959 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3960 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3963 =head1 Miscellaneous Functions
3965 =for apidoc getcwd_sv
3967 Fill the sv with current working directory
3972 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3973 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3974 * getcwd(3) if available
3975 * Comments from the orignal:
3976 * This is a faster version of getcwd. It's also more dangerous
3977 * because you might chdir out of a directory that you can't chdir
3981 Perl_getcwd_sv(pTHX_ register SV *sv)
3985 #ifndef INCOMPLETE_TAINTS
3991 char buf[MAXPATHLEN];
3993 /* Some getcwd()s automatically allocate a buffer of the given
3994 * size from the heap if they are given a NULL buffer pointer.
3995 * The problem is that this behaviour is not portable. */
3996 if (getcwd(buf, sizeof(buf) - 1)) {
4001 sv_setsv(sv, &PL_sv_undef);
4009 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4013 SvUPGRADE(sv, SVt_PV);
4015 if (PerlLIO_lstat(".", &statbuf) < 0) {
4016 SV_CWD_RETURN_UNDEF;
4019 orig_cdev = statbuf.st_dev;
4020 orig_cino = statbuf.st_ino;
4029 if (PerlDir_chdir("..") < 0) {
4030 SV_CWD_RETURN_UNDEF;
4032 if (PerlLIO_stat(".", &statbuf) < 0) {
4033 SV_CWD_RETURN_UNDEF;
4036 cdev = statbuf.st_dev;
4037 cino = statbuf.st_ino;
4039 if (odev == cdev && oino == cino) {
4042 if (!(dir = PerlDir_open("."))) {
4043 SV_CWD_RETURN_UNDEF;
4046 while ((dp = PerlDir_read(dir)) != NULL) {
4048 const int namelen = dp->d_namlen;
4050 const int namelen = strlen(dp->d_name);
4053 if (SV_CWD_ISDOT(dp)) {
4057 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4058 SV_CWD_RETURN_UNDEF;
4061 tdev = statbuf.st_dev;
4062 tino = statbuf.st_ino;
4063 if (tino == oino && tdev == odev) {
4069 SV_CWD_RETURN_UNDEF;
4072 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4073 SV_CWD_RETURN_UNDEF;
4076 SvGROW(sv, pathlen + namelen + 1);
4080 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4083 /* prepend current directory to the front */
4085 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4086 pathlen += (namelen + 1);
4088 #ifdef VOID_CLOSEDIR
4091 if (PerlDir_close(dir) < 0) {
4092 SV_CWD_RETURN_UNDEF;
4098 SvCUR_set(sv, pathlen);
4102 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4103 SV_CWD_RETURN_UNDEF;
4106 if (PerlLIO_stat(".", &statbuf) < 0) {
4107 SV_CWD_RETURN_UNDEF;
4110 cdev = statbuf.st_dev;
4111 cino = statbuf.st_ino;
4113 if (cdev != orig_cdev || cino != orig_cino) {
4114 Perl_croak(aTHX_ "Unstable directory path, "
4115 "current directory changed unexpectedly");
4127 =for apidoc scan_version
4129 Returns a pointer to the next character after the parsed
4130 version string, as well as upgrading the passed in SV to
4133 Function must be called with an already existing SV like
4136 s = scan_version(s, SV *sv, bool qv);
4138 Performs some preprocessing to the string to ensure that
4139 it has the correct characteristics of a version. Flags the
4140 object if it contains an underscore (which denotes this
4141 is an alpha version). The boolean qv denotes that the version
4142 should be interpreted as if it had multiple decimals, even if
4149 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4157 AV * const av = newAV();
4158 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4159 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4161 #ifndef NODEFAULT_SHAREKEYS
4162 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4165 while (isSPACE(*s)) /* leading whitespace is OK */
4171 s++; /* get past 'v' */
4172 qv = 1; /* force quoted version processing */
4177 /* pre-scan the input string to check for decimals/underbars */
4178 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4183 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4187 else if ( *pos == '_' )
4190 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4192 width = pos - last - 1; /* natural width of sub-version */
4197 if ( alpha && !saw_period )
4198 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4200 if ( alpha && saw_period && width == 0 )
4201 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4203 if ( saw_period > 1 )
4204 qv = 1; /* force quoted version processing */
4209 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4211 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4212 if ( !qv && width < 3 )
4213 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4215 while (isDIGIT(*pos))
4217 if (!isALPHA(*pos)) {
4223 /* this is atoi() that delimits on underscores */
4224 const char *end = pos;
4228 /* the following if() will only be true after the decimal
4229 * point of a version originally created with a bare
4230 * floating point number, i.e. not quoted in any way
4232 if ( !qv && s > start && saw_period == 1 ) {
4236 rev += (*s - '0') * mult;
4238 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4239 Perl_croak(aTHX_ "Integer overflow in version");
4246 while (--end >= s) {
4248 rev += (*end - '0') * mult;
4250 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4251 Perl_croak(aTHX_ "Integer overflow in version");
4256 /* Append revision */
4257 av_push(av, newSViv(rev));
4260 else if ( *pos == '_' && isDIGIT(pos[1]) )
4262 else if ( isDIGIT(*pos) )
4269 while ( isDIGIT(*pos) )
4274 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4282 if ( qv ) { /* quoted versions always get at least three terms*/
4283 I32 len = av_len(av);
4284 /* This for loop appears to trigger a compiler bug on OS X, as it
4285 loops infinitely. Yes, len is negative. No, it makes no sense.
4286 Compiler in question is:
4287 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4288 for ( len = 2 - len; len > 0; len-- )
4289 av_push((AV *)sv, newSViv(0));
4293 av_push(av, newSViv(0));
4296 /* need to save off the current version string for later */
4298 SV * orig = newSVpvn(start,s-start);
4299 if ( qv && saw_period == 1 && *start != 'v' ) {
4300 /* need to insert a v to be consistent */
4301 sv_insert(orig, 0, 0, "v", 1);
4303 hv_store((HV *)hv, "original", 8, orig, 0);
4306 hv_store((HV *)hv, "original", 8, newSVpvn("0",1), 0);
4307 av_push(av, newSViv(0));
4310 /* And finally, store the AV in the hash */
4311 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4313 /* fix RT#19517 - special case 'undef' as string */
4314 if ( *s == 'u' && strEQ(s,"undef") ) {
4322 =for apidoc new_version
4324 Returns a new version object based on the passed in SV:
4326 SV *sv = new_version(SV *ver);
4328 Does not alter the passed in ver SV. See "upg_version" if you
4329 want to upgrade the SV.
4335 Perl_new_version(pTHX_ SV *ver)
4338 SV * const rv = newSV(0);
4339 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4342 AV * const av = newAV();
4344 /* This will get reblessed later if a derived class*/
4345 SV * const hv = newSVrv(rv, "version");
4346 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4347 #ifndef NODEFAULT_SHAREKEYS
4348 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4354 /* Begin copying all of the elements */
4355 if ( hv_exists((HV *)ver, "qv", 2) )
4356 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4358 if ( hv_exists((HV *)ver, "alpha", 5) )
4359 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4361 if ( hv_exists((HV*)ver, "width", 5 ) )
4363 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4364 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4367 if ( hv_exists((HV*)ver, "original", 8 ) )
4369 SV * pv = *hv_fetchs((HV*)ver, "original", FALSE);
4370 hv_store((HV *)hv, "original", 8, newSVsv(pv), 0);
4373 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4374 /* This will get reblessed later if a derived class*/
4375 for ( key = 0; key <= av_len(sav); key++ )
4377 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4378 av_push(av, newSViv(rev));
4381 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4386 const MAGIC* const mg = SvVSTRING_mg(ver);
4387 if ( mg ) { /* already a v-string */
4388 const STRLEN len = mg->mg_len;
4389 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4390 sv_setpvn(rv,version,len);
4391 /* this is for consistency with the pure Perl class */
4392 if ( *version != 'v' )
4393 sv_insert(rv, 0, 0, "v", 1);
4398 sv_setsv(rv,ver); /* make a duplicate */
4403 return upg_version(rv, FALSE);
4407 =for apidoc upg_version
4409 In-place upgrade of the supplied SV to a version object.
4411 SV *sv = upg_version(SV *sv, bool qv);
4413 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4414 to force this SV to be interpreted as an "extended" version.
4420 Perl_upg_version(pTHX_ SV *ver, bool qv)
4422 const char *version, *s;
4427 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4429 /* may get too much accuracy */
4431 #ifdef USE_LOCALE_NUMERIC
4432 char *loc = setlocale(LC_NUMERIC, "C");
4434 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4435 #ifdef USE_LOCALE_NUMERIC
4436 setlocale(LC_NUMERIC, loc);
4438 while (tbuf[len-1] == '0' && len > 0) len--;
4439 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4440 version = savepvn(tbuf, len);
4443 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4444 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4448 else /* must be a string or something like a string */
4451 version = savepv(SvPV(ver,len));
4453 # if PERL_VERSION > 5
4454 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4455 if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4456 /* may be a v-string */
4457 SV * const nsv = sv_newmortal();
4461 sv_setpvf(nsv,"v%vd",ver);
4462 pos = nver = savepv(SvPV_nolen(nsv));
4464 /* scan the resulting formatted string */
4465 pos++; /* skip the leading 'v' */
4466 while ( *pos == '.' || isDIGIT(*pos) ) {
4472 /* is definitely a v-string */
4473 if ( saw_period == 2 ) {
4482 s = scan_version(version, ver, qv);
4484 if(ckWARN(WARN_MISC))
4485 Perl_warner(aTHX_ packWARN(WARN_MISC),
4486 "Version string '%s' contains invalid data; "
4487 "ignoring: '%s'", version, s);
4495 Validates that the SV contains a valid version object.
4497 bool vverify(SV *vobj);
4499 Note that it only confirms the bare minimum structure (so as not to get
4500 confused by derived classes which may contain additional hash entries):
4504 =item * The SV contains a [reference to a] hash
4506 =item * The hash contains a "version" key
4508 =item * The "version" key has [a reference to] an AV as its value
4516 Perl_vverify(pTHX_ SV *vs)
4522 /* see if the appropriate elements exist */
4523 if ( SvTYPE(vs) == SVt_PVHV
4524 && hv_exists((HV*)vs, "version", 7)
4525 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4526 && SvTYPE(sv) == SVt_PVAV )
4535 Accepts a version object and returns the normalized floating
4536 point representation. Call like:
4540 NOTE: you can pass either the object directly or the SV
4541 contained within the RV.
4547 Perl_vnumify(pTHX_ SV *vs)
4552 SV * const sv = newSV(0);
4558 Perl_croak(aTHX_ "Invalid version object");
4560 /* see if various flags exist */
4561 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4563 if ( hv_exists((HV*)vs, "width", 5 ) )
4564 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4569 /* attempt to retrieve the version array */
4570 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4582 digit = SvIV(*av_fetch(av, 0, 0));
4583 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4584 for ( i = 1 ; i < len ; i++ )
4586 digit = SvIV(*av_fetch(av, i, 0));
4588 const int denom = (width == 2 ? 10 : 100);
4589 const div_t term = div((int)PERL_ABS(digit),denom);
4590 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4593 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4599 digit = SvIV(*av_fetch(av, len, 0));
4600 if ( alpha && width == 3 ) /* alpha version */
4602 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4606 sv_catpvs(sv, "000");
4614 Accepts a version object and returns the normalized string
4615 representation. Call like:
4619 NOTE: you can pass either the object directly or the SV
4620 contained within the RV.
4626 Perl_vnormal(pTHX_ SV *vs)
4630 SV * const sv = newSV(0);
4636 Perl_croak(aTHX_ "Invalid version object");
4638 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4640 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4648 digit = SvIV(*av_fetch(av, 0, 0));
4649 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4650 for ( i = 1 ; i < len ; i++ ) {
4651 digit = SvIV(*av_fetch(av, i, 0));
4652 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4657 /* handle last digit specially */
4658 digit = SvIV(*av_fetch(av, len, 0));
4660 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4662 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4665 if ( len <= 2 ) { /* short version, must be at least three */
4666 for ( len = 2 - len; len != 0; len-- )
4673 =for apidoc vstringify
4675 In order to maintain maximum compatibility with earlier versions
4676 of Perl, this function will return either the floating point
4677 notation or the multiple dotted notation, depending on whether
4678 the original version contained 1 or more dots, respectively
4684 Perl_vstringify(pTHX_ SV *vs)
4691 Perl_croak(aTHX_ "Invalid version object");
4693 pv = *hv_fetchs((HV*)vs, "original", FALSE);
4697 return &PL_sv_undef;
4703 Version object aware cmp. Both operands must already have been
4704 converted into version objects.
4710 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4713 bool lalpha = FALSE;
4714 bool ralpha = FALSE;
4723 if ( !vverify(lhv) )
4724 Perl_croak(aTHX_ "Invalid version object");
4726 if ( !vverify(rhv) )
4727 Perl_croak(aTHX_ "Invalid version object");
4729 /* get the left hand term */
4730 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4731 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4734 /* and the right hand term */
4735 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4736 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4744 while ( i <= m && retval == 0 )
4746 left = SvIV(*av_fetch(lav,i,0));
4747 right = SvIV(*av_fetch(rav,i,0));
4755 /* tiebreaker for alpha with identical terms */
4756 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4758 if ( lalpha && !ralpha )
4762 else if ( ralpha && !lalpha)
4768 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4772 while ( i <= r && retval == 0 )
4774 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4775 retval = -1; /* not a match after all */
4781 while ( i <= l && retval == 0 )
4783 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4784 retval = +1; /* not a match after all */
4792 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4793 # define EMULATE_SOCKETPAIR_UDP
4796 #ifdef EMULATE_SOCKETPAIR_UDP
4798 S_socketpair_udp (int fd[2]) {
4800 /* Fake a datagram socketpair using UDP to localhost. */
4801 int sockets[2] = {-1, -1};
4802 struct sockaddr_in addresses[2];
4804 Sock_size_t size = sizeof(struct sockaddr_in);
4805 unsigned short port;
4808 memset(&addresses, 0, sizeof(addresses));
4811 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4812 if (sockets[i] == -1)
4813 goto tidy_up_and_fail;
4815 addresses[i].sin_family = AF_INET;
4816 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4817 addresses[i].sin_port = 0; /* kernel choses port. */
4818 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4819 sizeof(struct sockaddr_in)) == -1)
4820 goto tidy_up_and_fail;
4823 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4824 for each connect the other socket to it. */
4827 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4829 goto tidy_up_and_fail;
4830 if (size != sizeof(struct sockaddr_in))
4831 goto abort_tidy_up_and_fail;
4832 /* !1 is 0, !0 is 1 */
4833 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4834 sizeof(struct sockaddr_in)) == -1)
4835 goto tidy_up_and_fail;
4838 /* Now we have 2 sockets connected to each other. I don't trust some other
4839 process not to have already sent a packet to us (by random) so send
4840 a packet from each to the other. */
4843 /* I'm going to send my own port number. As a short.
4844 (Who knows if someone somewhere has sin_port as a bitfield and needs
4845 this routine. (I'm assuming crays have socketpair)) */
4846 port = addresses[i].sin_port;
4847 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4848 if (got != sizeof(port)) {
4850 goto tidy_up_and_fail;
4851 goto abort_tidy_up_and_fail;
4855 /* Packets sent. I don't trust them to have arrived though.
4856 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4857 connect to localhost will use a second kernel thread. In 2.6 the
4858 first thread running the connect() returns before the second completes,
4859 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4860 returns 0. Poor programs have tripped up. One poor program's authors'
4861 had a 50-1 reverse stock split. Not sure how connected these were.)
4862 So I don't trust someone not to have an unpredictable UDP stack.
4866 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4867 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4871 FD_SET((unsigned int)sockets[0], &rset);
4872 FD_SET((unsigned int)sockets[1], &rset);
4874 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4875 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4876 || !FD_ISSET(sockets[1], &rset)) {
4877 /* I hope this is portable and appropriate. */
4879 goto tidy_up_and_fail;
4880 goto abort_tidy_up_and_fail;
4884 /* And the paranoia department even now doesn't trust it to have arrive
4885 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4887 struct sockaddr_in readfrom;
4888 unsigned short buffer[2];
4893 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4894 sizeof(buffer), MSG_DONTWAIT,
4895 (struct sockaddr *) &readfrom, &size);
4897 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4899 (struct sockaddr *) &readfrom, &size);
4903 goto tidy_up_and_fail;
4904 if (got != sizeof(port)
4905 || size != sizeof(struct sockaddr_in)
4906 /* Check other socket sent us its port. */
4907 || buffer[0] != (unsigned short) addresses[!i].sin_port
4908 /* Check kernel says we got the datagram from that socket */
4909 || readfrom.sin_family != addresses[!i].sin_family
4910 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4911 || readfrom.sin_port != addresses[!i].sin_port)
4912 goto abort_tidy_up_and_fail;
4915 /* My caller (my_socketpair) has validated that this is non-NULL */
4918 /* I hereby declare this connection open. May God bless all who cross
4922 abort_tidy_up_and_fail:
4923 errno = ECONNABORTED;
4926 const int save_errno = errno;
4927 if (sockets[0] != -1)
4928 PerlLIO_close(sockets[0]);
4929 if (sockets[1] != -1)
4930 PerlLIO_close(sockets[1]);
4935 #endif /* EMULATE_SOCKETPAIR_UDP */
4937 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4939 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4940 /* Stevens says that family must be AF_LOCAL, protocol 0.
4941 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4946 struct sockaddr_in listen_addr;
4947 struct sockaddr_in connect_addr;
4952 || family != AF_UNIX
4955 errno = EAFNOSUPPORT;
4963 #ifdef EMULATE_SOCKETPAIR_UDP
4964 if (type == SOCK_DGRAM)
4965 return S_socketpair_udp(fd);
4968 listener = PerlSock_socket(AF_INET, type, 0);
4971 memset(&listen_addr, 0, sizeof(listen_addr));
4972 listen_addr.sin_family = AF_INET;
4973 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4974 listen_addr.sin_port = 0; /* kernel choses port. */
4975 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4976 sizeof(listen_addr)) == -1)
4977 goto tidy_up_and_fail;
4978 if (PerlSock_listen(listener, 1) == -1)
4979 goto tidy_up_and_fail;
4981 connector = PerlSock_socket(AF_INET, type, 0);
4982 if (connector == -1)
4983 goto tidy_up_and_fail;
4984 /* We want to find out the port number to connect to. */
4985 size = sizeof(connect_addr);
4986 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4988 goto tidy_up_and_fail;
4989 if (size != sizeof(connect_addr))
4990 goto abort_tidy_up_and_fail;
4991 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4992 sizeof(connect_addr)) == -1)
4993 goto tidy_up_and_fail;
4995 size = sizeof(listen_addr);
4996 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4999 goto tidy_up_and_fail;
5000 if (size != sizeof(listen_addr))
5001 goto abort_tidy_up_and_fail;
5002 PerlLIO_close(listener);
5003 /* Now check we are talking to ourself by matching port and host on the
5005 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5007 goto tidy_up_and_fail;
5008 if (size != sizeof(connect_addr)
5009 || listen_addr.sin_family != connect_addr.sin_family
5010 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5011 || listen_addr.sin_port != connect_addr.sin_port) {
5012 goto abort_tidy_up_and_fail;
5018 abort_tidy_up_and_fail:
5020 errno = ECONNABORTED; /* This would be the standard thing to do. */
5022 # ifdef ECONNREFUSED
5023 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5025 errno = ETIMEDOUT; /* Desperation time. */
5030 const int save_errno = errno;
5032 PerlLIO_close(listener);
5033 if (connector != -1)
5034 PerlLIO_close(connector);
5036 PerlLIO_close(acceptor);
5042 /* In any case have a stub so that there's code corresponding
5043 * to the my_socketpair in global.sym. */
5045 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5046 #ifdef HAS_SOCKETPAIR
5047 return socketpair(family, type, protocol, fd);
5056 =for apidoc sv_nosharing
5058 Dummy routine which "shares" an SV when there is no sharing module present.
5059 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5060 Exists to avoid test for a NULL function pointer and because it could
5061 potentially warn under some level of strict-ness.
5067 Perl_sv_nosharing(pTHX_ SV *sv)
5069 PERL_UNUSED_CONTEXT;
5070 PERL_UNUSED_ARG(sv);
5074 Perl_parse_unicode_opts(pTHX_ const char **popt)
5076 const char *p = *popt;
5081 opt = (U32) atoi(p);
5084 if (*p && *p != '\n' && *p != '\r')
5085 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5090 case PERL_UNICODE_STDIN:
5091 opt |= PERL_UNICODE_STDIN_FLAG; break;
5092 case PERL_UNICODE_STDOUT:
5093 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5094 case PERL_UNICODE_STDERR:
5095 opt |= PERL_UNICODE_STDERR_FLAG; break;
5096 case PERL_UNICODE_STD:
5097 opt |= PERL_UNICODE_STD_FLAG; break;
5098 case PERL_UNICODE_IN:
5099 opt |= PERL_UNICODE_IN_FLAG; break;
5100 case PERL_UNICODE_OUT:
5101 opt |= PERL_UNICODE_OUT_FLAG; break;
5102 case PERL_UNICODE_INOUT:
5103 opt |= PERL_UNICODE_INOUT_FLAG; break;
5104 case PERL_UNICODE_LOCALE:
5105 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5106 case PERL_UNICODE_ARGV:
5107 opt |= PERL_UNICODE_ARGV_FLAG; break;
5108 case PERL_UNICODE_UTF8CACHEASSERT:
5109 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5111 if (*p != '\n' && *p != '\r')
5113 "Unknown Unicode option letter '%c'", *p);
5119 opt = PERL_UNICODE_DEFAULT_FLAGS;
5121 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5122 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5123 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5135 * This is really just a quick hack which grabs various garbage
5136 * values. It really should be a real hash algorithm which
5137 * spreads the effect of every input bit onto every output bit,
5138 * if someone who knows about such things would bother to write it.
5139 * Might be a good idea to add that function to CORE as well.
5140 * No numbers below come from careful analysis or anything here,
5141 * except they are primes and SEED_C1 > 1E6 to get a full-width
5142 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5143 * probably be bigger too.
5146 # define SEED_C1 1000003
5147 #define SEED_C4 73819
5149 # define SEED_C1 25747
5150 #define SEED_C4 20639
5154 #define SEED_C5 26107
5156 #ifndef PERL_NO_DEV_RANDOM
5161 # include <starlet.h>
5162 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5163 * in 100-ns units, typically incremented ever 10 ms. */
5164 unsigned int when[2];
5166 # ifdef HAS_GETTIMEOFDAY
5167 struct timeval when;
5173 /* This test is an escape hatch, this symbol isn't set by Configure. */
5174 #ifndef PERL_NO_DEV_RANDOM
5175 #ifndef PERL_RANDOM_DEVICE
5176 /* /dev/random isn't used by default because reads from it will block
5177 * if there isn't enough entropy available. You can compile with
5178 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5179 * is enough real entropy to fill the seed. */
5180 # define PERL_RANDOM_DEVICE "/dev/urandom"
5182 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5184 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5193 _ckvmssts(sys$gettim(when));
5194 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5196 # ifdef HAS_GETTIMEOFDAY
5197 PerlProc_gettimeofday(&when,NULL);
5198 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5201 u = (U32)SEED_C1 * when;
5204 u += SEED_C3 * (U32)PerlProc_getpid();
5205 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5206 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5207 u += SEED_C5 * (U32)PTR2UV(&when);
5213 Perl_get_hash_seed(pTHX)
5216 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5222 if (s && isDIGIT(*s))
5223 myseed = (UV)Atoul(s);
5225 #ifdef USE_HASH_SEED_EXPLICIT
5229 /* Compute a random seed */
5230 (void)seedDrand01((Rand_seed_t)seed());
5231 myseed = (UV)(Drand01() * (NV)UV_MAX);
5232 #if RANDBITS < (UVSIZE * 8)
5233 /* Since there are not enough randbits to to reach all
5234 * the bits of a UV, the low bits might need extra
5235 * help. Sum in another random number that will
5236 * fill in the low bits. */
5238 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5239 #endif /* RANDBITS < (UVSIZE * 8) */
5240 if (myseed == 0) { /* Superparanoia. */
5241 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5243 Perl_croak(aTHX_ "Your random numbers are not that random");
5246 PL_rehash_seed_set = TRUE;
5253 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5255 const char * const stashpv = CopSTASHPV(c);
5256 const char * const name = HvNAME_get(hv);
5257 PERL_UNUSED_CONTEXT;
5259 if (stashpv == name)
5261 if (stashpv && name)
5262 if (strEQ(stashpv, name))
5269 #ifdef PERL_GLOBAL_STRUCT
5271 #define PERL_GLOBAL_STRUCT_INIT
5272 #include "opcode.h" /* the ppaddr and check */
5275 Perl_init_global_struct(pTHX)
5277 struct perl_vars *plvarsp = NULL;
5278 # ifdef PERL_GLOBAL_STRUCT
5279 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5280 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5281 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5282 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5283 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5287 plvarsp = PL_VarsPtr;
5288 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5294 # define PERLVAR(var,type) /**/
5295 # define PERLVARA(var,n,type) /**/
5296 # define PERLVARI(var,type,init) plvarsp->var = init;
5297 # define PERLVARIC(var,type,init) plvarsp->var = init;
5298 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5299 # include "perlvars.h"
5305 # ifdef PERL_GLOBAL_STRUCT
5308 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5309 if (!plvarsp->Gppaddr)
5313 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5314 if (!plvarsp->Gcheck)
5316 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5317 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5319 # ifdef PERL_SET_VARS
5320 PERL_SET_VARS(plvarsp);
5322 # undef PERL_GLOBAL_STRUCT_INIT
5327 #endif /* PERL_GLOBAL_STRUCT */
5329 #ifdef PERL_GLOBAL_STRUCT
5332 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5334 # ifdef PERL_GLOBAL_STRUCT
5335 # ifdef PERL_UNSET_VARS
5336 PERL_UNSET_VARS(plvarsp);
5338 free(plvarsp->Gppaddr);
5339 free(plvarsp->Gcheck);
5340 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5346 #endif /* PERL_GLOBAL_STRUCT */
5351 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5353 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5354 * variable PERL_MEM_LOG will be consulted, and if the integer value
5355 * of that is true, the logging will happen. (The default is to
5356 * always log if the PERL_MEM_LOG define was in effect.)
5360 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5361 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5363 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5366 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5367 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5368 * in which case the environment variable PERL_MEM_LOG_FD will be
5369 * consulted for the file descriptor number to use.
5371 #ifndef PERL_MEM_LOG_FD
5372 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5376 Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
5378 #ifdef PERL_MEM_LOG_STDERR
5379 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5382 # ifdef PERL_MEM_LOG_ENV
5383 s = getenv("PERL_MEM_LOG");
5384 if (s ? atoi(s) : 0)
5387 /* We can't use SVs or PerlIO for obvious reasons,
5388 * so we'll use stdio and low-level IO instead. */
5389 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5390 # ifdef PERL_MEM_LOG_TIMESTAMP
5392 # ifdef HAS_GETTIMEOFDAY
5393 gettimeofday(&tv, 0);
5395 /* If there are other OS specific ways of hires time than
5396 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5397 * probably that they would be used to fill in the struct
5404 # ifdef PERL_MEM_LOG_TIMESTAMP
5407 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5408 " %s = %"IVdf": %"UVxf"\n",
5409 # ifdef PERL_MEM_LOG_TIMESTAMP
5410 (int)tv.tv_sec, (int)tv.tv_usec,
5412 filename, linenumber, funcname, n, typesize,
5413 typename, n * typesize, PTR2UV(newalloc));
5414 # ifdef PERL_MEM_LOG_ENV_FD
5415 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5416 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5418 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5427 Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
5429 #ifdef PERL_MEM_LOG_STDERR
5430 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5433 # ifdef PERL_MEM_LOG_ENV
5434 s = PerlEnv_getenv("PERL_MEM_LOG");
5435 if (s ? atoi(s) : 0)
5438 /* We can't use SVs or PerlIO for obvious reasons,
5439 * so we'll use stdio and low-level IO instead. */
5440 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5441 # ifdef PERL_MEM_LOG_TIMESTAMP
5443 gettimeofday(&tv, 0);
5449 # ifdef PERL_MEM_LOG_TIMESTAMP
5452 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5453 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5454 # ifdef PERL_MEM_LOG_TIMESTAMP
5455 (int)tv.tv_sec, (int)tv.tv_usec,
5457 filename, linenumber, funcname, n, typesize,
5458 typename, n * typesize, PTR2UV(oldalloc),
5460 # ifdef PERL_MEM_LOG_ENV_FD
5461 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5462 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5464 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5473 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5475 #ifdef PERL_MEM_LOG_STDERR
5476 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5479 # ifdef PERL_MEM_LOG_ENV
5480 s = PerlEnv_getenv("PERL_MEM_LOG");
5481 if (s ? atoi(s) : 0)
5484 /* We can't use SVs or PerlIO for obvious reasons,
5485 * so we'll use stdio and low-level IO instead. */
5486 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5487 # ifdef PERL_MEM_LOG_TIMESTAMP
5489 gettimeofday(&tv, 0);
5495 # ifdef PERL_MEM_LOG_TIMESTAMP
5498 "free: %s:%d:%s: %"UVxf"\n",
5499 # ifdef PERL_MEM_LOG_TIMESTAMP
5500 (int)tv.tv_sec, (int)tv.tv_usec,
5502 filename, linenumber, funcname,
5504 # ifdef PERL_MEM_LOG_ENV_FD
5505 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5506 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5508 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5516 #endif /* PERL_MEM_LOG */
5519 =for apidoc my_sprintf
5521 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5522 the length of the string written to the buffer. Only rare pre-ANSI systems
5523 need the wrapper function - usually this is a direct call to C<sprintf>.
5527 #ifndef SPRINTF_RETURNS_STRLEN
5529 Perl_my_sprintf(char *buffer, const char* pat, ...)
5532 va_start(args, pat);
5533 vsprintf(buffer, pat, args);
5535 return strlen(buffer);
5540 =for apidoc my_snprintf
5542 The C library C<snprintf> functionality, if available and
5543 standards-compliant (uses C<vsnprintf>, actually). However, if the
5544 C<vsnprintf> is not available, will unfortunately use the unsafe
5545 C<vsprintf> which can overrun the buffer (there is an overrun check,
5546 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5547 getting C<vsnprintf>.
5552 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5557 va_start(ap, format);
5558 #ifdef HAS_VSNPRINTF
5559 retval = vsnprintf(buffer, len, format, ap);
5561 retval = vsprintf(buffer, format, ap);
5564 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5565 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5566 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5571 =for apidoc my_vsnprintf
5573 The C library C<vsnprintf> if available and standards-compliant.
5574 However, if if the C<vsnprintf> is not available, will unfortunately
5575 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5576 overrun check, but that may be too late). Consider using
5577 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5582 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5588 Perl_va_copy(ap, apc);
5589 # ifdef HAS_VSNPRINTF
5590 retval = vsnprintf(buffer, len, format, apc);
5592 retval = vsprintf(buffer, format, apc);
5595 # ifdef HAS_VSNPRINTF
5596 retval = vsnprintf(buffer, len, format, ap);
5598 retval = vsprintf(buffer, format, ap);
5600 #endif /* #ifdef NEED_VA_COPY */
5601 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5602 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5603 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5608 Perl_my_clearenv(pTHX)
5611 #if ! defined(PERL_MICRO)
5612 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5614 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5615 # if defined(USE_ENVIRON_ARRAY)
5616 # if defined(USE_ITHREADS)
5617 /* only the parent thread can clobber the process environment */
5618 if (PL_curinterp == aTHX)
5619 # endif /* USE_ITHREADS */
5621 # if ! defined(PERL_USE_SAFE_PUTENV)
5622 if ( !PL_use_safe_putenv) {
5624 if (environ == PL_origenviron)
5625 environ = (char**)safesysmalloc(sizeof(char*));
5627 for (i = 0; environ[i]; i++)
5628 (void)safesysfree(environ[i]);
5631 # else /* PERL_USE_SAFE_PUTENV */
5632 # if defined(HAS_CLEARENV)
5634 # elif defined(HAS_UNSETENV)
5635 int bsiz = 80; /* Most envvar names will be shorter than this. */
5636 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5637 char *buf = (char*)safesysmalloc(bufsiz);
5638 while (*environ != NULL) {
5639 char *e = strchr(*environ, '=');
5640 int l = e ? e - *environ : (int)strlen(*environ);
5642 (void)safesysfree(buf);
5643 bsiz = l + 1; /* + 1 for the \0. */
5644 buf = (char*)safesysmalloc(bufsiz);
5646 my_strlcpy(buf, *environ, l + 1);
5647 (void)unsetenv(buf);
5649 (void)safesysfree(buf);
5650 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5651 /* Just null environ and accept the leakage. */
5653 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5654 # endif /* ! PERL_USE_SAFE_PUTENV */
5656 # endif /* USE_ENVIRON_ARRAY */
5657 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5658 #endif /* PERL_MICRO */
5661 #ifdef PERL_IMPLICIT_CONTEXT
5663 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5664 the global PL_my_cxt_index is incremented, and that value is assigned to
5665 that module's static my_cxt_index (who's address is passed as an arg).
5666 Then, for each interpreter this function is called for, it makes sure a
5667 void* slot is available to hang the static data off, by allocating or
5668 extending the interpreter's PL_my_cxt_list array */
5670 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5672 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5677 /* this module hasn't been allocated an index yet */
5678 MUTEX_LOCK(&PL_my_ctx_mutex);
5679 *index = PL_my_cxt_index++;
5680 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5683 /* make sure the array is big enough */
5684 if (PL_my_cxt_size <= *index) {
5685 if (PL_my_cxt_size) {
5686 while (PL_my_cxt_size <= *index)
5687 PL_my_cxt_size *= 2;
5688 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5691 PL_my_cxt_size = 16;
5692 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5695 /* newSV() allocates one more than needed */
5696 p = (void*)SvPVX(newSV(size-1));
5697 PL_my_cxt_list[*index] = p;
5698 Zero(p, size, char);
5702 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5705 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5710 for (index = 0; index < PL_my_cxt_index; index++) {
5711 const char *key = PL_my_cxt_keys[index];
5712 /* try direct pointer compare first - there are chances to success,
5713 * and it's much faster.
5715 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5722 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5728 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5730 /* this module hasn't been allocated an index yet */
5731 MUTEX_LOCK(&PL_my_ctx_mutex);
5732 index = PL_my_cxt_index++;
5733 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5736 /* make sure the array is big enough */
5737 if (PL_my_cxt_size <= index) {
5738 int old_size = PL_my_cxt_size;
5740 if (PL_my_cxt_size) {
5741 while (PL_my_cxt_size <= index)
5742 PL_my_cxt_size *= 2;
5743 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5744 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5747 PL_my_cxt_size = 16;
5748 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5749 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5751 for (i = old_size; i < PL_my_cxt_size; i++) {
5752 PL_my_cxt_keys[i] = 0;
5753 PL_my_cxt_list[i] = 0;
5756 PL_my_cxt_keys[index] = my_cxt_key;
5757 /* newSV() allocates one more than needed */
5758 p = (void*)SvPVX(newSV(size-1));
5759 PL_my_cxt_list[index] = p;
5760 Zero(p, size, char);
5763 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5764 #endif /* PERL_IMPLICIT_CONTEXT */
5768 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5770 Size_t used, length, copy;
5773 length = strlen(src);
5774 if (size > 0 && used < size - 1) {
5775 copy = (length >= size - used) ? size - used - 1 : length;
5776 memcpy(dst + used, src, copy);
5777 dst[used + copy] = '\0';
5779 return used + length;
5785 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5787 Size_t length, copy;
5789 length = strlen(src);
5791 copy = (length >= size) ? size - 1 : length;
5792 memcpy(dst, src, copy);
5799 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5800 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5801 long _ftol( double ); /* Defined by VC6 C libs. */
5802 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5806 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5809 SV * const dbsv = GvSVn(PL_DBsub);
5810 /* We do not care about using sv to call CV;
5811 * it's for informational purposes only.
5815 if (!PERLDB_SUB_NN) {
5816 GV * const gv = CvGV(cv);
5818 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5819 || strEQ(GvNAME(gv), "END")
5820 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5821 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5822 /* Use GV from the stack as a fallback. */
5823 /* GV is potentially non-unique, or contain different CV. */
5824 SV * const tmp = newRV((SV*)cv);
5825 sv_setsv(dbsv, tmp);
5829 gv_efullname3(dbsv, gv, NULL);
5833 const int type = SvTYPE(dbsv);
5834 if (type < SVt_PVIV && type != SVt_IV)
5835 sv_upgrade(dbsv, SVt_PVIV);
5836 (void)SvIOK_on(dbsv);
5837 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5842 Perl_my_dirfd(pTHX_ DIR * dir) {
5844 /* Most dirfd implementations have problems when passed NULL. */
5849 #elif defined(HAS_DIR_DD_FD)
5852 Perl_die(aTHX_ PL_no_func, "dirfd");
5860 * c-indentation-style: bsd
5862 * indent-tabs-mode: t
5865 * ex: set ts=8 sts=4 sw=4 noet: