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 */
1836 #ifdef USE_CHAR_VSPRINTF
1841 vsprintf(char *dest, const char *pat, char *args)
1845 fakebuf._ptr = dest;
1846 fakebuf._cnt = 32767;
1850 fakebuf._flag = _IOWRT|_IOSTRG;
1851 _doprnt(pat, args, &fakebuf); /* what a kludge */
1852 (void)putc('\0', &fakebuf);
1853 #ifdef USE_CHAR_VSPRINTF
1856 return 0; /* perl doesn't use return value */
1860 #endif /* HAS_VPRINTF */
1863 #if BYTEORDER != 0x4321
1865 Perl_my_swap(pTHX_ short s)
1867 #if (BYTEORDER & 1) == 0
1870 result = ((s & 255) << 8) + ((s >> 8) & 255);
1878 Perl_my_htonl(pTHX_ long l)
1882 char c[sizeof(long)];
1885 #if BYTEORDER == 0x1234
1886 u.c[0] = (l >> 24) & 255;
1887 u.c[1] = (l >> 16) & 255;
1888 u.c[2] = (l >> 8) & 255;
1892 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1893 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1898 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1899 u.c[o & 0xf] = (l >> s) & 255;
1907 Perl_my_ntohl(pTHX_ long l)
1911 char c[sizeof(long)];
1914 #if BYTEORDER == 0x1234
1915 u.c[0] = (l >> 24) & 255;
1916 u.c[1] = (l >> 16) & 255;
1917 u.c[2] = (l >> 8) & 255;
1921 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1922 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1929 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1930 l |= (u.c[o & 0xf] & 255) << s;
1937 #endif /* BYTEORDER != 0x4321 */
1941 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1942 * If these functions are defined,
1943 * the BYTEORDER is neither 0x1234 nor 0x4321.
1944 * However, this is not assumed.
1948 #define HTOLE(name,type) \
1950 name (register type n) \
1954 char c[sizeof(type)]; \
1957 register U32 s = 0; \
1958 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1959 u.c[i] = (n >> s) & 0xFF; \
1964 #define LETOH(name,type) \
1966 name (register type n) \
1970 char c[sizeof(type)]; \
1973 register U32 s = 0; \
1976 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1977 n |= ((type)(u.c[i] & 0xFF)) << s; \
1983 * Big-endian byte order functions.
1986 #define HTOBE(name,type) \
1988 name (register type n) \
1992 char c[sizeof(type)]; \
1995 register U32 s = 8*(sizeof(u.c)-1); \
1996 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1997 u.c[i] = (n >> s) & 0xFF; \
2002 #define BETOH(name,type) \
2004 name (register type n) \
2008 char c[sizeof(type)]; \
2011 register U32 s = 8*(sizeof(u.c)-1); \
2014 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2015 n |= ((type)(u.c[i] & 0xFF)) << s; \
2021 * If we just can't do it...
2024 #define NOT_AVAIL(name,type) \
2026 name (register type n) \
2028 Perl_croak_nocontext(#name "() not available"); \
2029 return n; /* not reached */ \
2033 #if defined(HAS_HTOVS) && !defined(htovs)
2036 #if defined(HAS_HTOVL) && !defined(htovl)
2039 #if defined(HAS_VTOHS) && !defined(vtohs)
2042 #if defined(HAS_VTOHL) && !defined(vtohl)
2046 #ifdef PERL_NEED_MY_HTOLE16
2048 HTOLE(Perl_my_htole16,U16)
2050 NOT_AVAIL(Perl_my_htole16,U16)
2053 #ifdef PERL_NEED_MY_LETOH16
2055 LETOH(Perl_my_letoh16,U16)
2057 NOT_AVAIL(Perl_my_letoh16,U16)
2060 #ifdef PERL_NEED_MY_HTOBE16
2062 HTOBE(Perl_my_htobe16,U16)
2064 NOT_AVAIL(Perl_my_htobe16,U16)
2067 #ifdef PERL_NEED_MY_BETOH16
2069 BETOH(Perl_my_betoh16,U16)
2071 NOT_AVAIL(Perl_my_betoh16,U16)
2075 #ifdef PERL_NEED_MY_HTOLE32
2077 HTOLE(Perl_my_htole32,U32)
2079 NOT_AVAIL(Perl_my_htole32,U32)
2082 #ifdef PERL_NEED_MY_LETOH32
2084 LETOH(Perl_my_letoh32,U32)
2086 NOT_AVAIL(Perl_my_letoh32,U32)
2089 #ifdef PERL_NEED_MY_HTOBE32
2091 HTOBE(Perl_my_htobe32,U32)
2093 NOT_AVAIL(Perl_my_htobe32,U32)
2096 #ifdef PERL_NEED_MY_BETOH32
2098 BETOH(Perl_my_betoh32,U32)
2100 NOT_AVAIL(Perl_my_betoh32,U32)
2104 #ifdef PERL_NEED_MY_HTOLE64
2106 HTOLE(Perl_my_htole64,U64)
2108 NOT_AVAIL(Perl_my_htole64,U64)
2111 #ifdef PERL_NEED_MY_LETOH64
2113 LETOH(Perl_my_letoh64,U64)
2115 NOT_AVAIL(Perl_my_letoh64,U64)
2118 #ifdef PERL_NEED_MY_HTOBE64
2120 HTOBE(Perl_my_htobe64,U64)
2122 NOT_AVAIL(Perl_my_htobe64,U64)
2125 #ifdef PERL_NEED_MY_BETOH64
2127 BETOH(Perl_my_betoh64,U64)
2129 NOT_AVAIL(Perl_my_betoh64,U64)
2133 #ifdef PERL_NEED_MY_HTOLES
2134 HTOLE(Perl_my_htoles,short)
2136 #ifdef PERL_NEED_MY_LETOHS
2137 LETOH(Perl_my_letohs,short)
2139 #ifdef PERL_NEED_MY_HTOBES
2140 HTOBE(Perl_my_htobes,short)
2142 #ifdef PERL_NEED_MY_BETOHS
2143 BETOH(Perl_my_betohs,short)
2146 #ifdef PERL_NEED_MY_HTOLEI
2147 HTOLE(Perl_my_htolei,int)
2149 #ifdef PERL_NEED_MY_LETOHI
2150 LETOH(Perl_my_letohi,int)
2152 #ifdef PERL_NEED_MY_HTOBEI
2153 HTOBE(Perl_my_htobei,int)
2155 #ifdef PERL_NEED_MY_BETOHI
2156 BETOH(Perl_my_betohi,int)
2159 #ifdef PERL_NEED_MY_HTOLEL
2160 HTOLE(Perl_my_htolel,long)
2162 #ifdef PERL_NEED_MY_LETOHL
2163 LETOH(Perl_my_letohl,long)
2165 #ifdef PERL_NEED_MY_HTOBEL
2166 HTOBE(Perl_my_htobel,long)
2168 #ifdef PERL_NEED_MY_BETOHL
2169 BETOH(Perl_my_betohl,long)
2173 Perl_my_swabn(void *ptr, int n)
2175 register char *s = (char *)ptr;
2176 register char *e = s + (n-1);
2179 for (n /= 2; n > 0; s++, e--, n--) {
2187 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2189 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2192 register I32 This, that;
2198 PERL_FLUSHALL_FOR_CHILD;
2199 This = (*mode == 'w');
2203 taint_proper("Insecure %s%s", "EXEC");
2205 if (PerlProc_pipe(p) < 0)
2207 /* Try for another pipe pair for error return */
2208 if (PerlProc_pipe(pp) >= 0)
2210 while ((pid = PerlProc_fork()) < 0) {
2211 if (errno != EAGAIN) {
2212 PerlLIO_close(p[This]);
2213 PerlLIO_close(p[that]);
2215 PerlLIO_close(pp[0]);
2216 PerlLIO_close(pp[1]);
2228 /* Close parent's end of error status pipe (if any) */
2230 PerlLIO_close(pp[0]);
2231 #if defined(HAS_FCNTL) && defined(F_SETFD)
2232 /* Close error pipe automatically if exec works */
2233 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2236 /* Now dup our end of _the_ pipe to right position */
2237 if (p[THIS] != (*mode == 'r')) {
2238 PerlLIO_dup2(p[THIS], *mode == 'r');
2239 PerlLIO_close(p[THIS]);
2240 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2241 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2244 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2245 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2246 /* No automatic close - do it by hand */
2253 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2259 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2265 do_execfree(); /* free any memory malloced by child on fork */
2267 PerlLIO_close(pp[1]);
2268 /* Keep the lower of the two fd numbers */
2269 if (p[that] < p[This]) {
2270 PerlLIO_dup2(p[This], p[that]);
2271 PerlLIO_close(p[This]);
2275 PerlLIO_close(p[that]); /* close child's end of pipe */
2278 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2280 SvUPGRADE(sv,SVt_IV);
2282 PL_forkprocess = pid;
2283 /* If we managed to get status pipe check for exec fail */
2284 if (did_pipes && pid > 0) {
2289 while (n < sizeof(int)) {
2290 n1 = PerlLIO_read(pp[0],
2291 (void*)(((char*)&errkid)+n),
2297 PerlLIO_close(pp[0]);
2299 if (n) { /* Error */
2301 PerlLIO_close(p[This]);
2302 if (n != sizeof(int))
2303 Perl_croak(aTHX_ "panic: kid popen errno read");
2305 pid2 = wait4pid(pid, &status, 0);
2306 } while (pid2 == -1 && errno == EINTR);
2307 errno = errkid; /* Propagate errno from kid */
2312 PerlLIO_close(pp[0]);
2313 return PerlIO_fdopen(p[This], mode);
2315 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2316 return my_syspopen4(aTHX_ Nullch, mode, n, args);
2318 Perl_croak(aTHX_ "List form of piped open not implemented");
2319 return (PerlIO *) NULL;
2324 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2325 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2327 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2331 register I32 This, that;
2334 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2338 PERL_FLUSHALL_FOR_CHILD;
2341 return my_syspopen(aTHX_ cmd,mode);
2344 This = (*mode == 'w');
2346 if (doexec && PL_tainting) {
2348 taint_proper("Insecure %s%s", "EXEC");
2350 if (PerlProc_pipe(p) < 0)
2352 if (doexec && PerlProc_pipe(pp) >= 0)
2354 while ((pid = PerlProc_fork()) < 0) {
2355 if (errno != EAGAIN) {
2356 PerlLIO_close(p[This]);
2357 PerlLIO_close(p[that]);
2359 PerlLIO_close(pp[0]);
2360 PerlLIO_close(pp[1]);
2363 Perl_croak(aTHX_ "Can't fork");
2376 PerlLIO_close(pp[0]);
2377 #if defined(HAS_FCNTL) && defined(F_SETFD)
2378 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2381 if (p[THIS] != (*mode == 'r')) {
2382 PerlLIO_dup2(p[THIS], *mode == 'r');
2383 PerlLIO_close(p[THIS]);
2384 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2385 PerlLIO_close(p[THAT]);
2388 PerlLIO_close(p[THAT]);
2391 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2398 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2403 /* may or may not use the shell */
2404 do_exec3(cmd, pp[1], did_pipes);
2407 #endif /* defined OS2 */
2409 #ifdef PERLIO_USING_CRLF
2410 /* Since we circumvent IO layers when we manipulate low-level
2411 filedescriptors directly, need to manually switch to the
2412 default, binary, low-level mode; see PerlIOBuf_open(). */
2413 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2416 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2417 SvREADONLY_off(GvSV(tmpgv));
2418 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2419 SvREADONLY_on(GvSV(tmpgv));
2421 #ifdef THREADS_HAVE_PIDS
2422 PL_ppid = (IV)getppid();
2425 #ifdef PERL_USES_PL_PIDSTATUS
2426 hv_clear(PL_pidstatus); /* we have no children */
2432 do_execfree(); /* free any memory malloced by child on vfork */
2434 PerlLIO_close(pp[1]);
2435 if (p[that] < p[This]) {
2436 PerlLIO_dup2(p[This], p[that]);
2437 PerlLIO_close(p[This]);
2441 PerlLIO_close(p[that]);
2444 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2446 SvUPGRADE(sv,SVt_IV);
2448 PL_forkprocess = pid;
2449 if (did_pipes && pid > 0) {
2454 while (n < sizeof(int)) {
2455 n1 = PerlLIO_read(pp[0],
2456 (void*)(((char*)&errkid)+n),
2462 PerlLIO_close(pp[0]);
2464 if (n) { /* Error */
2466 PerlLIO_close(p[This]);
2467 if (n != sizeof(int))
2468 Perl_croak(aTHX_ "panic: kid popen errno read");
2470 pid2 = wait4pid(pid, &status, 0);
2471 } while (pid2 == -1 && errno == EINTR);
2472 errno = errkid; /* Propagate errno from kid */
2477 PerlLIO_close(pp[0]);
2478 return PerlIO_fdopen(p[This], mode);
2481 #if defined(atarist) || defined(EPOC)
2484 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2486 PERL_FLUSHALL_FOR_CHILD;
2487 /* Call system's popen() to get a FILE *, then import it.
2488 used 0 for 2nd parameter to PerlIO_importFILE;
2491 return PerlIO_importFILE(popen(cmd, mode), 0);
2495 FILE *djgpp_popen();
2497 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2499 PERL_FLUSHALL_FOR_CHILD;
2500 /* Call system's popen() to get a FILE *, then import it.
2501 used 0 for 2nd parameter to PerlIO_importFILE;
2504 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2509 #endif /* !DOSISH */
2511 /* this is called in parent before the fork() */
2513 Perl_atfork_lock(void)
2516 #if defined(USE_ITHREADS)
2517 /* locks must be held in locking order (if any) */
2519 MUTEX_LOCK(&PL_malloc_mutex);
2525 /* this is called in both parent and child after the fork() */
2527 Perl_atfork_unlock(void)
2530 #if defined(USE_ITHREADS)
2531 /* locks must be released in same order as in atfork_lock() */
2533 MUTEX_UNLOCK(&PL_malloc_mutex);
2542 #if defined(HAS_FORK)
2544 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2549 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2550 * handlers elsewhere in the code */
2555 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2556 Perl_croak_nocontext("fork() not available");
2558 #endif /* HAS_FORK */
2563 Perl_dump_fds(pTHX_ char *s)
2568 PerlIO_printf(Perl_debug_log,"%s", s);
2569 for (fd = 0; fd < 32; fd++) {
2570 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2571 PerlIO_printf(Perl_debug_log," %d",fd);
2573 PerlIO_printf(Perl_debug_log,"\n");
2576 #endif /* DUMP_FDS */
2580 dup2(int oldfd, int newfd)
2582 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2585 PerlLIO_close(newfd);
2586 return fcntl(oldfd, F_DUPFD, newfd);
2588 #define DUP2_MAX_FDS 256
2589 int fdtmp[DUP2_MAX_FDS];
2595 PerlLIO_close(newfd);
2596 /* good enough for low fd's... */
2597 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2598 if (fdx >= DUP2_MAX_FDS) {
2606 PerlLIO_close(fdtmp[--fdx]);
2613 #ifdef HAS_SIGACTION
2615 #ifdef MACOS_TRADITIONAL
2616 /* We don't want restart behavior on MacOS */
2621 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2624 struct sigaction act, oact;
2627 /* only "parent" interpreter can diddle signals */
2628 if (PL_curinterp != aTHX)
2629 return (Sighandler_t) SIG_ERR;
2632 act.sa_handler = (void(*)(int))handler;
2633 sigemptyset(&act.sa_mask);
2636 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2637 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2639 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2640 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2641 act.sa_flags |= SA_NOCLDWAIT;
2643 if (sigaction(signo, &act, &oact) == -1)
2644 return (Sighandler_t) SIG_ERR;
2646 return (Sighandler_t) oact.sa_handler;
2650 Perl_rsignal_state(pTHX_ int signo)
2652 struct sigaction oact;
2653 PERL_UNUSED_CONTEXT;
2655 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2656 return (Sighandler_t) SIG_ERR;
2658 return (Sighandler_t) oact.sa_handler;
2662 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2665 struct sigaction act;
2668 /* only "parent" interpreter can diddle signals */
2669 if (PL_curinterp != aTHX)
2673 act.sa_handler = (void(*)(int))handler;
2674 sigemptyset(&act.sa_mask);
2677 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2678 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2680 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2681 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2682 act.sa_flags |= SA_NOCLDWAIT;
2684 return sigaction(signo, &act, save);
2688 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2692 /* only "parent" interpreter can diddle signals */
2693 if (PL_curinterp != aTHX)
2697 return sigaction(signo, save, (struct sigaction *)NULL);
2700 #else /* !HAS_SIGACTION */
2703 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2705 #if defined(USE_ITHREADS) && !defined(WIN32)
2706 /* only "parent" interpreter can diddle signals */
2707 if (PL_curinterp != aTHX)
2708 return (Sighandler_t) SIG_ERR;
2711 return PerlProc_signal(signo, handler);
2722 Perl_rsignal_state(pTHX_ int signo)
2725 Sighandler_t oldsig;
2727 #if defined(USE_ITHREADS) && !defined(WIN32)
2728 /* only "parent" interpreter can diddle signals */
2729 if (PL_curinterp != aTHX)
2730 return (Sighandler_t) SIG_ERR;
2734 oldsig = PerlProc_signal(signo, sig_trap);
2735 PerlProc_signal(signo, oldsig);
2737 PerlProc_kill(PerlProc_getpid(), signo);
2742 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2744 #if defined(USE_ITHREADS) && !defined(WIN32)
2745 /* only "parent" interpreter can diddle signals */
2746 if (PL_curinterp != aTHX)
2749 *save = PerlProc_signal(signo, handler);
2750 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2754 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2756 #if defined(USE_ITHREADS) && !defined(WIN32)
2757 /* only "parent" interpreter can diddle signals */
2758 if (PL_curinterp != aTHX)
2761 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2764 #endif /* !HAS_SIGACTION */
2765 #endif /* !PERL_MICRO */
2767 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2768 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2770 Perl_my_pclose(pTHX_ PerlIO *ptr)
2773 Sigsave_t hstat, istat, qstat;
2779 int saved_errno = 0;
2781 int saved_win32_errno;
2785 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2787 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2789 *svp = &PL_sv_undef;
2791 if (pid == -1) { /* Opened by popen. */
2792 return my_syspclose(ptr);
2795 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2796 saved_errno = errno;
2798 saved_win32_errno = GetLastError();
2802 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2805 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2806 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2807 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2810 pid2 = wait4pid(pid, &status, 0);
2811 } while (pid2 == -1 && errno == EINTR);
2813 rsignal_restore(SIGHUP, &hstat);
2814 rsignal_restore(SIGINT, &istat);
2815 rsignal_restore(SIGQUIT, &qstat);
2818 SETERRNO(saved_errno, 0);
2821 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2823 #endif /* !DOSISH */
2825 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2827 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2833 #ifdef PERL_USES_PL_PIDSTATUS
2836 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2837 pid, rather than a string form. */
2838 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2839 if (svp && *svp != &PL_sv_undef) {
2840 *statusp = SvIVX(*svp);
2841 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2849 hv_iterinit(PL_pidstatus);
2850 if ((entry = hv_iternext(PL_pidstatus))) {
2851 SV * const sv = hv_iterval(PL_pidstatus,entry);
2853 const char * const spid = hv_iterkey(entry,&len);
2855 assert (len == sizeof(Pid_t));
2856 memcpy((char *)&pid, spid, len);
2857 *statusp = SvIVX(sv);
2858 /* The hash iterator is currently on this entry, so simply
2859 calling hv_delete would trigger the lazy delete, which on
2860 aggregate does more work, beacuse next call to hv_iterinit()
2861 would spot the flag, and have to call the delete routine,
2862 while in the meantime any new entries can't re-use that
2864 hv_iterinit(PL_pidstatus);
2865 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2872 # ifdef HAS_WAITPID_RUNTIME
2873 if (!HAS_WAITPID_RUNTIME)
2876 result = PerlProc_waitpid(pid,statusp,flags);
2879 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2880 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2883 #ifdef PERL_USES_PL_PIDSTATUS
2884 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2889 Perl_croak(aTHX_ "Can't do waitpid with flags");
2891 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2892 pidgone(result,*statusp);
2898 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2901 if (result < 0 && errno == EINTR) {
2906 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2908 #ifdef PERL_USES_PL_PIDSTATUS
2910 Perl_pidgone(pTHX_ Pid_t pid, int status)
2914 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2915 SvUPGRADE(sv,SVt_IV);
2916 SvIV_set(sv, status);
2921 #if defined(atarist) || defined(OS2) || defined(EPOC)
2924 int /* Cannot prototype with I32
2926 my_syspclose(PerlIO *ptr)
2929 Perl_my_pclose(pTHX_ PerlIO *ptr)
2932 /* Needs work for PerlIO ! */
2933 FILE * const f = PerlIO_findFILE(ptr);
2934 const I32 result = pclose(f);
2935 PerlIO_releaseFILE(ptr,f);
2943 Perl_my_pclose(pTHX_ PerlIO *ptr)
2945 /* Needs work for PerlIO ! */
2946 FILE * const f = PerlIO_findFILE(ptr);
2947 I32 result = djgpp_pclose(f);
2948 result = (result << 8) & 0xff00;
2949 PerlIO_releaseFILE(ptr,f);
2955 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2958 register const char * const frombase = from;
2959 PERL_UNUSED_CONTEXT;
2962 register const char c = *from;
2967 while (count-- > 0) {
2968 for (todo = len; todo > 0; todo--) {
2977 Perl_same_dirent(pTHX_ const char *a, const char *b)
2979 char *fa = strrchr(a,'/');
2980 char *fb = strrchr(b,'/');
2983 SV * const tmpsv = sv_newmortal();
2996 sv_setpvn(tmpsv, ".", 1);
2998 sv_setpvn(tmpsv, a, fa - a);
2999 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3002 sv_setpvn(tmpsv, ".", 1);
3004 sv_setpvn(tmpsv, b, fb - b);
3005 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3007 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3008 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3010 #endif /* !HAS_RENAME */
3013 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3014 const char *const *const search_ext, I32 flags)
3017 const char *xfound = NULL;
3018 char *xfailed = NULL;
3019 char tmpbuf[MAXPATHLEN];
3023 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3024 # define SEARCH_EXTS ".bat", ".cmd", NULL
3025 # define MAX_EXT_LEN 4
3028 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3029 # define MAX_EXT_LEN 4
3032 # define SEARCH_EXTS ".pl", ".com", NULL
3033 # define MAX_EXT_LEN 4
3035 /* additional extensions to try in each dir if scriptname not found */
3037 static const char *const exts[] = { SEARCH_EXTS };
3038 const char *const *const ext = search_ext ? search_ext : exts;
3039 int extidx = 0, i = 0;
3040 const char *curext = NULL;
3042 PERL_UNUSED_ARG(search_ext);
3043 # define MAX_EXT_LEN 0
3047 * If dosearch is true and if scriptname does not contain path
3048 * delimiters, search the PATH for scriptname.
3050 * If SEARCH_EXTS is also defined, will look for each
3051 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3052 * while searching the PATH.
3054 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3055 * proceeds as follows:
3056 * If DOSISH or VMSISH:
3057 * + look for ./scriptname{,.foo,.bar}
3058 * + search the PATH for scriptname{,.foo,.bar}
3061 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3062 * this will not look in '.' if it's not in the PATH)
3067 # ifdef ALWAYS_DEFTYPES
3068 len = strlen(scriptname);
3069 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3070 int idx = 0, deftypes = 1;
3073 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3076 int idx = 0, deftypes = 1;
3079 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3081 /* The first time through, just add SEARCH_EXTS to whatever we
3082 * already have, so we can check for default file types. */
3084 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3090 if ((strlen(tmpbuf) + strlen(scriptname)
3091 + MAX_EXT_LEN) >= sizeof tmpbuf)
3092 continue; /* don't search dir with too-long name */
3093 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3097 if (strEQ(scriptname, "-"))
3099 if (dosearch) { /* Look in '.' first. */
3100 const char *cur = scriptname;
3102 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3104 if (strEQ(ext[i++],curext)) {
3105 extidx = -1; /* already has an ext */
3110 DEBUG_p(PerlIO_printf(Perl_debug_log,
3111 "Looking for %s\n",cur));
3112 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3113 && !S_ISDIR(PL_statbuf.st_mode)) {
3121 if (cur == scriptname) {
3122 len = strlen(scriptname);
3123 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3125 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3128 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3129 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3134 #ifdef MACOS_TRADITIONAL
3135 if (dosearch && !strchr(scriptname, ':') &&
3136 (s = PerlEnv_getenv("Commands")))
3138 if (dosearch && !strchr(scriptname, '/')
3140 && !strchr(scriptname, '\\')
3142 && (s = PerlEnv_getenv("PATH")))
3147 PL_bufend = s + strlen(s);
3148 while (s < PL_bufend) {
3149 #ifdef MACOS_TRADITIONAL
3150 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3154 #if defined(atarist) || defined(DOSISH)
3159 && *s != ';'; len++, s++) {
3160 if (len < sizeof tmpbuf)
3163 if (len < sizeof tmpbuf)
3165 #else /* ! (atarist || DOSISH) */
3166 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3169 #endif /* ! (atarist || DOSISH) */
3170 #endif /* MACOS_TRADITIONAL */
3173 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3174 continue; /* don't search dir with too-long name */
3175 #ifdef MACOS_TRADITIONAL
3176 if (len && tmpbuf[len - 1] != ':')
3177 tmpbuf[len++] = ':';
3180 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3181 && tmpbuf[len - 1] != '/'
3182 && tmpbuf[len - 1] != '\\'
3185 tmpbuf[len++] = '/';
3186 if (len == 2 && tmpbuf[0] == '.')
3189 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3193 len = strlen(tmpbuf);
3194 if (extidx > 0) /* reset after previous loop */
3198 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3199 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3200 if (S_ISDIR(PL_statbuf.st_mode)) {
3204 } while ( retval < 0 /* not there */
3205 && extidx>=0 && ext[extidx] /* try an extension? */
3206 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3211 if (S_ISREG(PL_statbuf.st_mode)
3212 && cando(S_IRUSR,TRUE,&PL_statbuf)
3213 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3214 && cando(S_IXUSR,TRUE,&PL_statbuf)
3218 xfound = tmpbuf; /* bingo! */
3222 xfailed = savepv(tmpbuf);
3225 if (!xfound && !seen_dot && !xfailed &&
3226 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3227 || S_ISDIR(PL_statbuf.st_mode)))
3229 seen_dot = 1; /* Disable message. */
3231 if (flags & 1) { /* do or die? */
3232 Perl_croak(aTHX_ "Can't %s %s%s%s",
3233 (xfailed ? "execute" : "find"),
3234 (xfailed ? xfailed : scriptname),
3235 (xfailed ? "" : " on PATH"),
3236 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3241 scriptname = xfound;
3243 return (scriptname ? savepv(scriptname) : NULL);
3246 #ifndef PERL_GET_CONTEXT_DEFINED
3249 Perl_get_context(void)
3252 #if defined(USE_ITHREADS)
3253 # ifdef OLD_PTHREADS_API
3255 if (pthread_getspecific(PL_thr_key, &t))
3256 Perl_croak_nocontext("panic: pthread_getspecific");
3259 # ifdef I_MACH_CTHREADS
3260 return (void*)cthread_data(cthread_self());
3262 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3271 Perl_set_context(void *t)
3274 #if defined(USE_ITHREADS)
3275 # ifdef I_MACH_CTHREADS
3276 cthread_set_data(cthread_self(), t);
3278 if (pthread_setspecific(PL_thr_key, t))
3279 Perl_croak_nocontext("panic: pthread_setspecific");
3286 #endif /* !PERL_GET_CONTEXT_DEFINED */
3288 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3297 Perl_get_op_names(pTHX)
3299 PERL_UNUSED_CONTEXT;
3300 return (char **)PL_op_name;
3304 Perl_get_op_descs(pTHX)
3306 PERL_UNUSED_CONTEXT;
3307 return (char **)PL_op_desc;
3311 Perl_get_no_modify(pTHX)
3313 PERL_UNUSED_CONTEXT;
3314 return PL_no_modify;
3318 Perl_get_opargs(pTHX)
3320 PERL_UNUSED_CONTEXT;
3321 return (U32 *)PL_opargs;
3325 Perl_get_ppaddr(pTHX)
3328 PERL_UNUSED_CONTEXT;
3329 return (PPADDR_t*)PL_ppaddr;
3332 #ifndef HAS_GETENV_LEN
3334 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3336 char * const env_trans = PerlEnv_getenv(env_elem);
3337 PERL_UNUSED_CONTEXT;
3339 *len = strlen(env_trans);
3346 Perl_get_vtbl(pTHX_ int vtbl_id)
3348 const MGVTBL* result;
3349 PERL_UNUSED_CONTEXT;
3353 result = &PL_vtbl_sv;
3356 result = &PL_vtbl_env;
3358 case want_vtbl_envelem:
3359 result = &PL_vtbl_envelem;
3362 result = &PL_vtbl_sig;
3364 case want_vtbl_sigelem:
3365 result = &PL_vtbl_sigelem;
3367 case want_vtbl_pack:
3368 result = &PL_vtbl_pack;
3370 case want_vtbl_packelem:
3371 result = &PL_vtbl_packelem;
3373 case want_vtbl_dbline:
3374 result = &PL_vtbl_dbline;
3377 result = &PL_vtbl_isa;
3379 case want_vtbl_isaelem:
3380 result = &PL_vtbl_isaelem;
3382 case want_vtbl_arylen:
3383 result = &PL_vtbl_arylen;
3385 case want_vtbl_mglob:
3386 result = &PL_vtbl_mglob;
3388 case want_vtbl_nkeys:
3389 result = &PL_vtbl_nkeys;
3391 case want_vtbl_taint:
3392 result = &PL_vtbl_taint;
3394 case want_vtbl_substr:
3395 result = &PL_vtbl_substr;
3398 result = &PL_vtbl_vec;
3401 result = &PL_vtbl_pos;
3404 result = &PL_vtbl_bm;
3407 result = &PL_vtbl_fm;
3409 case want_vtbl_uvar:
3410 result = &PL_vtbl_uvar;
3412 case want_vtbl_defelem:
3413 result = &PL_vtbl_defelem;
3415 case want_vtbl_regexp:
3416 result = &PL_vtbl_regexp;
3418 case want_vtbl_regdata:
3419 result = &PL_vtbl_regdata;
3421 case want_vtbl_regdatum:
3422 result = &PL_vtbl_regdatum;
3424 #ifdef USE_LOCALE_COLLATE
3425 case want_vtbl_collxfrm:
3426 result = &PL_vtbl_collxfrm;
3429 case want_vtbl_amagic:
3430 result = &PL_vtbl_amagic;
3432 case want_vtbl_amagicelem:
3433 result = &PL_vtbl_amagicelem;
3435 case want_vtbl_backref:
3436 result = &PL_vtbl_backref;
3438 case want_vtbl_utf8:
3439 result = &PL_vtbl_utf8;
3445 return (MGVTBL*)result;
3449 Perl_my_fflush_all(pTHX)
3451 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3452 return PerlIO_flush(NULL);
3454 # if defined(HAS__FWALK)
3455 extern int fflush(FILE *);
3456 /* undocumented, unprototyped, but very useful BSDism */
3457 extern void _fwalk(int (*)(FILE *));
3461 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3463 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3464 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3466 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3467 open_max = sysconf(_SC_OPEN_MAX);
3470 open_max = FOPEN_MAX;
3473 open_max = OPEN_MAX;
3484 for (i = 0; i < open_max; i++)
3485 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3486 STDIO_STREAM_ARRAY[i]._file < open_max &&
3487 STDIO_STREAM_ARRAY[i]._flag)
3488 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3492 SETERRNO(EBADF,RMS_IFI);
3499 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3501 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3503 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3504 if (ckWARN(WARN_IO)) {
3505 const char * const direction =
3506 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3508 Perl_warner(aTHX_ packWARN(WARN_IO),
3509 "Filehandle %s opened only for %sput",
3512 Perl_warner(aTHX_ packWARN(WARN_IO),
3513 "Filehandle opened only for %sput", direction);
3520 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3522 warn_type = WARN_CLOSED;
3526 warn_type = WARN_UNOPENED;
3529 if (ckWARN(warn_type)) {
3530 const char * const pars =
3531 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3532 const char * const func =
3534 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3535 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3536 op < 0 ? "" : /* handle phoney cases */
3538 const char * const type =
3540 (OP_IS_SOCKET(op) ||
3541 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3542 "socket" : "filehandle");
3543 if (name && *name) {
3544 Perl_warner(aTHX_ packWARN(warn_type),
3545 "%s%s on %s %s %s", func, pars, vile, type, name);
3546 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3548 aTHX_ packWARN(warn_type),
3549 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3554 Perl_warner(aTHX_ packWARN(warn_type),
3555 "%s%s on %s %s", func, pars, vile, type);
3556 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3558 aTHX_ packWARN(warn_type),
3559 "\t(Are you trying to call %s%s on dirhandle?)\n",
3568 /* in ASCII order, not that it matters */
3569 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3572 Perl_ebcdic_control(pTHX_ int ch)
3580 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3581 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3584 if (ctlp == controllablechars)
3585 return('\177'); /* DEL */
3587 return((unsigned char)(ctlp - controllablechars - 1));
3588 } else { /* Want uncontrol */
3589 if (ch == '\177' || ch == -1)
3591 else if (ch == '\157')
3593 else if (ch == '\174')
3595 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3597 else if (ch == '\155')
3599 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3600 return(controllablechars[ch+1]);
3602 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3607 /* To workaround core dumps from the uninitialised tm_zone we get the
3608 * system to give us a reasonable struct to copy. This fix means that
3609 * strftime uses the tm_zone and tm_gmtoff values returned by
3610 * localtime(time()). That should give the desired result most of the
3611 * time. But probably not always!
3613 * This does not address tzname aspects of NETaa14816.
3618 # ifndef STRUCT_TM_HASZONE
3619 # define STRUCT_TM_HASZONE
3623 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3624 # ifndef HAS_TM_TM_ZONE
3625 # define HAS_TM_TM_ZONE
3630 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3632 #ifdef HAS_TM_TM_ZONE
3634 const struct tm* my_tm;
3636 my_tm = localtime(&now);
3638 Copy(my_tm, ptm, 1, struct tm);
3640 PERL_UNUSED_ARG(ptm);
3645 * mini_mktime - normalise struct tm values without the localtime()
3646 * semantics (and overhead) of mktime().
3649 Perl_mini_mktime(pTHX_ struct tm *ptm)
3653 int month, mday, year, jday;
3654 int odd_cent, odd_year;
3655 PERL_UNUSED_CONTEXT;
3657 #define DAYS_PER_YEAR 365
3658 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3659 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3660 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3661 #define SECS_PER_HOUR (60*60)
3662 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3663 /* parentheses deliberately absent on these two, otherwise they don't work */
3664 #define MONTH_TO_DAYS 153/5
3665 #define DAYS_TO_MONTH 5/153
3666 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3667 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3668 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3669 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3672 * Year/day algorithm notes:
3674 * With a suitable offset for numeric value of the month, one can find
3675 * an offset into the year by considering months to have 30.6 (153/5) days,
3676 * using integer arithmetic (i.e., with truncation). To avoid too much
3677 * messing about with leap days, we consider January and February to be
3678 * the 13th and 14th month of the previous year. After that transformation,
3679 * we need the month index we use to be high by 1 from 'normal human' usage,
3680 * so the month index values we use run from 4 through 15.
3682 * Given that, and the rules for the Gregorian calendar (leap years are those
3683 * divisible by 4 unless also divisible by 100, when they must be divisible
3684 * by 400 instead), we can simply calculate the number of days since some
3685 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3686 * the days we derive from our month index, and adding in the day of the
3687 * month. The value used here is not adjusted for the actual origin which
3688 * it normally would use (1 January A.D. 1), since we're not exposing it.
3689 * We're only building the value so we can turn around and get the
3690 * normalised values for the year, month, day-of-month, and day-of-year.
3692 * For going backward, we need to bias the value we're using so that we find
3693 * the right year value. (Basically, we don't want the contribution of
3694 * March 1st to the number to apply while deriving the year). Having done
3695 * that, we 'count up' the contribution to the year number by accounting for
3696 * full quadracenturies (400-year periods) with their extra leap days, plus
3697 * the contribution from full centuries (to avoid counting in the lost leap
3698 * days), plus the contribution from full quad-years (to count in the normal
3699 * leap days), plus the leftover contribution from any non-leap years.
3700 * At this point, if we were working with an actual leap day, we'll have 0
3701 * days left over. This is also true for March 1st, however. So, we have
3702 * to special-case that result, and (earlier) keep track of the 'odd'
3703 * century and year contributions. If we got 4 extra centuries in a qcent,
3704 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3705 * Otherwise, we add back in the earlier bias we removed (the 123 from
3706 * figuring in March 1st), find the month index (integer division by 30.6),
3707 * and the remainder is the day-of-month. We then have to convert back to
3708 * 'real' months (including fixing January and February from being 14/15 in
3709 * the previous year to being in the proper year). After that, to get
3710 * tm_yday, we work with the normalised year and get a new yearday value for
3711 * January 1st, which we subtract from the yearday value we had earlier,
3712 * representing the date we've re-built. This is done from January 1
3713 * because tm_yday is 0-origin.
3715 * Since POSIX time routines are only guaranteed to work for times since the
3716 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3717 * applies Gregorian calendar rules even to dates before the 16th century
3718 * doesn't bother me. Besides, you'd need cultural context for a given
3719 * date to know whether it was Julian or Gregorian calendar, and that's
3720 * outside the scope for this routine. Since we convert back based on the
3721 * same rules we used to build the yearday, you'll only get strange results
3722 * for input which needed normalising, or for the 'odd' century years which
3723 * were leap years in the Julian calander but not in the Gregorian one.
3724 * I can live with that.
3726 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3727 * that's still outside the scope for POSIX time manipulation, so I don't
3731 year = 1900 + ptm->tm_year;
3732 month = ptm->tm_mon;
3733 mday = ptm->tm_mday;
3734 /* allow given yday with no month & mday to dominate the result */
3735 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3738 jday = 1 + ptm->tm_yday;
3747 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3748 yearday += month*MONTH_TO_DAYS + mday + jday;
3750 * Note that we don't know when leap-seconds were or will be,
3751 * so we have to trust the user if we get something which looks
3752 * like a sensible leap-second. Wild values for seconds will
3753 * be rationalised, however.
3755 if ((unsigned) ptm->tm_sec <= 60) {
3762 secs += 60 * ptm->tm_min;
3763 secs += SECS_PER_HOUR * ptm->tm_hour;
3765 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3766 /* got negative remainder, but need positive time */
3767 /* back off an extra day to compensate */
3768 yearday += (secs/SECS_PER_DAY)-1;
3769 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3772 yearday += (secs/SECS_PER_DAY);
3773 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3776 else if (secs >= SECS_PER_DAY) {
3777 yearday += (secs/SECS_PER_DAY);
3778 secs %= SECS_PER_DAY;
3780 ptm->tm_hour = secs/SECS_PER_HOUR;
3781 secs %= SECS_PER_HOUR;
3782 ptm->tm_min = secs/60;
3784 ptm->tm_sec += secs;
3785 /* done with time of day effects */
3787 * The algorithm for yearday has (so far) left it high by 428.
3788 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3789 * bias it by 123 while trying to figure out what year it
3790 * really represents. Even with this tweak, the reverse
3791 * translation fails for years before A.D. 0001.
3792 * It would still fail for Feb 29, but we catch that one below.
3794 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3795 yearday -= YEAR_ADJUST;
3796 year = (yearday / DAYS_PER_QCENT) * 400;
3797 yearday %= DAYS_PER_QCENT;
3798 odd_cent = yearday / DAYS_PER_CENT;
3799 year += odd_cent * 100;
3800 yearday %= DAYS_PER_CENT;
3801 year += (yearday / DAYS_PER_QYEAR) * 4;
3802 yearday %= DAYS_PER_QYEAR;
3803 odd_year = yearday / DAYS_PER_YEAR;
3805 yearday %= DAYS_PER_YEAR;
3806 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3811 yearday += YEAR_ADJUST; /* recover March 1st crock */
3812 month = yearday*DAYS_TO_MONTH;
3813 yearday -= month*MONTH_TO_DAYS;
3814 /* recover other leap-year adjustment */
3823 ptm->tm_year = year - 1900;
3825 ptm->tm_mday = yearday;
3826 ptm->tm_mon = month;
3830 ptm->tm_mon = month - 1;
3832 /* re-build yearday based on Jan 1 to get tm_yday */
3834 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3835 yearday += 14*MONTH_TO_DAYS + 1;
3836 ptm->tm_yday = jday - yearday;
3837 /* fix tm_wday if not overridden by caller */
3838 if ((unsigned)ptm->tm_wday > 6)
3839 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3843 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)
3851 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3854 mytm.tm_hour = hour;
3855 mytm.tm_mday = mday;
3857 mytm.tm_year = year;
3858 mytm.tm_wday = wday;
3859 mytm.tm_yday = yday;
3860 mytm.tm_isdst = isdst;
3862 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3863 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3868 #ifdef HAS_TM_TM_GMTOFF
3869 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3871 #ifdef HAS_TM_TM_ZONE
3872 mytm.tm_zone = mytm2.tm_zone;
3877 Newx(buf, buflen, char);
3878 len = strftime(buf, buflen, fmt, &mytm);
3880 ** The following is needed to handle to the situation where
3881 ** tmpbuf overflows. Basically we want to allocate a buffer
3882 ** and try repeatedly. The reason why it is so complicated
3883 ** is that getting a return value of 0 from strftime can indicate
3884 ** one of the following:
3885 ** 1. buffer overflowed,
3886 ** 2. illegal conversion specifier, or
3887 ** 3. the format string specifies nothing to be returned(not
3888 ** an error). This could be because format is an empty string
3889 ** or it specifies %p that yields an empty string in some locale.
3890 ** If there is a better way to make it portable, go ahead by
3893 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3896 /* Possibly buf overflowed - try again with a bigger buf */
3897 const int fmtlen = strlen(fmt);
3898 int bufsize = fmtlen + buflen;
3900 Newx(buf, bufsize, char);
3902 buflen = strftime(buf, bufsize, fmt, &mytm);
3903 if (buflen > 0 && buflen < bufsize)
3905 /* heuristic to prevent out-of-memory errors */
3906 if (bufsize > 100*fmtlen) {
3912 Renew(buf, bufsize, char);
3917 Perl_croak(aTHX_ "panic: no strftime");
3923 #define SV_CWD_RETURN_UNDEF \
3924 sv_setsv(sv, &PL_sv_undef); \
3927 #define SV_CWD_ISDOT(dp) \
3928 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3929 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3932 =head1 Miscellaneous Functions
3934 =for apidoc getcwd_sv
3936 Fill the sv with current working directory
3941 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3942 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3943 * getcwd(3) if available
3944 * Comments from the orignal:
3945 * This is a faster version of getcwd. It's also more dangerous
3946 * because you might chdir out of a directory that you can't chdir
3950 Perl_getcwd_sv(pTHX_ register SV *sv)
3954 #ifndef INCOMPLETE_TAINTS
3960 char buf[MAXPATHLEN];
3962 /* Some getcwd()s automatically allocate a buffer of the given
3963 * size from the heap if they are given a NULL buffer pointer.
3964 * The problem is that this behaviour is not portable. */
3965 if (getcwd(buf, sizeof(buf) - 1)) {
3970 sv_setsv(sv, &PL_sv_undef);
3978 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3982 SvUPGRADE(sv, SVt_PV);
3984 if (PerlLIO_lstat(".", &statbuf) < 0) {
3985 SV_CWD_RETURN_UNDEF;
3988 orig_cdev = statbuf.st_dev;
3989 orig_cino = statbuf.st_ino;
3998 if (PerlDir_chdir("..") < 0) {
3999 SV_CWD_RETURN_UNDEF;
4001 if (PerlLIO_stat(".", &statbuf) < 0) {
4002 SV_CWD_RETURN_UNDEF;
4005 cdev = statbuf.st_dev;
4006 cino = statbuf.st_ino;
4008 if (odev == cdev && oino == cino) {
4011 if (!(dir = PerlDir_open("."))) {
4012 SV_CWD_RETURN_UNDEF;
4015 while ((dp = PerlDir_read(dir)) != NULL) {
4017 const int namelen = dp->d_namlen;
4019 const int namelen = strlen(dp->d_name);
4022 if (SV_CWD_ISDOT(dp)) {
4026 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4027 SV_CWD_RETURN_UNDEF;
4030 tdev = statbuf.st_dev;
4031 tino = statbuf.st_ino;
4032 if (tino == oino && tdev == odev) {
4038 SV_CWD_RETURN_UNDEF;
4041 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4042 SV_CWD_RETURN_UNDEF;
4045 SvGROW(sv, pathlen + namelen + 1);
4049 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4052 /* prepend current directory to the front */
4054 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4055 pathlen += (namelen + 1);
4057 #ifdef VOID_CLOSEDIR
4060 if (PerlDir_close(dir) < 0) {
4061 SV_CWD_RETURN_UNDEF;
4067 SvCUR_set(sv, pathlen);
4071 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4072 SV_CWD_RETURN_UNDEF;
4075 if (PerlLIO_stat(".", &statbuf) < 0) {
4076 SV_CWD_RETURN_UNDEF;
4079 cdev = statbuf.st_dev;
4080 cino = statbuf.st_ino;
4082 if (cdev != orig_cdev || cino != orig_cino) {
4083 Perl_croak(aTHX_ "Unstable directory path, "
4084 "current directory changed unexpectedly");
4096 =for apidoc scan_version
4098 Returns a pointer to the next character after the parsed
4099 version string, as well as upgrading the passed in SV to
4102 Function must be called with an already existing SV like
4105 s = scan_version(s, SV *sv, bool qv);
4107 Performs some preprocessing to the string to ensure that
4108 it has the correct characteristics of a version. Flags the
4109 object if it contains an underscore (which denotes this
4110 is an alpha version). The boolean qv denotes that the version
4111 should be interpreted as if it had multiple decimals, even if
4118 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4126 AV * const av = newAV();
4127 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4128 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4130 #ifndef NODEFAULT_SHAREKEYS
4131 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4134 while (isSPACE(*s)) /* leading whitespace is OK */
4138 s++; /* get past 'v' */
4139 qv = 1; /* force quoted version processing */
4142 start = last = pos = s;
4144 /* pre-scan the input string to check for decimals/underbars */
4145 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4150 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4154 else if ( *pos == '_' )
4157 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4159 width = pos - last - 1; /* natural width of sub-version */
4164 if ( alpha && !saw_period )
4165 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4167 if ( alpha && saw_period && width == 0 )
4168 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4170 if ( saw_period > 1 )
4171 qv = 1; /* force quoted version processing */
4176 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4178 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4179 if ( !qv && width < 3 )
4180 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4182 while (isDIGIT(*pos))
4184 if (!isALPHA(*pos)) {
4190 /* this is atoi() that delimits on underscores */
4191 const char *end = pos;
4195 /* the following if() will only be true after the decimal
4196 * point of a version originally created with a bare
4197 * floating point number, i.e. not quoted in any way
4199 if ( !qv && s > start && saw_period == 1 ) {
4203 rev += (*s - '0') * mult;
4205 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4206 Perl_croak(aTHX_ "Integer overflow in version");
4213 while (--end >= s) {
4215 rev += (*end - '0') * mult;
4217 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4218 Perl_croak(aTHX_ "Integer overflow in version");
4223 /* Append revision */
4224 av_push(av, newSViv(rev));
4227 else if ( *pos == '_' && isDIGIT(pos[1]) )
4229 else if ( isDIGIT(*pos) )
4236 while ( isDIGIT(*pos) )
4241 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4249 if ( qv ) { /* quoted versions always get at least three terms*/
4250 I32 len = av_len(av);
4251 /* This for loop appears to trigger a compiler bug on OS X, as it
4252 loops infinitely. Yes, len is negative. No, it makes no sense.
4253 Compiler in question is:
4254 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4255 for ( len = 2 - len; len > 0; len-- )
4256 av_push((AV *)sv, newSViv(0));
4260 av_push(av, newSViv(0));
4263 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4264 av_push(av, newSViv(0));
4266 /* fix RT#19517 - special case 'undef' as string */
4267 if ( *s == 'u' && strEQ(s,"undef") ) {
4271 /* And finally, store the AV in the hash */
4272 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4277 =for apidoc new_version
4279 Returns a new version object based on the passed in SV:
4281 SV *sv = new_version(SV *ver);
4283 Does not alter the passed in ver SV. See "upg_version" if you
4284 want to upgrade the SV.
4290 Perl_new_version(pTHX_ SV *ver)
4293 SV * const rv = newSV(0);
4294 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4297 AV * const av = newAV();
4299 /* This will get reblessed later if a derived class*/
4300 SV * const hv = newSVrv(rv, "version");
4301 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4302 #ifndef NODEFAULT_SHAREKEYS
4303 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4309 /* Begin copying all of the elements */
4310 if ( hv_exists((HV *)ver, "qv", 2) )
4311 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4313 if ( hv_exists((HV *)ver, "alpha", 5) )
4314 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4316 if ( hv_exists((HV*)ver, "width", 5 ) )
4318 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4319 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4322 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4323 /* This will get reblessed later if a derived class*/
4324 for ( key = 0; key <= av_len(sav); key++ )
4326 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4327 av_push(av, newSViv(rev));
4330 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4335 const MAGIC* const mg = SvVSTRING_mg(ver);
4336 if ( mg ) { /* already a v-string */
4337 const STRLEN len = mg->mg_len;
4338 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4339 sv_setpvn(rv,version,len);
4344 sv_setsv(rv,ver); /* make a duplicate */
4349 return upg_version(rv, FALSE);
4353 =for apidoc upg_version
4355 In-place upgrade of the supplied SV to a version object.
4357 SV *sv = upg_version(SV *sv, bool qv);
4359 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4360 to force this SV to be interpreted as an "extended" version.
4366 Perl_upg_version(pTHX_ SV *ver, bool qv)
4368 const char *version, *s;
4373 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4375 /* may get too much accuracy */
4377 #ifdef USE_LOCALE_NUMERIC
4378 char *loc = setlocale(LC_NUMERIC, "C");
4380 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4381 #ifdef USE_LOCALE_NUMERIC
4382 setlocale(LC_NUMERIC, loc);
4384 while (tbuf[len-1] == '0' && len > 0) len--;
4385 version = savepvn(tbuf, len);
4388 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4389 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4393 else /* must be a string or something like a string */
4396 version = savepv(SvPV(ver,len));
4398 # if PERL_VERSION > 5
4399 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4400 if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4401 /* may be a v-string */
4402 SV * const nsv = sv_newmortal();
4406 sv_setpvf(nsv,"%vd",ver);
4407 pos = nver = savepv(SvPV_nolen(nsv));
4409 /* scan the resulting formatted string */
4410 while ( *pos == '.' || isDIGIT(*pos) ) {
4416 /* is definitely a v-string */
4417 if ( saw_period == 2 ) {
4426 s = scan_version(version, ver, qv);
4428 if(ckWARN(WARN_MISC))
4429 Perl_warner(aTHX_ packWARN(WARN_MISC),
4430 "Version string '%s' contains invalid data; "
4431 "ignoring: '%s'", version, s);
4439 Validates that the SV contains a valid version object.
4441 bool vverify(SV *vobj);
4443 Note that it only confirms the bare minimum structure (so as not to get
4444 confused by derived classes which may contain additional hash entries):
4448 =item * The SV contains a [reference to a] hash
4450 =item * The hash contains a "version" key
4452 =item * The "version" key has [a reference to] an AV as its value
4460 Perl_vverify(pTHX_ SV *vs)
4466 /* see if the appropriate elements exist */
4467 if ( SvTYPE(vs) == SVt_PVHV
4468 && hv_exists((HV*)vs, "version", 7)
4469 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4470 && SvTYPE(sv) == SVt_PVAV )
4479 Accepts a version object and returns the normalized floating
4480 point representation. Call like:
4484 NOTE: you can pass either the object directly or the SV
4485 contained within the RV.
4491 Perl_vnumify(pTHX_ SV *vs)
4496 SV * const sv = newSV(0);
4502 Perl_croak(aTHX_ "Invalid version object");
4504 /* see if various flags exist */
4505 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4507 if ( hv_exists((HV*)vs, "width", 5 ) )
4508 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4513 /* attempt to retrieve the version array */
4514 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4526 digit = SvIV(*av_fetch(av, 0, 0));
4527 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4528 for ( i = 1 ; i < len ; i++ )
4530 digit = SvIV(*av_fetch(av, i, 0));
4532 const int denom = (width == 2 ? 10 : 100);
4533 const div_t term = div((int)PERL_ABS(digit),denom);
4534 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4537 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4543 digit = SvIV(*av_fetch(av, len, 0));
4544 if ( alpha && width == 3 ) /* alpha version */
4546 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4550 sv_catpvs(sv, "000");
4558 Accepts a version object and returns the normalized string
4559 representation. Call like:
4563 NOTE: you can pass either the object directly or the SV
4564 contained within the RV.
4570 Perl_vnormal(pTHX_ SV *vs)
4574 SV * const sv = newSV(0);
4580 Perl_croak(aTHX_ "Invalid version object");
4582 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4584 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4592 digit = SvIV(*av_fetch(av, 0, 0));
4593 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4594 for ( i = 1 ; i < len ; i++ ) {
4595 digit = SvIV(*av_fetch(av, i, 0));
4596 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4601 /* handle last digit specially */
4602 digit = SvIV(*av_fetch(av, len, 0));
4604 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4606 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4609 if ( len <= 2 ) { /* short version, must be at least three */
4610 for ( len = 2 - len; len != 0; len-- )
4617 =for apidoc vstringify
4619 In order to maintain maximum compatibility with earlier versions
4620 of Perl, this function will return either the floating point
4621 notation or the multiple dotted notation, depending on whether
4622 the original version contained 1 or more dots, respectively
4628 Perl_vstringify(pTHX_ SV *vs)
4634 Perl_croak(aTHX_ "Invalid version object");
4636 if ( hv_exists((HV *)vs, "qv", 2) )
4645 Version object aware cmp. Both operands must already have been
4646 converted into version objects.
4652 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4655 bool lalpha = FALSE;
4656 bool ralpha = FALSE;
4665 if ( !vverify(lhv) )
4666 Perl_croak(aTHX_ "Invalid version object");
4668 if ( !vverify(rhv) )
4669 Perl_croak(aTHX_ "Invalid version object");
4671 /* get the left hand term */
4672 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4673 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4676 /* and the right hand term */
4677 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4678 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4686 while ( i <= m && retval == 0 )
4688 left = SvIV(*av_fetch(lav,i,0));
4689 right = SvIV(*av_fetch(rav,i,0));
4697 /* tiebreaker for alpha with identical terms */
4698 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4700 if ( lalpha && !ralpha )
4704 else if ( ralpha && !lalpha)
4710 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4714 while ( i <= r && retval == 0 )
4716 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4717 retval = -1; /* not a match after all */
4723 while ( i <= l && retval == 0 )
4725 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4726 retval = +1; /* not a match after all */
4734 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4735 # define EMULATE_SOCKETPAIR_UDP
4738 #ifdef EMULATE_SOCKETPAIR_UDP
4740 S_socketpair_udp (int fd[2]) {
4742 /* Fake a datagram socketpair using UDP to localhost. */
4743 int sockets[2] = {-1, -1};
4744 struct sockaddr_in addresses[2];
4746 Sock_size_t size = sizeof(struct sockaddr_in);
4747 unsigned short port;
4750 memset(&addresses, 0, sizeof(addresses));
4753 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4754 if (sockets[i] == -1)
4755 goto tidy_up_and_fail;
4757 addresses[i].sin_family = AF_INET;
4758 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4759 addresses[i].sin_port = 0; /* kernel choses port. */
4760 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4761 sizeof(struct sockaddr_in)) == -1)
4762 goto tidy_up_and_fail;
4765 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4766 for each connect the other socket to it. */
4769 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4771 goto tidy_up_and_fail;
4772 if (size != sizeof(struct sockaddr_in))
4773 goto abort_tidy_up_and_fail;
4774 /* !1 is 0, !0 is 1 */
4775 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4776 sizeof(struct sockaddr_in)) == -1)
4777 goto tidy_up_and_fail;
4780 /* Now we have 2 sockets connected to each other. I don't trust some other
4781 process not to have already sent a packet to us (by random) so send
4782 a packet from each to the other. */
4785 /* I'm going to send my own port number. As a short.
4786 (Who knows if someone somewhere has sin_port as a bitfield and needs
4787 this routine. (I'm assuming crays have socketpair)) */
4788 port = addresses[i].sin_port;
4789 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4790 if (got != sizeof(port)) {
4792 goto tidy_up_and_fail;
4793 goto abort_tidy_up_and_fail;
4797 /* Packets sent. I don't trust them to have arrived though.
4798 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4799 connect to localhost will use a second kernel thread. In 2.6 the
4800 first thread running the connect() returns before the second completes,
4801 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4802 returns 0. Poor programs have tripped up. One poor program's authors'
4803 had a 50-1 reverse stock split. Not sure how connected these were.)
4804 So I don't trust someone not to have an unpredictable UDP stack.
4808 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4809 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4813 FD_SET((unsigned int)sockets[0], &rset);
4814 FD_SET((unsigned int)sockets[1], &rset);
4816 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4817 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4818 || !FD_ISSET(sockets[1], &rset)) {
4819 /* I hope this is portable and appropriate. */
4821 goto tidy_up_and_fail;
4822 goto abort_tidy_up_and_fail;
4826 /* And the paranoia department even now doesn't trust it to have arrive
4827 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4829 struct sockaddr_in readfrom;
4830 unsigned short buffer[2];
4835 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4836 sizeof(buffer), MSG_DONTWAIT,
4837 (struct sockaddr *) &readfrom, &size);
4839 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4841 (struct sockaddr *) &readfrom, &size);
4845 goto tidy_up_and_fail;
4846 if (got != sizeof(port)
4847 || size != sizeof(struct sockaddr_in)
4848 /* Check other socket sent us its port. */
4849 || buffer[0] != (unsigned short) addresses[!i].sin_port
4850 /* Check kernel says we got the datagram from that socket */
4851 || readfrom.sin_family != addresses[!i].sin_family
4852 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4853 || readfrom.sin_port != addresses[!i].sin_port)
4854 goto abort_tidy_up_and_fail;
4857 /* My caller (my_socketpair) has validated that this is non-NULL */
4860 /* I hereby declare this connection open. May God bless all who cross
4864 abort_tidy_up_and_fail:
4865 errno = ECONNABORTED;
4868 const int save_errno = errno;
4869 if (sockets[0] != -1)
4870 PerlLIO_close(sockets[0]);
4871 if (sockets[1] != -1)
4872 PerlLIO_close(sockets[1]);
4877 #endif /* EMULATE_SOCKETPAIR_UDP */
4879 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4881 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4882 /* Stevens says that family must be AF_LOCAL, protocol 0.
4883 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4888 struct sockaddr_in listen_addr;
4889 struct sockaddr_in connect_addr;
4894 || family != AF_UNIX
4897 errno = EAFNOSUPPORT;
4905 #ifdef EMULATE_SOCKETPAIR_UDP
4906 if (type == SOCK_DGRAM)
4907 return S_socketpair_udp(fd);
4910 listener = PerlSock_socket(AF_INET, type, 0);
4913 memset(&listen_addr, 0, sizeof(listen_addr));
4914 listen_addr.sin_family = AF_INET;
4915 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4916 listen_addr.sin_port = 0; /* kernel choses port. */
4917 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4918 sizeof(listen_addr)) == -1)
4919 goto tidy_up_and_fail;
4920 if (PerlSock_listen(listener, 1) == -1)
4921 goto tidy_up_and_fail;
4923 connector = PerlSock_socket(AF_INET, type, 0);
4924 if (connector == -1)
4925 goto tidy_up_and_fail;
4926 /* We want to find out the port number to connect to. */
4927 size = sizeof(connect_addr);
4928 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4930 goto tidy_up_and_fail;
4931 if (size != sizeof(connect_addr))
4932 goto abort_tidy_up_and_fail;
4933 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4934 sizeof(connect_addr)) == -1)
4935 goto tidy_up_and_fail;
4937 size = sizeof(listen_addr);
4938 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4941 goto tidy_up_and_fail;
4942 if (size != sizeof(listen_addr))
4943 goto abort_tidy_up_and_fail;
4944 PerlLIO_close(listener);
4945 /* Now check we are talking to ourself by matching port and host on the
4947 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4949 goto tidy_up_and_fail;
4950 if (size != sizeof(connect_addr)
4951 || listen_addr.sin_family != connect_addr.sin_family
4952 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4953 || listen_addr.sin_port != connect_addr.sin_port) {
4954 goto abort_tidy_up_and_fail;
4960 abort_tidy_up_and_fail:
4962 errno = ECONNABORTED; /* This would be the standard thing to do. */
4964 # ifdef ECONNREFUSED
4965 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4967 errno = ETIMEDOUT; /* Desperation time. */
4972 const int save_errno = errno;
4974 PerlLIO_close(listener);
4975 if (connector != -1)
4976 PerlLIO_close(connector);
4978 PerlLIO_close(acceptor);
4984 /* In any case have a stub so that there's code corresponding
4985 * to the my_socketpair in global.sym. */
4987 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4988 #ifdef HAS_SOCKETPAIR
4989 return socketpair(family, type, protocol, fd);
4998 =for apidoc sv_nosharing
5000 Dummy routine which "shares" an SV when there is no sharing module present.
5001 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5002 Exists to avoid test for a NULL function pointer and because it could
5003 potentially warn under some level of strict-ness.
5009 Perl_sv_nosharing(pTHX_ SV *sv)
5011 PERL_UNUSED_CONTEXT;
5012 PERL_UNUSED_ARG(sv);
5016 Perl_parse_unicode_opts(pTHX_ const char **popt)
5018 const char *p = *popt;
5023 opt = (U32) atoi(p);
5026 if (*p && *p != '\n' && *p != '\r')
5027 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5032 case PERL_UNICODE_STDIN:
5033 opt |= PERL_UNICODE_STDIN_FLAG; break;
5034 case PERL_UNICODE_STDOUT:
5035 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5036 case PERL_UNICODE_STDERR:
5037 opt |= PERL_UNICODE_STDERR_FLAG; break;
5038 case PERL_UNICODE_STD:
5039 opt |= PERL_UNICODE_STD_FLAG; break;
5040 case PERL_UNICODE_IN:
5041 opt |= PERL_UNICODE_IN_FLAG; break;
5042 case PERL_UNICODE_OUT:
5043 opt |= PERL_UNICODE_OUT_FLAG; break;
5044 case PERL_UNICODE_INOUT:
5045 opt |= PERL_UNICODE_INOUT_FLAG; break;
5046 case PERL_UNICODE_LOCALE:
5047 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5048 case PERL_UNICODE_ARGV:
5049 opt |= PERL_UNICODE_ARGV_FLAG; break;
5050 case PERL_UNICODE_UTF8CACHEASSERT:
5051 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5053 if (*p != '\n' && *p != '\r')
5055 "Unknown Unicode option letter '%c'", *p);
5061 opt = PERL_UNICODE_DEFAULT_FLAGS;
5063 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5064 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5065 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5077 * This is really just a quick hack which grabs various garbage
5078 * values. It really should be a real hash algorithm which
5079 * spreads the effect of every input bit onto every output bit,
5080 * if someone who knows about such things would bother to write it.
5081 * Might be a good idea to add that function to CORE as well.
5082 * No numbers below come from careful analysis or anything here,
5083 * except they are primes and SEED_C1 > 1E6 to get a full-width
5084 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5085 * probably be bigger too.
5088 # define SEED_C1 1000003
5089 #define SEED_C4 73819
5091 # define SEED_C1 25747
5092 #define SEED_C4 20639
5096 #define SEED_C5 26107
5098 #ifndef PERL_NO_DEV_RANDOM
5103 # include <starlet.h>
5104 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5105 * in 100-ns units, typically incremented ever 10 ms. */
5106 unsigned int when[2];
5108 # ifdef HAS_GETTIMEOFDAY
5109 struct timeval when;
5115 /* This test is an escape hatch, this symbol isn't set by Configure. */
5116 #ifndef PERL_NO_DEV_RANDOM
5117 #ifndef PERL_RANDOM_DEVICE
5118 /* /dev/random isn't used by default because reads from it will block
5119 * if there isn't enough entropy available. You can compile with
5120 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5121 * is enough real entropy to fill the seed. */
5122 # define PERL_RANDOM_DEVICE "/dev/urandom"
5124 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5126 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5135 _ckvmssts(sys$gettim(when));
5136 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5138 # ifdef HAS_GETTIMEOFDAY
5139 PerlProc_gettimeofday(&when,NULL);
5140 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5143 u = (U32)SEED_C1 * when;
5146 u += SEED_C3 * (U32)PerlProc_getpid();
5147 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5148 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5149 u += SEED_C5 * (U32)PTR2UV(&when);
5155 Perl_get_hash_seed(pTHX)
5158 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5164 if (s && isDIGIT(*s))
5165 myseed = (UV)Atoul(s);
5167 #ifdef USE_HASH_SEED_EXPLICIT
5171 /* Compute a random seed */
5172 (void)seedDrand01((Rand_seed_t)seed());
5173 myseed = (UV)(Drand01() * (NV)UV_MAX);
5174 #if RANDBITS < (UVSIZE * 8)
5175 /* Since there are not enough randbits to to reach all
5176 * the bits of a UV, the low bits might need extra
5177 * help. Sum in another random number that will
5178 * fill in the low bits. */
5180 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5181 #endif /* RANDBITS < (UVSIZE * 8) */
5182 if (myseed == 0) { /* Superparanoia. */
5183 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5185 Perl_croak(aTHX_ "Your random numbers are not that random");
5188 PL_rehash_seed_set = TRUE;
5195 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5197 const char * const stashpv = CopSTASHPV(c);
5198 const char * const name = HvNAME_get(hv);
5199 PERL_UNUSED_CONTEXT;
5201 if (stashpv == name)
5203 if (stashpv && name)
5204 if (strEQ(stashpv, name))
5211 #ifdef PERL_GLOBAL_STRUCT
5213 #define PERL_GLOBAL_STRUCT_INIT
5214 #include "opcode.h" /* the ppaddr and check */
5217 Perl_init_global_struct(pTHX)
5219 struct perl_vars *plvarsp = NULL;
5220 # ifdef PERL_GLOBAL_STRUCT
5221 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5222 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5223 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5224 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5225 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5229 plvarsp = PL_VarsPtr;
5230 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5236 # define PERLVAR(var,type) /**/
5237 # define PERLVARA(var,n,type) /**/
5238 # define PERLVARI(var,type,init) plvarsp->var = init;
5239 # define PERLVARIC(var,type,init) plvarsp->var = init;
5240 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5241 # include "perlvars.h"
5247 # ifdef PERL_GLOBAL_STRUCT
5250 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5251 if (!plvarsp->Gppaddr)
5255 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5256 if (!plvarsp->Gcheck)
5258 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5259 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5261 # ifdef PERL_SET_VARS
5262 PERL_SET_VARS(plvarsp);
5264 # undef PERL_GLOBAL_STRUCT_INIT
5269 #endif /* PERL_GLOBAL_STRUCT */
5271 #ifdef PERL_GLOBAL_STRUCT
5274 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5276 # ifdef PERL_GLOBAL_STRUCT
5277 # ifdef PERL_UNSET_VARS
5278 PERL_UNSET_VARS(plvarsp);
5280 free(plvarsp->Gppaddr);
5281 free(plvarsp->Gcheck);
5282 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5288 #endif /* PERL_GLOBAL_STRUCT */
5293 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5295 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5296 * variable PERL_MEM_LOG will be consulted, and if the integer value
5297 * of that is true, the logging will happen. (The default is to
5298 * always log if the PERL_MEM_LOG define was in effect.)
5302 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5303 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5305 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5308 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5309 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5310 * in which case the environment variable PERL_MEM_LOG_FD will be
5311 * consulted for the file descriptor number to use.
5313 #ifndef PERL_MEM_LOG_FD
5314 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5318 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)
5320 #ifdef PERL_MEM_LOG_STDERR
5321 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5324 # ifdef PERL_MEM_LOG_ENV
5325 s = getenv("PERL_MEM_LOG");
5326 if (s ? atoi(s) : 0)
5329 /* We can't use SVs or PerlIO for obvious reasons,
5330 * so we'll use stdio and low-level IO instead. */
5331 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5332 # ifdef PERL_MEM_LOG_TIMESTAMP
5334 # ifdef HAS_GETTIMEOFDAY
5335 gettimeofday(&tv, 0);
5337 /* If there are other OS specific ways of hires time than
5338 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5339 * probably that they would be used to fill in the struct
5346 # ifdef PERL_MEM_LOG_TIMESTAMP
5349 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5350 " %s = %"IVdf": %"UVxf"\n",
5351 # ifdef PERL_MEM_LOG_TIMESTAMP
5352 (int)tv.tv_sec, (int)tv.tv_usec,
5354 filename, linenumber, funcname, n, typesize,
5355 typename, n * typesize, PTR2UV(newalloc));
5356 # ifdef PERL_MEM_LOG_ENV_FD
5357 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5358 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5360 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5369 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)
5371 #ifdef PERL_MEM_LOG_STDERR
5372 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5375 # ifdef PERL_MEM_LOG_ENV
5376 s = PerlEnv_getenv("PERL_MEM_LOG");
5377 if (s ? atoi(s) : 0)
5380 /* We can't use SVs or PerlIO for obvious reasons,
5381 * so we'll use stdio and low-level IO instead. */
5382 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5383 # ifdef PERL_MEM_LOG_TIMESTAMP
5385 gettimeofday(&tv, 0);
5391 # ifdef PERL_MEM_LOG_TIMESTAMP
5394 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5395 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5396 # ifdef PERL_MEM_LOG_TIMESTAMP
5397 (int)tv.tv_sec, (int)tv.tv_usec,
5399 filename, linenumber, funcname, n, typesize,
5400 typename, n * typesize, PTR2UV(oldalloc),
5402 # ifdef PERL_MEM_LOG_ENV_FD
5403 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5404 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5406 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5415 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5417 #ifdef PERL_MEM_LOG_STDERR
5418 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5421 # ifdef PERL_MEM_LOG_ENV
5422 s = PerlEnv_getenv("PERL_MEM_LOG");
5423 if (s ? atoi(s) : 0)
5426 /* We can't use SVs or PerlIO for obvious reasons,
5427 * so we'll use stdio and low-level IO instead. */
5428 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5429 # ifdef PERL_MEM_LOG_TIMESTAMP
5431 gettimeofday(&tv, 0);
5437 # ifdef PERL_MEM_LOG_TIMESTAMP
5440 "free: %s:%d:%s: %"UVxf"\n",
5441 # ifdef PERL_MEM_LOG_TIMESTAMP
5442 (int)tv.tv_sec, (int)tv.tv_usec,
5444 filename, linenumber, funcname,
5446 # ifdef PERL_MEM_LOG_ENV_FD
5447 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5448 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5450 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5458 #endif /* PERL_MEM_LOG */
5461 =for apidoc my_sprintf
5463 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5464 the length of the string written to the buffer. Only rare pre-ANSI systems
5465 need the wrapper function - usually this is a direct call to C<sprintf>.
5469 #ifndef SPRINTF_RETURNS_STRLEN
5471 Perl_my_sprintf(char *buffer, const char* pat, ...)
5474 va_start(args, pat);
5475 vsprintf(buffer, pat, args);
5477 return strlen(buffer);
5482 =for apidoc my_snprintf
5484 The C library C<snprintf> functionality, if available and
5485 standards-compliant (uses C<vsnprintf>, actually). However, if the
5486 C<vsnprintf> is not available, will unfortunately use the unsafe
5487 C<vsprintf> which can overrun the buffer (there is an overrun check,
5488 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5489 getting C<vsnprintf>.
5494 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5499 va_start(ap, format);
5500 #ifdef HAS_VSNPRINTF
5501 retval = vsnprintf(buffer, len, format, ap);
5503 retval = vsprintf(buffer, format, ap);
5506 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5507 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5508 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5513 =for apidoc my_vsnprintf
5515 The C library C<vsnprintf> if available and standards-compliant.
5516 However, if if the C<vsnprintf> is not available, will unfortunately
5517 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5518 overrun check, but that may be too late). Consider using
5519 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5524 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5530 Perl_va_copy(ap, apc);
5531 # ifdef HAS_VSNPRINTF
5532 retval = vsnprintf(buffer, len, format, apc);
5534 retval = vsprintf(buffer, format, apc);
5537 # ifdef HAS_VSNPRINTF
5538 retval = vsnprintf(buffer, len, format, ap);
5540 retval = vsprintf(buffer, format, ap);
5542 #endif /* #ifdef NEED_VA_COPY */
5543 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5544 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5545 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5550 Perl_my_clearenv(pTHX)
5553 #if ! defined(PERL_MICRO)
5554 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5556 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5557 # if defined(USE_ENVIRON_ARRAY)
5558 # if defined(USE_ITHREADS)
5559 /* only the parent thread can clobber the process environment */
5560 if (PL_curinterp == aTHX)
5561 # endif /* USE_ITHREADS */
5563 # if ! defined(PERL_USE_SAFE_PUTENV)
5564 if ( !PL_use_safe_putenv) {
5566 if (environ == PL_origenviron)
5567 environ = (char**)safesysmalloc(sizeof(char*));
5569 for (i = 0; environ[i]; i++)
5570 (void)safesysfree(environ[i]);
5573 # else /* PERL_USE_SAFE_PUTENV */
5574 # if defined(HAS_CLEARENV)
5576 # elif defined(HAS_UNSETENV)
5577 int bsiz = 80; /* Most envvar names will be shorter than this. */
5578 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5579 char *buf = (char*)safesysmalloc(bufsiz);
5580 while (*environ != NULL) {
5581 char *e = strchr(*environ, '=');
5582 int l = e ? e - *environ : (int)strlen(*environ);
5584 (void)safesysfree(buf);
5585 bsiz = l + 1; /* + 1 for the \0. */
5586 buf = (char*)safesysmalloc(bufsiz);
5588 my_strlcpy(buf, *environ, l + 1);
5589 (void)unsetenv(buf);
5591 (void)safesysfree(buf);
5592 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5593 /* Just null environ and accept the leakage. */
5595 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5596 # endif /* ! PERL_USE_SAFE_PUTENV */
5598 # endif /* USE_ENVIRON_ARRAY */
5599 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5600 #endif /* PERL_MICRO */
5603 #ifdef PERL_IMPLICIT_CONTEXT
5605 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5606 the global PL_my_cxt_index is incremented, and that value is assigned to
5607 that module's static my_cxt_index (who's address is passed as an arg).
5608 Then, for each interpreter this function is called for, it makes sure a
5609 void* slot is available to hang the static data off, by allocating or
5610 extending the interpreter's PL_my_cxt_list array */
5612 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5614 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5619 /* this module hasn't been allocated an index yet */
5620 MUTEX_LOCK(&PL_my_ctx_mutex);
5621 *index = PL_my_cxt_index++;
5622 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5625 /* make sure the array is big enough */
5626 if (PL_my_cxt_size <= *index) {
5627 if (PL_my_cxt_size) {
5628 while (PL_my_cxt_size <= *index)
5629 PL_my_cxt_size *= 2;
5630 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5633 PL_my_cxt_size = 16;
5634 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5637 /* newSV() allocates one more than needed */
5638 p = (void*)SvPVX(newSV(size-1));
5639 PL_my_cxt_list[*index] = p;
5640 Zero(p, size, char);
5644 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5647 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5652 for (index = 0; index < PL_my_cxt_index; index++) {
5653 const char *key = PL_my_cxt_keys[index];
5654 /* try direct pointer compare first - there are chances to success,
5655 * and it's much faster.
5657 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5664 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5670 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5672 /* this module hasn't been allocated an index yet */
5673 MUTEX_LOCK(&PL_my_ctx_mutex);
5674 index = PL_my_cxt_index++;
5675 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5678 /* make sure the array is big enough */
5679 if (PL_my_cxt_size <= index) {
5680 int old_size = PL_my_cxt_size;
5682 if (PL_my_cxt_size) {
5683 while (PL_my_cxt_size <= index)
5684 PL_my_cxt_size *= 2;
5685 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5686 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5689 PL_my_cxt_size = 16;
5690 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5691 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5693 for (i = old_size; i < PL_my_cxt_size; i++) {
5694 PL_my_cxt_keys[i] = 0;
5695 PL_my_cxt_list[i] = 0;
5698 PL_my_cxt_keys[index] = my_cxt_key;
5699 /* newSV() allocates one more than needed */
5700 p = (void*)SvPVX(newSV(size-1));
5701 PL_my_cxt_list[index] = p;
5702 Zero(p, size, char);
5705 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5706 #endif /* PERL_IMPLICIT_CONTEXT */
5710 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5712 Size_t used, length, copy;
5715 length = strlen(src);
5716 if (size > 0 && used < size - 1) {
5717 copy = (length >= size - used) ? size - used - 1 : length;
5718 memcpy(dst + used, src, copy);
5719 dst[used + copy] = '\0';
5721 return used + length;
5727 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5729 Size_t length, copy;
5731 length = strlen(src);
5733 copy = (length >= size) ? size - 1 : length;
5734 memcpy(dst, src, copy);
5741 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5742 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5743 long _ftol( double ); /* Defined by VC6 C libs. */
5744 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5748 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5751 SV * const dbsv = GvSVn(PL_DBsub);
5752 /* We do not care about using sv to call CV;
5753 * it's for informational purposes only.
5757 if (!PERLDB_SUB_NN) {
5758 GV * const gv = CvGV(cv);
5760 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5761 || strEQ(GvNAME(gv), "END")
5762 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5763 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5764 /* Use GV from the stack as a fallback. */
5765 /* GV is potentially non-unique, or contain different CV. */
5766 SV * const tmp = newRV((SV*)cv);
5767 sv_setsv(dbsv, tmp);
5771 gv_efullname3(dbsv, gv, NULL);
5775 const int type = SvTYPE(dbsv);
5776 if (type < SVt_PVIV && type != SVt_IV)
5777 sv_upgrade(dbsv, SVt_PVIV);
5778 (void)SvIOK_on(dbsv);
5779 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5785 * c-indentation-style: bsd
5787 * indent-tabs-mode: t
5790 * ex: set ts=8 sts=4 sw=4 noet: