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 #if defined(DEBUGGING) || defined(HAS_64K_LIMIT) || defined(PERL_TRACK_MEMPOOL)
262 const MEM_SIZE total_size = size * count
263 #ifdef PERL_TRACK_MEMPOOL
270 if (total_size > 0xffff) {
271 PerlIO_printf(Perl_error_log,
272 "Allocation too large: %lx\n", total_size) FLUSH;
275 #endif /* HAS_64K_LIMIT */
277 if ((long)size < 0 || (long)count < 0)
278 Perl_croak_nocontext("panic: calloc");
280 #ifdef PERL_TRACK_MEMPOOL
281 /* Have to use malloc() because we've added some space for our tracking
283 ptr = (Malloc_t)PerlMem_malloc(total_size);
285 /* Use calloc() because it might save a memset() if the memory is fresh
286 and clean from the OS. */
287 ptr = (Malloc_t)PerlMem_calloc(count, size);
289 PERL_ALLOC_CHECK(ptr);
290 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));
292 #ifdef PERL_TRACK_MEMPOOL
294 struct perl_memory_debug_header *const header
295 = (struct perl_memory_debug_header *)ptr;
297 memset((void*)ptr, 0, total_size);
298 header->interpreter = aTHX;
299 /* Link us into the list. */
300 header->prev = &PL_memory_debug_header;
301 header->next = PL_memory_debug_header.next;
302 PL_memory_debug_header.next = header;
303 header->next->prev = header;
305 header->size = total_size;
307 ptr = (Malloc_t)((char*)ptr+sTHX);
314 return write_no_mem();
317 /* These must be defined when not using Perl's malloc for binary
322 Malloc_t Perl_malloc (MEM_SIZE nbytes)
325 return (Malloc_t)PerlMem_malloc(nbytes);
328 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
331 return (Malloc_t)PerlMem_calloc(elements, size);
334 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
337 return (Malloc_t)PerlMem_realloc(where, nbytes);
340 Free_t Perl_mfree (Malloc_t where)
348 /* copy a string up to some (non-backslashed) delimiter, if any */
351 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
356 for (tolen = 0; from < fromend; from++, tolen++) {
358 if (from[1] != delim) {
365 else if (*from == delim)
376 /* return ptr to little string in big string, NULL if not found */
377 /* This routine was donated by Corey Satten. */
380 Perl_instr(pTHX_ register const char *big, register const char *little)
391 register const char *s, *x;
394 for (x=big,s=little; *s; /**/ ) {
405 return (char*)(big-1);
410 /* same as instr but allow embedded nulls */
413 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
419 char first = *little++;
421 bigend -= lend - little;
423 while (big <= bigend) {
424 if (*big++ == first) {
425 for (x=big,s=little; s < lend; x++,s++) {
429 return (char*)(big-1);
436 /* reverse of the above--find last substring */
439 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
441 register const char *bigbeg;
442 register const I32 first = *little;
443 register const char * const littleend = lend;
446 if (little >= littleend)
447 return (char*)bigend;
449 big = bigend - (littleend - little++);
450 while (big >= bigbeg) {
451 register const char *s, *x;
454 for (x=big+2,s=little; s < littleend; /**/ ) {
463 return (char*)(big+1);
468 /* As a space optimization, we do not compile tables for strings of length
469 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
470 special-cased in fbm_instr().
472 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
475 =head1 Miscellaneous Functions
477 =for apidoc fbm_compile
479 Analyses the string in order to make fast searches on it using fbm_instr()
480 -- the Boyer-Moore algorithm.
486 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
489 register const U8 *s;
495 if (flags & FBMcf_TAIL) {
496 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
497 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
498 if (mg && mg->mg_len >= 0)
501 s = (U8*)SvPV_force_mutable(sv, len);
502 if (len == 0) /* TAIL might be on a zero-length string. */
504 SvUPGRADE(sv, SVt_PVGV);
509 const unsigned char *sb;
510 const U8 mlen = (len>255) ? 255 : (U8)len;
513 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
515 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
516 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
517 memset((void*)table, mlen, 256);
519 sb = s - mlen + 1; /* first char (maybe) */
521 if (table[*s] == mlen)
526 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
528 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
530 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
531 for (i = 0; i < len; i++) {
532 if (PL_freq[s[i]] < frequency) {
534 frequency = PL_freq[s[i]];
537 BmFLAGS(sv) = (U8)flags;
538 BmRARE(sv) = s[rarest];
539 BmPREVIOUS(sv) = rarest;
540 BmUSEFUL(sv) = 100; /* Initial value */
541 if (flags & FBMcf_TAIL)
543 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
544 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
547 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
548 /* If SvTAIL is actually due to \Z or \z, this gives false positives
552 =for apidoc fbm_instr
554 Returns the location of the SV in the string delimited by C<str> and
555 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
556 does not have to be fbm_compiled, but the search will not be as fast
563 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
565 register unsigned char *s;
567 register const unsigned char *little
568 = (const unsigned char *)SvPV_const(littlestr,l);
569 register STRLEN littlelen = l;
570 register const I32 multiline = flags & FBMrf_MULTILINE;
572 if ((STRLEN)(bigend - big) < littlelen) {
573 if ( SvTAIL(littlestr)
574 && ((STRLEN)(bigend - big) == littlelen - 1)
576 || (*big == *little &&
577 memEQ((char *)big, (char *)little, littlelen - 1))))
582 if (littlelen <= 2) { /* Special-cased */
584 if (littlelen == 1) {
585 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
586 /* Know that bigend != big. */
587 if (bigend[-1] == '\n')
588 return (char *)(bigend - 1);
589 return (char *) bigend;
597 if (SvTAIL(littlestr))
598 return (char *) bigend;
602 return (char*)big; /* Cannot be SvTAIL! */
605 if (SvTAIL(littlestr) && !multiline) {
606 if (bigend[-1] == '\n' && bigend[-2] == *little)
607 return (char*)bigend - 2;
608 if (bigend[-1] == *little)
609 return (char*)bigend - 1;
613 /* This should be better than FBM if c1 == c2, and almost
614 as good otherwise: maybe better since we do less indirection.
615 And we save a lot of memory by caching no table. */
616 const unsigned char c1 = little[0];
617 const unsigned char c2 = little[1];
622 while (s <= bigend) {
632 goto check_1char_anchor;
643 goto check_1char_anchor;
646 while (s <= bigend) {
651 goto check_1char_anchor;
660 check_1char_anchor: /* One char and anchor! */
661 if (SvTAIL(littlestr) && (*bigend == *little))
662 return (char *)bigend; /* bigend is already decremented. */
665 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
666 s = bigend - littlelen;
667 if (s >= big && bigend[-1] == '\n' && *s == *little
668 /* Automatically of length > 2 */
669 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
671 return (char*)s; /* how sweet it is */
674 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
676 return (char*)s + 1; /* how sweet it is */
680 if (!SvVALID(littlestr)) {
681 char * const b = ninstr((char*)big,(char*)bigend,
682 (char*)little, (char*)little + littlelen);
684 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
685 /* Chop \n from littlestr: */
686 s = bigend - littlelen + 1;
688 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
698 if (littlelen > (STRLEN)(bigend - big))
702 register const unsigned char * const table
703 = little + littlelen + PERL_FBM_TABLE_OFFSET;
704 register const unsigned char *oldlittle;
706 --littlelen; /* Last char found by table lookup */
709 little += littlelen; /* last char */
715 if ((tmp = table[*s])) {
716 if ((s += tmp) < bigend)
720 else { /* less expensive than calling strncmp() */
721 register unsigned char * const olds = s;
726 if (*--s == *--little)
728 s = olds + 1; /* here we pay the price for failure */
730 if (s < bigend) /* fake up continue to outer loop */
739 && (BmFLAGS(littlestr) & FBMcf_TAIL)
740 && memEQ((char *)(bigend - littlelen),
741 (char *)(oldlittle - littlelen), littlelen) )
742 return (char*)bigend - littlelen;
747 /* start_shift, end_shift are positive quantities which give offsets
748 of ends of some substring of bigstr.
749 If "last" we want the last occurrence.
750 old_posp is the way of communication between consequent calls if
751 the next call needs to find the .
752 The initial *old_posp should be -1.
754 Note that we take into account SvTAIL, so one can get extra
755 optimizations if _ALL flag is set.
758 /* If SvTAIL is actually due to \Z or \z, this gives false positives
759 if PL_multiline. In fact if !PL_multiline the authoritative answer
760 is not supported yet. */
763 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
766 register const unsigned char *big;
768 register I32 previous;
770 register const unsigned char *little;
771 register I32 stop_pos;
772 register const unsigned char *littleend;
775 assert(SvTYPE(littlestr) == SVt_PVGV);
776 assert(SvVALID(littlestr));
779 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
780 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
782 if ( BmRARE(littlestr) == '\n'
783 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
784 little = (const unsigned char *)(SvPVX_const(littlestr));
785 littleend = little + SvCUR(littlestr);
792 little = (const unsigned char *)(SvPVX_const(littlestr));
793 littleend = little + SvCUR(littlestr);
795 /* The value of pos we can start at: */
796 previous = BmPREVIOUS(littlestr);
797 big = (const unsigned char *)(SvPVX_const(bigstr));
798 /* The value of pos we can stop at: */
799 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
800 if (previous + start_shift > stop_pos) {
802 stop_pos does not include SvTAIL in the count, so this check is incorrect
803 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
806 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
811 while (pos < previous + start_shift) {
812 if (!(pos += PL_screamnext[pos]))
817 register const unsigned char *s, *x;
818 if (pos >= stop_pos) break;
819 if (big[pos] != first)
821 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
827 if (s == littleend) {
829 if (!last) return (char *)(big+pos);
832 } while ( pos += PL_screamnext[pos] );
834 return (char *)(big+(*old_posp));
836 if (!SvTAIL(littlestr) || (end_shift > 0))
838 /* Ignore the trailing "\n". This code is not microoptimized */
839 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
840 stop_pos = littleend - little; /* Actual littlestr len */
845 && ((stop_pos == 1) ||
846 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
852 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
854 register const U8 *a = (const U8 *)s1;
855 register const U8 *b = (const U8 *)s2;
859 if (*a != *b && *a != PL_fold[*b])
867 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
870 register const U8 *a = (const U8 *)s1;
871 register const U8 *b = (const U8 *)s2;
875 if (*a != *b && *a != PL_fold_locale[*b])
882 /* copy a string to a safe spot */
885 =head1 Memory Management
889 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
890 string which is a duplicate of C<pv>. The size of the string is
891 determined by C<strlen()>. The memory allocated for the new string can
892 be freed with the C<Safefree()> function.
898 Perl_savepv(pTHX_ const char *pv)
905 const STRLEN pvlen = strlen(pv)+1;
906 Newx(newaddr, pvlen, char);
907 return (char*)memcpy(newaddr, pv, pvlen);
911 /* same thing but with a known length */
916 Perl's version of what C<strndup()> would be if it existed. Returns a
917 pointer to a newly allocated string which is a duplicate of the first
918 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
919 the new string can be freed with the C<Safefree()> function.
925 Perl_savepvn(pTHX_ const char *pv, register I32 len)
927 register char *newaddr;
930 Newx(newaddr,len+1,char);
931 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
933 /* might not be null terminated */
935 return (char *) CopyD(pv,newaddr,len,char);
938 return (char *) ZeroD(newaddr,len+1,char);
943 =for apidoc savesharedpv
945 A version of C<savepv()> which allocates the duplicate string in memory
946 which is shared between threads.
951 Perl_savesharedpv(pTHX_ const char *pv)
953 register char *newaddr;
958 pvlen = strlen(pv)+1;
959 newaddr = (char*)PerlMemShared_malloc(pvlen);
961 return write_no_mem();
963 return (char*)memcpy(newaddr, pv, pvlen);
967 =for apidoc savesharedpvn
969 A version of C<savepvn()> which allocates the duplicate string in memory
970 which is shared between threads. (With the specific difference that a NULL
971 pointer is not acceptable)
976 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
978 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
981 return write_no_mem();
984 return (char*)memcpy(newaddr, pv, len);
990 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
991 the passed in SV using C<SvPV()>
997 Perl_savesvpv(pTHX_ SV *sv)
1000 const char * const pv = SvPV_const(sv, len);
1001 register char *newaddr;
1004 Newx(newaddr,len,char);
1005 return (char *) CopyD(pv,newaddr,len,char);
1009 /* the SV for Perl_form() and mess() is not kept in an arena */
1019 return sv_2mortal(newSVpvs(""));
1024 /* Create as PVMG now, to avoid any upgrading later */
1026 Newxz(any, 1, XPVMG);
1027 SvFLAGS(sv) = SVt_PVMG;
1028 SvANY(sv) = (void*)any;
1030 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1035 #if defined(PERL_IMPLICIT_CONTEXT)
1037 Perl_form_nocontext(const char* pat, ...)
1042 va_start(args, pat);
1043 retval = vform(pat, &args);
1047 #endif /* PERL_IMPLICIT_CONTEXT */
1050 =head1 Miscellaneous Functions
1053 Takes a sprintf-style format pattern and conventional
1054 (non-SV) arguments and returns the formatted string.
1056 (char *) Perl_form(pTHX_ const char* pat, ...)
1058 can be used any place a string (char *) is required:
1060 char * s = Perl_form("%d.%d",major,minor);
1062 Uses a single private buffer so if you want to format several strings you
1063 must explicitly copy the earlier strings away (and free the copies when you
1070 Perl_form(pTHX_ const char* pat, ...)
1074 va_start(args, pat);
1075 retval = vform(pat, &args);
1081 Perl_vform(pTHX_ const char *pat, va_list *args)
1083 SV * const sv = mess_alloc();
1084 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1088 #if defined(PERL_IMPLICIT_CONTEXT)
1090 Perl_mess_nocontext(const char *pat, ...)
1095 va_start(args, pat);
1096 retval = vmess(pat, &args);
1100 #endif /* PERL_IMPLICIT_CONTEXT */
1103 Perl_mess(pTHX_ const char *pat, ...)
1107 va_start(args, pat);
1108 retval = vmess(pat, &args);
1114 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1117 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1119 if (!o || o == PL_op)
1122 if (o->op_flags & OPf_KIDS) {
1124 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1127 /* If the OP_NEXTSTATE has been optimised away we can still use it
1128 * the get the file and line number. */
1130 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1131 cop = (const COP *)kid;
1133 /* Keep searching, and return when we've found something. */
1135 new_cop = closest_cop(cop, kid);
1141 /* Nothing found. */
1147 Perl_vmess(pTHX_ const char *pat, va_list *args)
1150 SV * const sv = mess_alloc();
1152 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1153 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1155 * Try and find the file and line for PL_op. This will usually be
1156 * PL_curcop, but it might be a cop that has been optimised away. We
1157 * can try to find such a cop by searching through the optree starting
1158 * from the sibling of PL_curcop.
1161 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1166 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1167 OutCopFILE(cop), (IV)CopLINE(cop));
1168 /* Seems that GvIO() can be untrustworthy during global destruction. */
1169 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1170 && IoLINES(GvIOp(PL_last_in_gv)))
1172 const bool line_mode = (RsSIMPLE(PL_rs) &&
1173 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1174 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1175 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1176 line_mode ? "line" : "chunk",
1177 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1180 sv_catpvs(sv, " during global destruction");
1181 sv_catpvs(sv, ".\n");
1187 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1193 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1194 && (io = GvIO(PL_stderrgv))
1195 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1202 SAVESPTR(PL_stderrgv);
1205 PUSHSTACKi(PERLSI_MAGIC);
1209 PUSHs(SvTIED_obj((SV*)io, mg));
1210 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1212 call_method("PRINT", G_SCALAR);
1220 /* SFIO can really mess with your errno */
1221 const int e = errno;
1223 PerlIO * const serr = Perl_error_log;
1225 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1226 (void)PerlIO_flush(serr);
1233 /* Common code used by vcroak, vdie, vwarn and vwarner */
1236 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
1242 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1243 /* sv_2cv might call Perl_croak() or Perl_warner() */
1244 SV * const oldhook = *hook;
1251 cv = sv_2cv(oldhook, &stash, &gv, 0);
1253 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1263 if (warn || message) {
1264 msg = newSVpvn(message, msglen);
1265 SvFLAGS(msg) |= utf8;
1273 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1277 call_sv((SV*)cv, G_DISCARD);
1286 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1290 const char *message;
1293 SV * const msv = vmess(pat, args);
1294 if (PL_errors && SvCUR(PL_errors)) {
1295 sv_catsv(PL_errors, msv);
1296 message = SvPV_const(PL_errors, *msglen);
1297 SvCUR_set(PL_errors, 0);
1300 message = SvPV_const(msv,*msglen);
1301 *utf8 = SvUTF8(msv);
1307 DEBUG_S(PerlIO_printf(Perl_debug_log,
1308 "%p: die/croak: message = %s\ndiehook = %p\n",
1309 (void*)thr, message, (void*)PL_diehook));
1311 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1317 Perl_vdie(pTHX_ const char* pat, va_list *args)
1320 const char *message;
1321 const int was_in_eval = PL_in_eval;
1325 DEBUG_S(PerlIO_printf(Perl_debug_log,
1326 "%p: die: curstack = %p, mainstack = %p\n",
1327 (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
1329 message = vdie_croak_common(pat, args, &msglen, &utf8);
1331 PL_restartop = die_where(message, msglen);
1332 SvFLAGS(ERRSV) |= utf8;
1333 DEBUG_S(PerlIO_printf(Perl_debug_log,
1334 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1335 (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env));
1336 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1338 return PL_restartop;
1341 #if defined(PERL_IMPLICIT_CONTEXT)
1343 Perl_die_nocontext(const char* pat, ...)
1348 va_start(args, pat);
1349 o = vdie(pat, &args);
1353 #endif /* PERL_IMPLICIT_CONTEXT */
1356 Perl_die(pTHX_ const char* pat, ...)
1360 va_start(args, pat);
1361 o = vdie(pat, &args);
1367 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1370 const char *message;
1374 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1377 PL_restartop = die_where(message, msglen);
1378 SvFLAGS(ERRSV) |= utf8;
1382 message = SvPVx_const(ERRSV, msglen);
1384 write_to_stderr(message, msglen);
1388 #if defined(PERL_IMPLICIT_CONTEXT)
1390 Perl_croak_nocontext(const char *pat, ...)
1394 va_start(args, pat);
1399 #endif /* PERL_IMPLICIT_CONTEXT */
1402 =head1 Warning and Dieing
1406 This is the XSUB-writer's interface to Perl's C<die> function.
1407 Normally call this function the same way you call the C C<printf>
1408 function. Calling C<croak> returns control directly to Perl,
1409 sidestepping the normal C order of execution. See C<warn>.
1411 If you want to throw an exception object, assign the object to
1412 C<$@> and then pass C<NULL> to croak():
1414 errsv = get_sv("@", TRUE);
1415 sv_setsv(errsv, exception_object);
1422 Perl_croak(pTHX_ const char *pat, ...)
1425 va_start(args, pat);
1432 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1436 SV * const msv = vmess(pat, args);
1437 const I32 utf8 = SvUTF8(msv);
1438 const char * const message = SvPV_const(msv, msglen);
1441 if (vdie_common(message, msglen, utf8, TRUE))
1445 write_to_stderr(message, msglen);
1448 #if defined(PERL_IMPLICIT_CONTEXT)
1450 Perl_warn_nocontext(const char *pat, ...)
1454 va_start(args, pat);
1458 #endif /* PERL_IMPLICIT_CONTEXT */
1463 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1464 function the same way you call the C C<printf> function. See C<croak>.
1470 Perl_warn(pTHX_ const char *pat, ...)
1473 va_start(args, pat);
1478 #if defined(PERL_IMPLICIT_CONTEXT)
1480 Perl_warner_nocontext(U32 err, const char *pat, ...)
1484 va_start(args, pat);
1485 vwarner(err, pat, &args);
1488 #endif /* PERL_IMPLICIT_CONTEXT */
1491 Perl_warner(pTHX_ U32 err, const char* pat,...)
1494 va_start(args, pat);
1495 vwarner(err, pat, &args);
1500 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1503 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1504 SV * const msv = vmess(pat, args);
1506 const char * const message = SvPV_const(msv, msglen);
1507 const I32 utf8 = SvUTF8(msv);
1511 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1514 PL_restartop = die_where(message, msglen);
1515 SvFLAGS(ERRSV) |= utf8;
1518 write_to_stderr(message, msglen);
1522 Perl_vwarn(aTHX_ pat, args);
1526 /* implements the ckWARN? macros */
1529 Perl_ckwarn(pTHX_ U32 w)
1535 && PL_curcop->cop_warnings != pWARN_NONE
1537 PL_curcop->cop_warnings == pWARN_ALL
1538 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1539 || (unpackWARN2(w) &&
1540 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1541 || (unpackWARN3(w) &&
1542 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1543 || (unpackWARN4(w) &&
1544 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1549 isLEXWARN_off && PL_dowarn & G_WARN_ON
1554 /* implements the ckWARN?_d macro */
1557 Perl_ckwarn_d(pTHX_ U32 w)
1562 || PL_curcop->cop_warnings == pWARN_ALL
1564 PL_curcop->cop_warnings != pWARN_NONE
1566 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1567 || (unpackWARN2(w) &&
1568 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1569 || (unpackWARN3(w) &&
1570 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1571 || (unpackWARN4(w) &&
1572 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1578 /* Set buffer=NULL to get a new one. */
1580 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1582 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1583 PERL_UNUSED_CONTEXT;
1586 (specialWARN(buffer) ?
1587 PerlMemShared_malloc(len_wanted) :
1588 PerlMemShared_realloc(buffer, len_wanted));
1590 Copy(bits, (buffer + 1), size, char);
1594 /* since we've already done strlen() for both nam and val
1595 * we can use that info to make things faster than
1596 * sprintf(s, "%s=%s", nam, val)
1598 #define my_setenv_format(s, nam, nlen, val, vlen) \
1599 Copy(nam, s, nlen, char); \
1601 Copy(val, s+(nlen+1), vlen, char); \
1602 *(s+(nlen+1+vlen)) = '\0'
1604 #ifdef USE_ENVIRON_ARRAY
1605 /* VMS' my_setenv() is in vms.c */
1606 #if !defined(WIN32) && !defined(NETWARE)
1608 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1612 /* only parent thread can modify process environment */
1613 if (PL_curinterp == aTHX)
1616 #ifndef PERL_USE_SAFE_PUTENV
1617 if (!PL_use_safe_putenv) {
1618 /* most putenv()s leak, so we manipulate environ directly */
1619 register I32 i=setenv_getix(nam); /* where does it go? */
1622 if (environ == PL_origenviron) { /* need we copy environment? */
1628 while (environ[max])
1630 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1631 for (j=0; j<max; j++) { /* copy environment */
1632 const int len = strlen(environ[j]);
1633 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1634 Copy(environ[j], tmpenv[j], len+1, char);
1637 environ = tmpenv; /* tell exec where it is now */
1640 safesysfree(environ[i]);
1641 while (environ[i]) {
1642 environ[i] = environ[i+1];
1647 if (!environ[i]) { /* does not exist yet */
1648 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1649 environ[i+1] = NULL; /* make sure it's null terminated */
1652 safesysfree(environ[i]);
1656 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1657 /* all that work just for this */
1658 my_setenv_format(environ[i], nam, nlen, val, vlen);
1661 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1662 # if defined(HAS_UNSETENV)
1664 (void)unsetenv(nam);
1666 (void)setenv(nam, val, 1);
1668 # else /* ! HAS_UNSETENV */
1669 (void)setenv(nam, val, 1);
1670 # endif /* HAS_UNSETENV */
1672 # if defined(HAS_UNSETENV)
1674 (void)unsetenv(nam);
1676 const int nlen = strlen(nam);
1677 const int vlen = strlen(val);
1678 char * const new_env =
1679 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1680 my_setenv_format(new_env, nam, nlen, val, vlen);
1681 (void)putenv(new_env);
1683 # else /* ! HAS_UNSETENV */
1685 const int nlen = strlen(nam);
1691 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1692 /* all that work just for this */
1693 my_setenv_format(new_env, nam, nlen, val, vlen);
1694 (void)putenv(new_env);
1695 # endif /* HAS_UNSETENV */
1696 # endif /* __CYGWIN__ */
1697 #ifndef PERL_USE_SAFE_PUTENV
1703 #else /* WIN32 || NETWARE */
1706 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1709 register char *envstr;
1710 const int nlen = strlen(nam);
1717 Newx(envstr, nlen+vlen+2, char);
1718 my_setenv_format(envstr, nam, nlen, val, vlen);
1719 (void)PerlEnv_putenv(envstr);
1723 #endif /* WIN32 || NETWARE */
1727 Perl_setenv_getix(pTHX_ const char *nam)
1730 register const I32 len = strlen(nam);
1731 PERL_UNUSED_CONTEXT;
1733 for (i = 0; environ[i]; i++) {
1736 strnicmp(environ[i],nam,len) == 0
1738 strnEQ(environ[i],nam,len)
1740 && environ[i][len] == '=')
1741 break; /* strnEQ must come first to avoid */
1742 } /* potential SEGV's */
1745 #endif /* !PERL_MICRO */
1747 #endif /* !VMS && !EPOC*/
1749 #ifdef UNLINK_ALL_VERSIONS
1751 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1755 while (PerlLIO_unlink(f) >= 0)
1757 return retries ? 0 : -1;
1761 /* this is a drop-in replacement for bcopy() */
1762 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1764 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1766 char * const retval = to;
1768 if (from - to >= 0) {
1776 *(--to) = *(--from);
1782 /* this is a drop-in replacement for memset() */
1785 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1787 char * const retval = loc;
1795 /* this is a drop-in replacement for bzero() */
1796 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1798 Perl_my_bzero(register char *loc, register I32 len)
1800 char * const retval = loc;
1808 /* this is a drop-in replacement for memcmp() */
1809 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1811 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1813 register const U8 *a = (const U8 *)s1;
1814 register const U8 *b = (const U8 *)s2;
1818 if ((tmp = *a++ - *b++))
1823 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1827 #ifdef USE_CHAR_VSPRINTF
1832 vsprintf(char *dest, const char *pat, char *args)
1836 fakebuf._ptr = dest;
1837 fakebuf._cnt = 32767;
1841 fakebuf._flag = _IOWRT|_IOSTRG;
1842 _doprnt(pat, args, &fakebuf); /* what a kludge */
1843 (void)putc('\0', &fakebuf);
1844 #ifdef USE_CHAR_VSPRINTF
1847 return 0; /* perl doesn't use return value */
1851 #endif /* HAS_VPRINTF */
1854 #if BYTEORDER != 0x4321
1856 Perl_my_swap(pTHX_ short s)
1858 #if (BYTEORDER & 1) == 0
1861 result = ((s & 255) << 8) + ((s >> 8) & 255);
1869 Perl_my_htonl(pTHX_ long l)
1873 char c[sizeof(long)];
1876 #if BYTEORDER == 0x1234
1877 u.c[0] = (l >> 24) & 255;
1878 u.c[1] = (l >> 16) & 255;
1879 u.c[2] = (l >> 8) & 255;
1883 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1884 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1889 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1890 u.c[o & 0xf] = (l >> s) & 255;
1898 Perl_my_ntohl(pTHX_ long l)
1902 char c[sizeof(long)];
1905 #if BYTEORDER == 0x1234
1906 u.c[0] = (l >> 24) & 255;
1907 u.c[1] = (l >> 16) & 255;
1908 u.c[2] = (l >> 8) & 255;
1912 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1913 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1920 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1921 l |= (u.c[o & 0xf] & 255) << s;
1928 #endif /* BYTEORDER != 0x4321 */
1932 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1933 * If these functions are defined,
1934 * the BYTEORDER is neither 0x1234 nor 0x4321.
1935 * However, this is not assumed.
1939 #define HTOLE(name,type) \
1941 name (register type n) \
1945 char c[sizeof(type)]; \
1948 register U32 s = 0; \
1949 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1950 u.c[i] = (n >> s) & 0xFF; \
1955 #define LETOH(name,type) \
1957 name (register type n) \
1961 char c[sizeof(type)]; \
1964 register U32 s = 0; \
1967 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1968 n |= ((type)(u.c[i] & 0xFF)) << s; \
1974 * Big-endian byte order functions.
1977 #define HTOBE(name,type) \
1979 name (register type n) \
1983 char c[sizeof(type)]; \
1986 register U32 s = 8*(sizeof(u.c)-1); \
1987 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1988 u.c[i] = (n >> s) & 0xFF; \
1993 #define BETOH(name,type) \
1995 name (register type n) \
1999 char c[sizeof(type)]; \
2002 register U32 s = 8*(sizeof(u.c)-1); \
2005 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2006 n |= ((type)(u.c[i] & 0xFF)) << s; \
2012 * If we just can't do it...
2015 #define NOT_AVAIL(name,type) \
2017 name (register type n) \
2019 Perl_croak_nocontext(#name "() not available"); \
2020 return n; /* not reached */ \
2024 #if defined(HAS_HTOVS) && !defined(htovs)
2027 #if defined(HAS_HTOVL) && !defined(htovl)
2030 #if defined(HAS_VTOHS) && !defined(vtohs)
2033 #if defined(HAS_VTOHL) && !defined(vtohl)
2037 #ifdef PERL_NEED_MY_HTOLE16
2039 HTOLE(Perl_my_htole16,U16)
2041 NOT_AVAIL(Perl_my_htole16,U16)
2044 #ifdef PERL_NEED_MY_LETOH16
2046 LETOH(Perl_my_letoh16,U16)
2048 NOT_AVAIL(Perl_my_letoh16,U16)
2051 #ifdef PERL_NEED_MY_HTOBE16
2053 HTOBE(Perl_my_htobe16,U16)
2055 NOT_AVAIL(Perl_my_htobe16,U16)
2058 #ifdef PERL_NEED_MY_BETOH16
2060 BETOH(Perl_my_betoh16,U16)
2062 NOT_AVAIL(Perl_my_betoh16,U16)
2066 #ifdef PERL_NEED_MY_HTOLE32
2068 HTOLE(Perl_my_htole32,U32)
2070 NOT_AVAIL(Perl_my_htole32,U32)
2073 #ifdef PERL_NEED_MY_LETOH32
2075 LETOH(Perl_my_letoh32,U32)
2077 NOT_AVAIL(Perl_my_letoh32,U32)
2080 #ifdef PERL_NEED_MY_HTOBE32
2082 HTOBE(Perl_my_htobe32,U32)
2084 NOT_AVAIL(Perl_my_htobe32,U32)
2087 #ifdef PERL_NEED_MY_BETOH32
2089 BETOH(Perl_my_betoh32,U32)
2091 NOT_AVAIL(Perl_my_betoh32,U32)
2095 #ifdef PERL_NEED_MY_HTOLE64
2097 HTOLE(Perl_my_htole64,U64)
2099 NOT_AVAIL(Perl_my_htole64,U64)
2102 #ifdef PERL_NEED_MY_LETOH64
2104 LETOH(Perl_my_letoh64,U64)
2106 NOT_AVAIL(Perl_my_letoh64,U64)
2109 #ifdef PERL_NEED_MY_HTOBE64
2111 HTOBE(Perl_my_htobe64,U64)
2113 NOT_AVAIL(Perl_my_htobe64,U64)
2116 #ifdef PERL_NEED_MY_BETOH64
2118 BETOH(Perl_my_betoh64,U64)
2120 NOT_AVAIL(Perl_my_betoh64,U64)
2124 #ifdef PERL_NEED_MY_HTOLES
2125 HTOLE(Perl_my_htoles,short)
2127 #ifdef PERL_NEED_MY_LETOHS
2128 LETOH(Perl_my_letohs,short)
2130 #ifdef PERL_NEED_MY_HTOBES
2131 HTOBE(Perl_my_htobes,short)
2133 #ifdef PERL_NEED_MY_BETOHS
2134 BETOH(Perl_my_betohs,short)
2137 #ifdef PERL_NEED_MY_HTOLEI
2138 HTOLE(Perl_my_htolei,int)
2140 #ifdef PERL_NEED_MY_LETOHI
2141 LETOH(Perl_my_letohi,int)
2143 #ifdef PERL_NEED_MY_HTOBEI
2144 HTOBE(Perl_my_htobei,int)
2146 #ifdef PERL_NEED_MY_BETOHI
2147 BETOH(Perl_my_betohi,int)
2150 #ifdef PERL_NEED_MY_HTOLEL
2151 HTOLE(Perl_my_htolel,long)
2153 #ifdef PERL_NEED_MY_LETOHL
2154 LETOH(Perl_my_letohl,long)
2156 #ifdef PERL_NEED_MY_HTOBEL
2157 HTOBE(Perl_my_htobel,long)
2159 #ifdef PERL_NEED_MY_BETOHL
2160 BETOH(Perl_my_betohl,long)
2164 Perl_my_swabn(void *ptr, int n)
2166 register char *s = (char *)ptr;
2167 register char *e = s + (n-1);
2170 for (n /= 2; n > 0; s++, e--, n--) {
2178 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2180 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2183 register I32 This, that;
2189 PERL_FLUSHALL_FOR_CHILD;
2190 This = (*mode == 'w');
2194 taint_proper("Insecure %s%s", "EXEC");
2196 if (PerlProc_pipe(p) < 0)
2198 /* Try for another pipe pair for error return */
2199 if (PerlProc_pipe(pp) >= 0)
2201 while ((pid = PerlProc_fork()) < 0) {
2202 if (errno != EAGAIN) {
2203 PerlLIO_close(p[This]);
2204 PerlLIO_close(p[that]);
2206 PerlLIO_close(pp[0]);
2207 PerlLIO_close(pp[1]);
2219 /* Close parent's end of error status pipe (if any) */
2221 PerlLIO_close(pp[0]);
2222 #if defined(HAS_FCNTL) && defined(F_SETFD)
2223 /* Close error pipe automatically if exec works */
2224 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2227 /* Now dup our end of _the_ pipe to right position */
2228 if (p[THIS] != (*mode == 'r')) {
2229 PerlLIO_dup2(p[THIS], *mode == 'r');
2230 PerlLIO_close(p[THIS]);
2231 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2232 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2235 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2236 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2237 /* No automatic close - do it by hand */
2244 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2250 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2256 do_execfree(); /* free any memory malloced by child on fork */
2258 PerlLIO_close(pp[1]);
2259 /* Keep the lower of the two fd numbers */
2260 if (p[that] < p[This]) {
2261 PerlLIO_dup2(p[This], p[that]);
2262 PerlLIO_close(p[This]);
2266 PerlLIO_close(p[that]); /* close child's end of pipe */
2269 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2271 SvUPGRADE(sv,SVt_IV);
2273 PL_forkprocess = pid;
2274 /* If we managed to get status pipe check for exec fail */
2275 if (did_pipes && pid > 0) {
2280 while (n < sizeof(int)) {
2281 n1 = PerlLIO_read(pp[0],
2282 (void*)(((char*)&errkid)+n),
2288 PerlLIO_close(pp[0]);
2290 if (n) { /* Error */
2292 PerlLIO_close(p[This]);
2293 if (n != sizeof(int))
2294 Perl_croak(aTHX_ "panic: kid popen errno read");
2296 pid2 = wait4pid(pid, &status, 0);
2297 } while (pid2 == -1 && errno == EINTR);
2298 errno = errkid; /* Propagate errno from kid */
2303 PerlLIO_close(pp[0]);
2304 return PerlIO_fdopen(p[This], mode);
2306 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2307 return my_syspopen4(aTHX_ Nullch, mode, n, args);
2309 Perl_croak(aTHX_ "List form of piped open not implemented");
2310 return (PerlIO *) NULL;
2315 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2316 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2318 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2322 register I32 This, that;
2325 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2329 PERL_FLUSHALL_FOR_CHILD;
2332 return my_syspopen(aTHX_ cmd,mode);
2335 This = (*mode == 'w');
2337 if (doexec && PL_tainting) {
2339 taint_proper("Insecure %s%s", "EXEC");
2341 if (PerlProc_pipe(p) < 0)
2343 if (doexec && PerlProc_pipe(pp) >= 0)
2345 while ((pid = PerlProc_fork()) < 0) {
2346 if (errno != EAGAIN) {
2347 PerlLIO_close(p[This]);
2348 PerlLIO_close(p[that]);
2350 PerlLIO_close(pp[0]);
2351 PerlLIO_close(pp[1]);
2354 Perl_croak(aTHX_ "Can't fork");
2367 PerlLIO_close(pp[0]);
2368 #if defined(HAS_FCNTL) && defined(F_SETFD)
2369 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2372 if (p[THIS] != (*mode == 'r')) {
2373 PerlLIO_dup2(p[THIS], *mode == 'r');
2374 PerlLIO_close(p[THIS]);
2375 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2376 PerlLIO_close(p[THAT]);
2379 PerlLIO_close(p[THAT]);
2382 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2389 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2394 /* may or may not use the shell */
2395 do_exec3(cmd, pp[1], did_pipes);
2398 #endif /* defined OS2 */
2400 #ifdef PERLIO_USING_CRLF
2401 /* Since we circumvent IO layers when we manipulate low-level
2402 filedescriptors directly, need to manually switch to the
2403 default, binary, low-level mode; see PerlIOBuf_open(). */
2404 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2407 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2408 SvREADONLY_off(GvSV(tmpgv));
2409 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2410 SvREADONLY_on(GvSV(tmpgv));
2412 #ifdef THREADS_HAVE_PIDS
2413 PL_ppid = (IV)getppid();
2416 #ifdef PERL_USES_PL_PIDSTATUS
2417 hv_clear(PL_pidstatus); /* we have no children */
2423 do_execfree(); /* free any memory malloced by child on vfork */
2425 PerlLIO_close(pp[1]);
2426 if (p[that] < p[This]) {
2427 PerlLIO_dup2(p[This], p[that]);
2428 PerlLIO_close(p[This]);
2432 PerlLIO_close(p[that]);
2435 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2437 SvUPGRADE(sv,SVt_IV);
2439 PL_forkprocess = pid;
2440 if (did_pipes && pid > 0) {
2445 while (n < sizeof(int)) {
2446 n1 = PerlLIO_read(pp[0],
2447 (void*)(((char*)&errkid)+n),
2453 PerlLIO_close(pp[0]);
2455 if (n) { /* Error */
2457 PerlLIO_close(p[This]);
2458 if (n != sizeof(int))
2459 Perl_croak(aTHX_ "panic: kid popen errno read");
2461 pid2 = wait4pid(pid, &status, 0);
2462 } while (pid2 == -1 && errno == EINTR);
2463 errno = errkid; /* Propagate errno from kid */
2468 PerlLIO_close(pp[0]);
2469 return PerlIO_fdopen(p[This], mode);
2472 #if defined(atarist) || defined(EPOC)
2475 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2477 PERL_FLUSHALL_FOR_CHILD;
2478 /* Call system's popen() to get a FILE *, then import it.
2479 used 0 for 2nd parameter to PerlIO_importFILE;
2482 return PerlIO_importFILE(popen(cmd, mode), 0);
2486 FILE *djgpp_popen();
2488 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2490 PERL_FLUSHALL_FOR_CHILD;
2491 /* Call system's popen() to get a FILE *, then import it.
2492 used 0 for 2nd parameter to PerlIO_importFILE;
2495 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2500 #endif /* !DOSISH */
2502 /* this is called in parent before the fork() */
2504 Perl_atfork_lock(void)
2507 #if defined(USE_ITHREADS)
2508 /* locks must be held in locking order (if any) */
2510 MUTEX_LOCK(&PL_malloc_mutex);
2516 /* this is called in both parent and child after the fork() */
2518 Perl_atfork_unlock(void)
2521 #if defined(USE_ITHREADS)
2522 /* locks must be released in same order as in atfork_lock() */
2524 MUTEX_UNLOCK(&PL_malloc_mutex);
2533 #if defined(HAS_FORK)
2535 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2540 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2541 * handlers elsewhere in the code */
2546 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2547 Perl_croak_nocontext("fork() not available");
2549 #endif /* HAS_FORK */
2554 Perl_dump_fds(pTHX_ char *s)
2559 PerlIO_printf(Perl_debug_log,"%s", s);
2560 for (fd = 0; fd < 32; fd++) {
2561 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2562 PerlIO_printf(Perl_debug_log," %d",fd);
2564 PerlIO_printf(Perl_debug_log,"\n");
2567 #endif /* DUMP_FDS */
2571 dup2(int oldfd, int newfd)
2573 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2576 PerlLIO_close(newfd);
2577 return fcntl(oldfd, F_DUPFD, newfd);
2579 #define DUP2_MAX_FDS 256
2580 int fdtmp[DUP2_MAX_FDS];
2586 PerlLIO_close(newfd);
2587 /* good enough for low fd's... */
2588 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2589 if (fdx >= DUP2_MAX_FDS) {
2597 PerlLIO_close(fdtmp[--fdx]);
2604 #ifdef HAS_SIGACTION
2606 #ifdef MACOS_TRADITIONAL
2607 /* We don't want restart behavior on MacOS */
2612 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2615 struct sigaction act, oact;
2618 /* only "parent" interpreter can diddle signals */
2619 if (PL_curinterp != aTHX)
2620 return (Sighandler_t) SIG_ERR;
2623 act.sa_handler = (void(*)(int))handler;
2624 sigemptyset(&act.sa_mask);
2627 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2628 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2630 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2631 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2632 act.sa_flags |= SA_NOCLDWAIT;
2634 if (sigaction(signo, &act, &oact) == -1)
2635 return (Sighandler_t) SIG_ERR;
2637 return (Sighandler_t) oact.sa_handler;
2641 Perl_rsignal_state(pTHX_ int signo)
2643 struct sigaction oact;
2644 PERL_UNUSED_CONTEXT;
2646 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2647 return (Sighandler_t) SIG_ERR;
2649 return (Sighandler_t) oact.sa_handler;
2653 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2656 struct sigaction act;
2659 /* only "parent" interpreter can diddle signals */
2660 if (PL_curinterp != aTHX)
2664 act.sa_handler = (void(*)(int))handler;
2665 sigemptyset(&act.sa_mask);
2668 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2669 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2671 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2672 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2673 act.sa_flags |= SA_NOCLDWAIT;
2675 return sigaction(signo, &act, save);
2679 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2683 /* only "parent" interpreter can diddle signals */
2684 if (PL_curinterp != aTHX)
2688 return sigaction(signo, save, (struct sigaction *)NULL);
2691 #else /* !HAS_SIGACTION */
2694 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2696 #if defined(USE_ITHREADS) && !defined(WIN32)
2697 /* only "parent" interpreter can diddle signals */
2698 if (PL_curinterp != aTHX)
2699 return (Sighandler_t) SIG_ERR;
2702 return PerlProc_signal(signo, handler);
2713 Perl_rsignal_state(pTHX_ int signo)
2716 Sighandler_t oldsig;
2718 #if defined(USE_ITHREADS) && !defined(WIN32)
2719 /* only "parent" interpreter can diddle signals */
2720 if (PL_curinterp != aTHX)
2721 return (Sighandler_t) SIG_ERR;
2725 oldsig = PerlProc_signal(signo, sig_trap);
2726 PerlProc_signal(signo, oldsig);
2728 PerlProc_kill(PerlProc_getpid(), signo);
2733 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2735 #if defined(USE_ITHREADS) && !defined(WIN32)
2736 /* only "parent" interpreter can diddle signals */
2737 if (PL_curinterp != aTHX)
2740 *save = PerlProc_signal(signo, handler);
2741 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2745 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2747 #if defined(USE_ITHREADS) && !defined(WIN32)
2748 /* only "parent" interpreter can diddle signals */
2749 if (PL_curinterp != aTHX)
2752 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2755 #endif /* !HAS_SIGACTION */
2756 #endif /* !PERL_MICRO */
2758 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2759 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2761 Perl_my_pclose(pTHX_ PerlIO *ptr)
2764 Sigsave_t hstat, istat, qstat;
2770 int saved_errno = 0;
2772 int saved_win32_errno;
2776 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2778 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2780 *svp = &PL_sv_undef;
2782 if (pid == -1) { /* Opened by popen. */
2783 return my_syspclose(ptr);
2786 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2787 saved_errno = errno;
2789 saved_win32_errno = GetLastError();
2793 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2796 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2797 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2798 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2801 pid2 = wait4pid(pid, &status, 0);
2802 } while (pid2 == -1 && errno == EINTR);
2804 rsignal_restore(SIGHUP, &hstat);
2805 rsignal_restore(SIGINT, &istat);
2806 rsignal_restore(SIGQUIT, &qstat);
2809 SETERRNO(saved_errno, 0);
2812 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2814 #endif /* !DOSISH */
2816 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2818 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2824 #ifdef PERL_USES_PL_PIDSTATUS
2827 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2828 pid, rather than a string form. */
2829 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2830 if (svp && *svp != &PL_sv_undef) {
2831 *statusp = SvIVX(*svp);
2832 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2840 hv_iterinit(PL_pidstatus);
2841 if ((entry = hv_iternext(PL_pidstatus))) {
2842 SV * const sv = hv_iterval(PL_pidstatus,entry);
2844 const char * const spid = hv_iterkey(entry,&len);
2846 assert (len == sizeof(Pid_t));
2847 memcpy((char *)&pid, spid, len);
2848 *statusp = SvIVX(sv);
2849 /* The hash iterator is currently on this entry, so simply
2850 calling hv_delete would trigger the lazy delete, which on
2851 aggregate does more work, beacuse next call to hv_iterinit()
2852 would spot the flag, and have to call the delete routine,
2853 while in the meantime any new entries can't re-use that
2855 hv_iterinit(PL_pidstatus);
2856 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2863 # ifdef HAS_WAITPID_RUNTIME
2864 if (!HAS_WAITPID_RUNTIME)
2867 result = PerlProc_waitpid(pid,statusp,flags);
2870 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2871 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2874 #ifdef PERL_USES_PL_PIDSTATUS
2875 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2880 Perl_croak(aTHX_ "Can't do waitpid with flags");
2882 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2883 pidgone(result,*statusp);
2889 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2892 if (result < 0 && errno == EINTR) {
2897 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2899 #ifdef PERL_USES_PL_PIDSTATUS
2901 Perl_pidgone(pTHX_ Pid_t pid, int status)
2905 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2906 SvUPGRADE(sv,SVt_IV);
2907 SvIV_set(sv, status);
2912 #if defined(atarist) || defined(OS2) || defined(EPOC)
2915 int /* Cannot prototype with I32
2917 my_syspclose(PerlIO *ptr)
2920 Perl_my_pclose(pTHX_ PerlIO *ptr)
2923 /* Needs work for PerlIO ! */
2924 FILE * const f = PerlIO_findFILE(ptr);
2925 const I32 result = pclose(f);
2926 PerlIO_releaseFILE(ptr,f);
2934 Perl_my_pclose(pTHX_ PerlIO *ptr)
2936 /* Needs work for PerlIO ! */
2937 FILE * const f = PerlIO_findFILE(ptr);
2938 I32 result = djgpp_pclose(f);
2939 result = (result << 8) & 0xff00;
2940 PerlIO_releaseFILE(ptr,f);
2946 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2949 register const char * const frombase = from;
2950 PERL_UNUSED_CONTEXT;
2953 register const char c = *from;
2958 while (count-- > 0) {
2959 for (todo = len; todo > 0; todo--) {
2968 Perl_same_dirent(pTHX_ const char *a, const char *b)
2970 char *fa = strrchr(a,'/');
2971 char *fb = strrchr(b,'/');
2974 SV * const tmpsv = sv_newmortal();
2987 sv_setpvn(tmpsv, ".", 1);
2989 sv_setpvn(tmpsv, a, fa - a);
2990 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2993 sv_setpvn(tmpsv, ".", 1);
2995 sv_setpvn(tmpsv, b, fb - b);
2996 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2998 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2999 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3001 #endif /* !HAS_RENAME */
3004 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3005 const char *const *const search_ext, I32 flags)
3008 const char *xfound = NULL;
3009 char *xfailed = NULL;
3010 char tmpbuf[MAXPATHLEN];
3014 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3015 # define SEARCH_EXTS ".bat", ".cmd", NULL
3016 # define MAX_EXT_LEN 4
3019 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3020 # define MAX_EXT_LEN 4
3023 # define SEARCH_EXTS ".pl", ".com", NULL
3024 # define MAX_EXT_LEN 4
3026 /* additional extensions to try in each dir if scriptname not found */
3028 static const char *const exts[] = { SEARCH_EXTS };
3029 const char *const *const ext = search_ext ? search_ext : exts;
3030 int extidx = 0, i = 0;
3031 const char *curext = NULL;
3033 PERL_UNUSED_ARG(search_ext);
3034 # define MAX_EXT_LEN 0
3038 * If dosearch is true and if scriptname does not contain path
3039 * delimiters, search the PATH for scriptname.
3041 * If SEARCH_EXTS is also defined, will look for each
3042 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3043 * while searching the PATH.
3045 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3046 * proceeds as follows:
3047 * If DOSISH or VMSISH:
3048 * + look for ./scriptname{,.foo,.bar}
3049 * + search the PATH for scriptname{,.foo,.bar}
3052 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3053 * this will not look in '.' if it's not in the PATH)
3058 # ifdef ALWAYS_DEFTYPES
3059 len = strlen(scriptname);
3060 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3061 int idx = 0, deftypes = 1;
3064 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3067 int idx = 0, deftypes = 1;
3070 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3072 /* The first time through, just add SEARCH_EXTS to whatever we
3073 * already have, so we can check for default file types. */
3075 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3081 if ((strlen(tmpbuf) + strlen(scriptname)
3082 + MAX_EXT_LEN) >= sizeof tmpbuf)
3083 continue; /* don't search dir with too-long name */
3084 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3088 if (strEQ(scriptname, "-"))
3090 if (dosearch) { /* Look in '.' first. */
3091 const char *cur = scriptname;
3093 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3095 if (strEQ(ext[i++],curext)) {
3096 extidx = -1; /* already has an ext */
3101 DEBUG_p(PerlIO_printf(Perl_debug_log,
3102 "Looking for %s\n",cur));
3103 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3104 && !S_ISDIR(PL_statbuf.st_mode)) {
3112 if (cur == scriptname) {
3113 len = strlen(scriptname);
3114 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3116 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3119 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3120 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3125 #ifdef MACOS_TRADITIONAL
3126 if (dosearch && !strchr(scriptname, ':') &&
3127 (s = PerlEnv_getenv("Commands")))
3129 if (dosearch && !strchr(scriptname, '/')
3131 && !strchr(scriptname, '\\')
3133 && (s = PerlEnv_getenv("PATH")))
3138 PL_bufend = s + strlen(s);
3139 while (s < PL_bufend) {
3140 #ifdef MACOS_TRADITIONAL
3141 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3145 #if defined(atarist) || defined(DOSISH)
3150 && *s != ';'; len++, s++) {
3151 if (len < sizeof tmpbuf)
3154 if (len < sizeof tmpbuf)
3156 #else /* ! (atarist || DOSISH) */
3157 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3160 #endif /* ! (atarist || DOSISH) */
3161 #endif /* MACOS_TRADITIONAL */
3164 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3165 continue; /* don't search dir with too-long name */
3166 #ifdef MACOS_TRADITIONAL
3167 if (len && tmpbuf[len - 1] != ':')
3168 tmpbuf[len++] = ':';
3171 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3172 && tmpbuf[len - 1] != '/'
3173 && tmpbuf[len - 1] != '\\'
3176 tmpbuf[len++] = '/';
3177 if (len == 2 && tmpbuf[0] == '.')
3180 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3184 len = strlen(tmpbuf);
3185 if (extidx > 0) /* reset after previous loop */
3189 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3190 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3191 if (S_ISDIR(PL_statbuf.st_mode)) {
3195 } while ( retval < 0 /* not there */
3196 && extidx>=0 && ext[extidx] /* try an extension? */
3197 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3202 if (S_ISREG(PL_statbuf.st_mode)
3203 && cando(S_IRUSR,TRUE,&PL_statbuf)
3204 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3205 && cando(S_IXUSR,TRUE,&PL_statbuf)
3209 xfound = tmpbuf; /* bingo! */
3213 xfailed = savepv(tmpbuf);
3216 if (!xfound && !seen_dot && !xfailed &&
3217 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3218 || S_ISDIR(PL_statbuf.st_mode)))
3220 seen_dot = 1; /* Disable message. */
3222 if (flags & 1) { /* do or die? */
3223 Perl_croak(aTHX_ "Can't %s %s%s%s",
3224 (xfailed ? "execute" : "find"),
3225 (xfailed ? xfailed : scriptname),
3226 (xfailed ? "" : " on PATH"),
3227 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3232 scriptname = xfound;
3234 return (scriptname ? savepv(scriptname) : NULL);
3237 #ifndef PERL_GET_CONTEXT_DEFINED
3240 Perl_get_context(void)
3243 #if defined(USE_ITHREADS)
3244 # ifdef OLD_PTHREADS_API
3246 if (pthread_getspecific(PL_thr_key, &t))
3247 Perl_croak_nocontext("panic: pthread_getspecific");
3250 # ifdef I_MACH_CTHREADS
3251 return (void*)cthread_data(cthread_self());
3253 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3262 Perl_set_context(void *t)
3265 #if defined(USE_ITHREADS)
3266 # ifdef I_MACH_CTHREADS
3267 cthread_set_data(cthread_self(), t);
3269 if (pthread_setspecific(PL_thr_key, t))
3270 Perl_croak_nocontext("panic: pthread_setspecific");
3277 #endif /* !PERL_GET_CONTEXT_DEFINED */
3279 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3288 Perl_get_op_names(pTHX)
3290 PERL_UNUSED_CONTEXT;
3291 return (char **)PL_op_name;
3295 Perl_get_op_descs(pTHX)
3297 PERL_UNUSED_CONTEXT;
3298 return (char **)PL_op_desc;
3302 Perl_get_no_modify(pTHX)
3304 PERL_UNUSED_CONTEXT;
3305 return PL_no_modify;
3309 Perl_get_opargs(pTHX)
3311 PERL_UNUSED_CONTEXT;
3312 return (U32 *)PL_opargs;
3316 Perl_get_ppaddr(pTHX)
3319 PERL_UNUSED_CONTEXT;
3320 return (PPADDR_t*)PL_ppaddr;
3323 #ifndef HAS_GETENV_LEN
3325 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3327 char * const env_trans = PerlEnv_getenv(env_elem);
3328 PERL_UNUSED_CONTEXT;
3330 *len = strlen(env_trans);
3337 Perl_get_vtbl(pTHX_ int vtbl_id)
3339 const MGVTBL* result;
3340 PERL_UNUSED_CONTEXT;
3344 result = &PL_vtbl_sv;
3347 result = &PL_vtbl_env;
3349 case want_vtbl_envelem:
3350 result = &PL_vtbl_envelem;
3353 result = &PL_vtbl_sig;
3355 case want_vtbl_sigelem:
3356 result = &PL_vtbl_sigelem;
3358 case want_vtbl_pack:
3359 result = &PL_vtbl_pack;
3361 case want_vtbl_packelem:
3362 result = &PL_vtbl_packelem;
3364 case want_vtbl_dbline:
3365 result = &PL_vtbl_dbline;
3368 result = &PL_vtbl_isa;
3370 case want_vtbl_isaelem:
3371 result = &PL_vtbl_isaelem;
3373 case want_vtbl_arylen:
3374 result = &PL_vtbl_arylen;
3376 case want_vtbl_mglob:
3377 result = &PL_vtbl_mglob;
3379 case want_vtbl_nkeys:
3380 result = &PL_vtbl_nkeys;
3382 case want_vtbl_taint:
3383 result = &PL_vtbl_taint;
3385 case want_vtbl_substr:
3386 result = &PL_vtbl_substr;
3389 result = &PL_vtbl_vec;
3392 result = &PL_vtbl_pos;
3395 result = &PL_vtbl_bm;
3398 result = &PL_vtbl_fm;
3400 case want_vtbl_uvar:
3401 result = &PL_vtbl_uvar;
3403 case want_vtbl_defelem:
3404 result = &PL_vtbl_defelem;
3406 case want_vtbl_regexp:
3407 result = &PL_vtbl_regexp;
3409 case want_vtbl_regdata:
3410 result = &PL_vtbl_regdata;
3412 case want_vtbl_regdatum:
3413 result = &PL_vtbl_regdatum;
3415 #ifdef USE_LOCALE_COLLATE
3416 case want_vtbl_collxfrm:
3417 result = &PL_vtbl_collxfrm;
3420 case want_vtbl_amagic:
3421 result = &PL_vtbl_amagic;
3423 case want_vtbl_amagicelem:
3424 result = &PL_vtbl_amagicelem;
3426 case want_vtbl_backref:
3427 result = &PL_vtbl_backref;
3429 case want_vtbl_utf8:
3430 result = &PL_vtbl_utf8;
3436 return (MGVTBL*)result;
3440 Perl_my_fflush_all(pTHX)
3442 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3443 return PerlIO_flush(NULL);
3445 # if defined(HAS__FWALK)
3446 extern int fflush(FILE *);
3447 /* undocumented, unprototyped, but very useful BSDism */
3448 extern void _fwalk(int (*)(FILE *));
3452 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3454 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3455 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3457 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3458 open_max = sysconf(_SC_OPEN_MAX);
3461 open_max = FOPEN_MAX;
3464 open_max = OPEN_MAX;
3475 for (i = 0; i < open_max; i++)
3476 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3477 STDIO_STREAM_ARRAY[i]._file < open_max &&
3478 STDIO_STREAM_ARRAY[i]._flag)
3479 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3483 SETERRNO(EBADF,RMS_IFI);
3490 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3492 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3494 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3495 if (ckWARN(WARN_IO)) {
3496 const char * const direction =
3497 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3499 Perl_warner(aTHX_ packWARN(WARN_IO),
3500 "Filehandle %s opened only for %sput",
3503 Perl_warner(aTHX_ packWARN(WARN_IO),
3504 "Filehandle opened only for %sput", direction);
3511 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3513 warn_type = WARN_CLOSED;
3517 warn_type = WARN_UNOPENED;
3520 if (ckWARN(warn_type)) {
3521 const char * const pars =
3522 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3523 const char * const func =
3525 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3526 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3527 op < 0 ? "" : /* handle phoney cases */
3529 const char * const type =
3531 (OP_IS_SOCKET(op) ||
3532 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3533 "socket" : "filehandle");
3534 if (name && *name) {
3535 Perl_warner(aTHX_ packWARN(warn_type),
3536 "%s%s on %s %s %s", func, pars, vile, type, name);
3537 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3539 aTHX_ packWARN(warn_type),
3540 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3545 Perl_warner(aTHX_ packWARN(warn_type),
3546 "%s%s on %s %s", func, pars, vile, type);
3547 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3549 aTHX_ packWARN(warn_type),
3550 "\t(Are you trying to call %s%s on dirhandle?)\n",
3559 /* in ASCII order, not that it matters */
3560 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3563 Perl_ebcdic_control(pTHX_ int ch)
3571 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3572 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3575 if (ctlp == controllablechars)
3576 return('\177'); /* DEL */
3578 return((unsigned char)(ctlp - controllablechars - 1));
3579 } else { /* Want uncontrol */
3580 if (ch == '\177' || ch == -1)
3582 else if (ch == '\157')
3584 else if (ch == '\174')
3586 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3588 else if (ch == '\155')
3590 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3591 return(controllablechars[ch+1]);
3593 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3598 /* To workaround core dumps from the uninitialised tm_zone we get the
3599 * system to give us a reasonable struct to copy. This fix means that
3600 * strftime uses the tm_zone and tm_gmtoff values returned by
3601 * localtime(time()). That should give the desired result most of the
3602 * time. But probably not always!
3604 * This does not address tzname aspects of NETaa14816.
3609 # ifndef STRUCT_TM_HASZONE
3610 # define STRUCT_TM_HASZONE
3614 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3615 # ifndef HAS_TM_TM_ZONE
3616 # define HAS_TM_TM_ZONE
3621 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3623 #ifdef HAS_TM_TM_ZONE
3625 const struct tm* my_tm;
3627 my_tm = localtime(&now);
3629 Copy(my_tm, ptm, 1, struct tm);
3631 PERL_UNUSED_ARG(ptm);
3636 * mini_mktime - normalise struct tm values without the localtime()
3637 * semantics (and overhead) of mktime().
3640 Perl_mini_mktime(pTHX_ struct tm *ptm)
3644 int month, mday, year, jday;
3645 int odd_cent, odd_year;
3646 PERL_UNUSED_CONTEXT;
3648 #define DAYS_PER_YEAR 365
3649 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3650 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3651 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3652 #define SECS_PER_HOUR (60*60)
3653 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3654 /* parentheses deliberately absent on these two, otherwise they don't work */
3655 #define MONTH_TO_DAYS 153/5
3656 #define DAYS_TO_MONTH 5/153
3657 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3658 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3659 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3660 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3663 * Year/day algorithm notes:
3665 * With a suitable offset for numeric value of the month, one can find
3666 * an offset into the year by considering months to have 30.6 (153/5) days,
3667 * using integer arithmetic (i.e., with truncation). To avoid too much
3668 * messing about with leap days, we consider January and February to be
3669 * the 13th and 14th month of the previous year. After that transformation,
3670 * we need the month index we use to be high by 1 from 'normal human' usage,
3671 * so the month index values we use run from 4 through 15.
3673 * Given that, and the rules for the Gregorian calendar (leap years are those
3674 * divisible by 4 unless also divisible by 100, when they must be divisible
3675 * by 400 instead), we can simply calculate the number of days since some
3676 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3677 * the days we derive from our month index, and adding in the day of the
3678 * month. The value used here is not adjusted for the actual origin which
3679 * it normally would use (1 January A.D. 1), since we're not exposing it.
3680 * We're only building the value so we can turn around and get the
3681 * normalised values for the year, month, day-of-month, and day-of-year.
3683 * For going backward, we need to bias the value we're using so that we find
3684 * the right year value. (Basically, we don't want the contribution of
3685 * March 1st to the number to apply while deriving the year). Having done
3686 * that, we 'count up' the contribution to the year number by accounting for
3687 * full quadracenturies (400-year periods) with their extra leap days, plus
3688 * the contribution from full centuries (to avoid counting in the lost leap
3689 * days), plus the contribution from full quad-years (to count in the normal
3690 * leap days), plus the leftover contribution from any non-leap years.
3691 * At this point, if we were working with an actual leap day, we'll have 0
3692 * days left over. This is also true for March 1st, however. So, we have
3693 * to special-case that result, and (earlier) keep track of the 'odd'
3694 * century and year contributions. If we got 4 extra centuries in a qcent,
3695 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3696 * Otherwise, we add back in the earlier bias we removed (the 123 from
3697 * figuring in March 1st), find the month index (integer division by 30.6),
3698 * and the remainder is the day-of-month. We then have to convert back to
3699 * 'real' months (including fixing January and February from being 14/15 in
3700 * the previous year to being in the proper year). After that, to get
3701 * tm_yday, we work with the normalised year and get a new yearday value for
3702 * January 1st, which we subtract from the yearday value we had earlier,
3703 * representing the date we've re-built. This is done from January 1
3704 * because tm_yday is 0-origin.
3706 * Since POSIX time routines are only guaranteed to work for times since the
3707 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3708 * applies Gregorian calendar rules even to dates before the 16th century
3709 * doesn't bother me. Besides, you'd need cultural context for a given
3710 * date to know whether it was Julian or Gregorian calendar, and that's
3711 * outside the scope for this routine. Since we convert back based on the
3712 * same rules we used to build the yearday, you'll only get strange results
3713 * for input which needed normalising, or for the 'odd' century years which
3714 * were leap years in the Julian calander but not in the Gregorian one.
3715 * I can live with that.
3717 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3718 * that's still outside the scope for POSIX time manipulation, so I don't
3722 year = 1900 + ptm->tm_year;
3723 month = ptm->tm_mon;
3724 mday = ptm->tm_mday;
3725 /* allow given yday with no month & mday to dominate the result */
3726 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3729 jday = 1 + ptm->tm_yday;
3738 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3739 yearday += month*MONTH_TO_DAYS + mday + jday;
3741 * Note that we don't know when leap-seconds were or will be,
3742 * so we have to trust the user if we get something which looks
3743 * like a sensible leap-second. Wild values for seconds will
3744 * be rationalised, however.
3746 if ((unsigned) ptm->tm_sec <= 60) {
3753 secs += 60 * ptm->tm_min;
3754 secs += SECS_PER_HOUR * ptm->tm_hour;
3756 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3757 /* got negative remainder, but need positive time */
3758 /* back off an extra day to compensate */
3759 yearday += (secs/SECS_PER_DAY)-1;
3760 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3763 yearday += (secs/SECS_PER_DAY);
3764 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3767 else if (secs >= SECS_PER_DAY) {
3768 yearday += (secs/SECS_PER_DAY);
3769 secs %= SECS_PER_DAY;
3771 ptm->tm_hour = secs/SECS_PER_HOUR;
3772 secs %= SECS_PER_HOUR;
3773 ptm->tm_min = secs/60;
3775 ptm->tm_sec += secs;
3776 /* done with time of day effects */
3778 * The algorithm for yearday has (so far) left it high by 428.
3779 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3780 * bias it by 123 while trying to figure out what year it
3781 * really represents. Even with this tweak, the reverse
3782 * translation fails for years before A.D. 0001.
3783 * It would still fail for Feb 29, but we catch that one below.
3785 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3786 yearday -= YEAR_ADJUST;
3787 year = (yearday / DAYS_PER_QCENT) * 400;
3788 yearday %= DAYS_PER_QCENT;
3789 odd_cent = yearday / DAYS_PER_CENT;
3790 year += odd_cent * 100;
3791 yearday %= DAYS_PER_CENT;
3792 year += (yearday / DAYS_PER_QYEAR) * 4;
3793 yearday %= DAYS_PER_QYEAR;
3794 odd_year = yearday / DAYS_PER_YEAR;
3796 yearday %= DAYS_PER_YEAR;
3797 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3802 yearday += YEAR_ADJUST; /* recover March 1st crock */
3803 month = yearday*DAYS_TO_MONTH;
3804 yearday -= month*MONTH_TO_DAYS;
3805 /* recover other leap-year adjustment */
3814 ptm->tm_year = year - 1900;
3816 ptm->tm_mday = yearday;
3817 ptm->tm_mon = month;
3821 ptm->tm_mon = month - 1;
3823 /* re-build yearday based on Jan 1 to get tm_yday */
3825 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3826 yearday += 14*MONTH_TO_DAYS + 1;
3827 ptm->tm_yday = jday - yearday;
3828 /* fix tm_wday if not overridden by caller */
3829 if ((unsigned)ptm->tm_wday > 6)
3830 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3834 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)
3842 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3845 mytm.tm_hour = hour;
3846 mytm.tm_mday = mday;
3848 mytm.tm_year = year;
3849 mytm.tm_wday = wday;
3850 mytm.tm_yday = yday;
3851 mytm.tm_isdst = isdst;
3853 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3854 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3859 #ifdef HAS_TM_TM_GMTOFF
3860 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3862 #ifdef HAS_TM_TM_ZONE
3863 mytm.tm_zone = mytm2.tm_zone;
3868 Newx(buf, buflen, char);
3869 len = strftime(buf, buflen, fmt, &mytm);
3871 ** The following is needed to handle to the situation where
3872 ** tmpbuf overflows. Basically we want to allocate a buffer
3873 ** and try repeatedly. The reason why it is so complicated
3874 ** is that getting a return value of 0 from strftime can indicate
3875 ** one of the following:
3876 ** 1. buffer overflowed,
3877 ** 2. illegal conversion specifier, or
3878 ** 3. the format string specifies nothing to be returned(not
3879 ** an error). This could be because format is an empty string
3880 ** or it specifies %p that yields an empty string in some locale.
3881 ** If there is a better way to make it portable, go ahead by
3884 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3887 /* Possibly buf overflowed - try again with a bigger buf */
3888 const int fmtlen = strlen(fmt);
3889 int bufsize = fmtlen + buflen;
3891 Newx(buf, bufsize, char);
3893 buflen = strftime(buf, bufsize, fmt, &mytm);
3894 if (buflen > 0 && buflen < bufsize)
3896 /* heuristic to prevent out-of-memory errors */
3897 if (bufsize > 100*fmtlen) {
3903 Renew(buf, bufsize, char);
3908 Perl_croak(aTHX_ "panic: no strftime");
3914 #define SV_CWD_RETURN_UNDEF \
3915 sv_setsv(sv, &PL_sv_undef); \
3918 #define SV_CWD_ISDOT(dp) \
3919 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3920 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3923 =head1 Miscellaneous Functions
3925 =for apidoc getcwd_sv
3927 Fill the sv with current working directory
3932 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3933 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3934 * getcwd(3) if available
3935 * Comments from the orignal:
3936 * This is a faster version of getcwd. It's also more dangerous
3937 * because you might chdir out of a directory that you can't chdir
3941 Perl_getcwd_sv(pTHX_ register SV *sv)
3945 #ifndef INCOMPLETE_TAINTS
3951 char buf[MAXPATHLEN];
3953 /* Some getcwd()s automatically allocate a buffer of the given
3954 * size from the heap if they are given a NULL buffer pointer.
3955 * The problem is that this behaviour is not portable. */
3956 if (getcwd(buf, sizeof(buf) - 1)) {
3961 sv_setsv(sv, &PL_sv_undef);
3969 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3973 SvUPGRADE(sv, SVt_PV);
3975 if (PerlLIO_lstat(".", &statbuf) < 0) {
3976 SV_CWD_RETURN_UNDEF;
3979 orig_cdev = statbuf.st_dev;
3980 orig_cino = statbuf.st_ino;
3989 if (PerlDir_chdir("..") < 0) {
3990 SV_CWD_RETURN_UNDEF;
3992 if (PerlLIO_stat(".", &statbuf) < 0) {
3993 SV_CWD_RETURN_UNDEF;
3996 cdev = statbuf.st_dev;
3997 cino = statbuf.st_ino;
3999 if (odev == cdev && oino == cino) {
4002 if (!(dir = PerlDir_open("."))) {
4003 SV_CWD_RETURN_UNDEF;
4006 while ((dp = PerlDir_read(dir)) != NULL) {
4008 const int namelen = dp->d_namlen;
4010 const int namelen = strlen(dp->d_name);
4013 if (SV_CWD_ISDOT(dp)) {
4017 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4018 SV_CWD_RETURN_UNDEF;
4021 tdev = statbuf.st_dev;
4022 tino = statbuf.st_ino;
4023 if (tino == oino && tdev == odev) {
4029 SV_CWD_RETURN_UNDEF;
4032 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4033 SV_CWD_RETURN_UNDEF;
4036 SvGROW(sv, pathlen + namelen + 1);
4040 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4043 /* prepend current directory to the front */
4045 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4046 pathlen += (namelen + 1);
4048 #ifdef VOID_CLOSEDIR
4051 if (PerlDir_close(dir) < 0) {
4052 SV_CWD_RETURN_UNDEF;
4058 SvCUR_set(sv, pathlen);
4062 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4063 SV_CWD_RETURN_UNDEF;
4066 if (PerlLIO_stat(".", &statbuf) < 0) {
4067 SV_CWD_RETURN_UNDEF;
4070 cdev = statbuf.st_dev;
4071 cino = statbuf.st_ino;
4073 if (cdev != orig_cdev || cino != orig_cino) {
4074 Perl_croak(aTHX_ "Unstable directory path, "
4075 "current directory changed unexpectedly");
4087 =for apidoc scan_version
4089 Returns a pointer to the next character after the parsed
4090 version string, as well as upgrading the passed in SV to
4093 Function must be called with an already existing SV like
4096 s = scan_version(s, SV *sv, bool qv);
4098 Performs some preprocessing to the string to ensure that
4099 it has the correct characteristics of a version. Flags the
4100 object if it contains an underscore (which denotes this
4101 is an alpha version). The boolean qv denotes that the version
4102 should be interpreted as if it had multiple decimals, even if
4109 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4117 AV * const av = newAV();
4118 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4119 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4121 #ifndef NODEFAULT_SHAREKEYS
4122 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4125 while (isSPACE(*s)) /* leading whitespace is OK */
4129 s++; /* get past 'v' */
4130 qv = 1; /* force quoted version processing */
4133 start = last = pos = s;
4135 /* pre-scan the input string to check for decimals/underbars */
4136 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4141 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4145 else if ( *pos == '_' )
4148 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4150 width = pos - last - 1; /* natural width of sub-version */
4155 if ( alpha && !saw_period )
4156 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4158 if ( alpha && saw_period && width == 0 )
4159 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4161 if ( saw_period > 1 )
4162 qv = 1; /* force quoted version processing */
4167 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4169 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4170 if ( !qv && width < 3 )
4171 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4173 while (isDIGIT(*pos))
4175 if (!isALPHA(*pos)) {
4181 /* this is atoi() that delimits on underscores */
4182 const char *end = pos;
4186 /* the following if() will only be true after the decimal
4187 * point of a version originally created with a bare
4188 * floating point number, i.e. not quoted in any way
4190 if ( !qv && s > start && saw_period == 1 ) {
4194 rev += (*s - '0') * mult;
4196 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4197 Perl_croak(aTHX_ "Integer overflow in version");
4204 while (--end >= s) {
4206 rev += (*end - '0') * mult;
4208 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4209 Perl_croak(aTHX_ "Integer overflow in version");
4214 /* Append revision */
4215 av_push(av, newSViv(rev));
4218 else if ( *pos == '_' && isDIGIT(pos[1]) )
4220 else if ( isDIGIT(*pos) )
4227 while ( isDIGIT(*pos) )
4232 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4240 if ( qv ) { /* quoted versions always get at least three terms*/
4241 I32 len = av_len(av);
4242 /* This for loop appears to trigger a compiler bug on OS X, as it
4243 loops infinitely. Yes, len is negative. No, it makes no sense.
4244 Compiler in question is:
4245 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4246 for ( len = 2 - len; len > 0; len-- )
4247 av_push((AV *)sv, newSViv(0));
4251 av_push(av, newSViv(0));
4254 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4255 av_push(av, newSViv(0));
4257 /* fix RT#19517 - special case 'undef' as string */
4258 if ( *s == 'u' && strEQ(s,"undef") ) {
4262 /* And finally, store the AV in the hash */
4263 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4268 =for apidoc new_version
4270 Returns a new version object based on the passed in SV:
4272 SV *sv = new_version(SV *ver);
4274 Does not alter the passed in ver SV. See "upg_version" if you
4275 want to upgrade the SV.
4281 Perl_new_version(pTHX_ SV *ver)
4284 SV * const rv = newSV(0);
4285 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4288 AV * const av = newAV();
4290 /* This will get reblessed later if a derived class*/
4291 SV * const hv = newSVrv(rv, "version");
4292 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4293 #ifndef NODEFAULT_SHAREKEYS
4294 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4300 /* Begin copying all of the elements */
4301 if ( hv_exists((HV *)ver, "qv", 2) )
4302 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4304 if ( hv_exists((HV *)ver, "alpha", 5) )
4305 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4307 if ( hv_exists((HV*)ver, "width", 5 ) )
4309 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4310 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4313 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4314 /* This will get reblessed later if a derived class*/
4315 for ( key = 0; key <= av_len(sav); key++ )
4317 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4318 av_push(av, newSViv(rev));
4321 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4326 const MAGIC* const mg = SvVSTRING_mg(ver);
4327 if ( mg ) { /* already a v-string */
4328 const STRLEN len = mg->mg_len;
4329 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4330 sv_setpvn(rv,version,len);
4335 sv_setsv(rv,ver); /* make a duplicate */
4340 return upg_version(rv, FALSE);
4344 =for apidoc upg_version
4346 In-place upgrade of the supplied SV to a version object.
4348 SV *sv = upg_version(SV *sv, bool qv);
4350 Returns a pointer to the upgraded SV. Set the boolean qv if you want
4351 to force this SV to be interpreted as an "extended" version.
4357 Perl_upg_version(pTHX_ SV *ver, bool qv)
4359 const char *version, *s;
4364 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4366 /* may get too much accuracy */
4368 #ifdef USE_LOCALE_NUMERIC
4369 char *loc = setlocale(LC_NUMERIC, "C");
4371 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4372 #ifdef USE_LOCALE_NUMERIC
4373 setlocale(LC_NUMERIC, loc);
4375 while (tbuf[len-1] == '0' && len > 0) len--;
4376 version = savepvn(tbuf, len);
4379 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4380 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4384 else /* must be a string or something like a string */
4387 version = savepv(SvPV(ver,len));
4389 # if PERL_VERSION > 5
4390 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4391 if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4392 /* may be a v-string */
4393 SV * const nsv = sv_newmortal();
4397 sv_setpvf(nsv,"%vd",ver);
4398 pos = nver = savepv(SvPV_nolen(nsv));
4400 /* scan the resulting formatted string */
4401 while ( *pos == '.' || isDIGIT(*pos) ) {
4407 /* is definitely a v-string */
4408 if ( saw_period == 2 ) {
4417 s = scan_version(version, ver, qv);
4419 if(ckWARN(WARN_MISC))
4420 Perl_warner(aTHX_ packWARN(WARN_MISC),
4421 "Version string '%s' contains invalid data; "
4422 "ignoring: '%s'", version, s);
4430 Validates that the SV contains a valid version object.
4432 bool vverify(SV *vobj);
4434 Note that it only confirms the bare minimum structure (so as not to get
4435 confused by derived classes which may contain additional hash entries):
4439 =item * The SV contains a [reference to a] hash
4441 =item * The hash contains a "version" key
4443 =item * The "version" key has [a reference to] an AV as its value
4451 Perl_vverify(pTHX_ SV *vs)
4457 /* see if the appropriate elements exist */
4458 if ( SvTYPE(vs) == SVt_PVHV
4459 && hv_exists((HV*)vs, "version", 7)
4460 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4461 && SvTYPE(sv) == SVt_PVAV )
4470 Accepts a version object and returns the normalized floating
4471 point representation. Call like:
4475 NOTE: you can pass either the object directly or the SV
4476 contained within the RV.
4482 Perl_vnumify(pTHX_ SV *vs)
4487 SV * const sv = newSV(0);
4493 Perl_croak(aTHX_ "Invalid version object");
4495 /* see if various flags exist */
4496 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4498 if ( hv_exists((HV*)vs, "width", 5 ) )
4499 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4504 /* attempt to retrieve the version array */
4505 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4517 digit = SvIV(*av_fetch(av, 0, 0));
4518 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4519 for ( i = 1 ; i < len ; i++ )
4521 digit = SvIV(*av_fetch(av, i, 0));
4523 const int denom = (width == 2 ? 10 : 100);
4524 const div_t term = div((int)PERL_ABS(digit),denom);
4525 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4528 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4534 digit = SvIV(*av_fetch(av, len, 0));
4535 if ( alpha && width == 3 ) /* alpha version */
4537 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4541 sv_catpvs(sv, "000");
4549 Accepts a version object and returns the normalized string
4550 representation. Call like:
4554 NOTE: you can pass either the object directly or the SV
4555 contained within the RV.
4561 Perl_vnormal(pTHX_ SV *vs)
4565 SV * const sv = newSV(0);
4571 Perl_croak(aTHX_ "Invalid version object");
4573 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4575 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4583 digit = SvIV(*av_fetch(av, 0, 0));
4584 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4585 for ( i = 1 ; i < len ; i++ ) {
4586 digit = SvIV(*av_fetch(av, i, 0));
4587 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4592 /* handle last digit specially */
4593 digit = SvIV(*av_fetch(av, len, 0));
4595 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4597 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4600 if ( len <= 2 ) { /* short version, must be at least three */
4601 for ( len = 2 - len; len != 0; len-- )
4608 =for apidoc vstringify
4610 In order to maintain maximum compatibility with earlier versions
4611 of Perl, this function will return either the floating point
4612 notation or the multiple dotted notation, depending on whether
4613 the original version contained 1 or more dots, respectively
4619 Perl_vstringify(pTHX_ SV *vs)
4625 Perl_croak(aTHX_ "Invalid version object");
4627 if ( hv_exists((HV *)vs, "qv", 2) )
4636 Version object aware cmp. Both operands must already have been
4637 converted into version objects.
4643 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4646 bool lalpha = FALSE;
4647 bool ralpha = FALSE;
4656 if ( !vverify(lhv) )
4657 Perl_croak(aTHX_ "Invalid version object");
4659 if ( !vverify(rhv) )
4660 Perl_croak(aTHX_ "Invalid version object");
4662 /* get the left hand term */
4663 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4664 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4667 /* and the right hand term */
4668 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4669 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4677 while ( i <= m && retval == 0 )
4679 left = SvIV(*av_fetch(lav,i,0));
4680 right = SvIV(*av_fetch(rav,i,0));
4688 /* tiebreaker for alpha with identical terms */
4689 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4691 if ( lalpha && !ralpha )
4695 else if ( ralpha && !lalpha)
4701 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4705 while ( i <= r && retval == 0 )
4707 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4708 retval = -1; /* not a match after all */
4714 while ( i <= l && retval == 0 )
4716 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4717 retval = +1; /* not a match after all */
4725 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4726 # define EMULATE_SOCKETPAIR_UDP
4729 #ifdef EMULATE_SOCKETPAIR_UDP
4731 S_socketpair_udp (int fd[2]) {
4733 /* Fake a datagram socketpair using UDP to localhost. */
4734 int sockets[2] = {-1, -1};
4735 struct sockaddr_in addresses[2];
4737 Sock_size_t size = sizeof(struct sockaddr_in);
4738 unsigned short port;
4741 memset(&addresses, 0, sizeof(addresses));
4744 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4745 if (sockets[i] == -1)
4746 goto tidy_up_and_fail;
4748 addresses[i].sin_family = AF_INET;
4749 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4750 addresses[i].sin_port = 0; /* kernel choses port. */
4751 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4752 sizeof(struct sockaddr_in)) == -1)
4753 goto tidy_up_and_fail;
4756 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4757 for each connect the other socket to it. */
4760 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4762 goto tidy_up_and_fail;
4763 if (size != sizeof(struct sockaddr_in))
4764 goto abort_tidy_up_and_fail;
4765 /* !1 is 0, !0 is 1 */
4766 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4767 sizeof(struct sockaddr_in)) == -1)
4768 goto tidy_up_and_fail;
4771 /* Now we have 2 sockets connected to each other. I don't trust some other
4772 process not to have already sent a packet to us (by random) so send
4773 a packet from each to the other. */
4776 /* I'm going to send my own port number. As a short.
4777 (Who knows if someone somewhere has sin_port as a bitfield and needs
4778 this routine. (I'm assuming crays have socketpair)) */
4779 port = addresses[i].sin_port;
4780 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4781 if (got != sizeof(port)) {
4783 goto tidy_up_and_fail;
4784 goto abort_tidy_up_and_fail;
4788 /* Packets sent. I don't trust them to have arrived though.
4789 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4790 connect to localhost will use a second kernel thread. In 2.6 the
4791 first thread running the connect() returns before the second completes,
4792 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4793 returns 0. Poor programs have tripped up. One poor program's authors'
4794 had a 50-1 reverse stock split. Not sure how connected these were.)
4795 So I don't trust someone not to have an unpredictable UDP stack.
4799 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4800 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4804 FD_SET((unsigned int)sockets[0], &rset);
4805 FD_SET((unsigned int)sockets[1], &rset);
4807 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4808 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4809 || !FD_ISSET(sockets[1], &rset)) {
4810 /* I hope this is portable and appropriate. */
4812 goto tidy_up_and_fail;
4813 goto abort_tidy_up_and_fail;
4817 /* And the paranoia department even now doesn't trust it to have arrive
4818 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4820 struct sockaddr_in readfrom;
4821 unsigned short buffer[2];
4826 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4827 sizeof(buffer), MSG_DONTWAIT,
4828 (struct sockaddr *) &readfrom, &size);
4830 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4832 (struct sockaddr *) &readfrom, &size);
4836 goto tidy_up_and_fail;
4837 if (got != sizeof(port)
4838 || size != sizeof(struct sockaddr_in)
4839 /* Check other socket sent us its port. */
4840 || buffer[0] != (unsigned short) addresses[!i].sin_port
4841 /* Check kernel says we got the datagram from that socket */
4842 || readfrom.sin_family != addresses[!i].sin_family
4843 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4844 || readfrom.sin_port != addresses[!i].sin_port)
4845 goto abort_tidy_up_and_fail;
4848 /* My caller (my_socketpair) has validated that this is non-NULL */
4851 /* I hereby declare this connection open. May God bless all who cross
4855 abort_tidy_up_and_fail:
4856 errno = ECONNABORTED;
4859 const int save_errno = errno;
4860 if (sockets[0] != -1)
4861 PerlLIO_close(sockets[0]);
4862 if (sockets[1] != -1)
4863 PerlLIO_close(sockets[1]);
4868 #endif /* EMULATE_SOCKETPAIR_UDP */
4870 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4872 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4873 /* Stevens says that family must be AF_LOCAL, protocol 0.
4874 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4879 struct sockaddr_in listen_addr;
4880 struct sockaddr_in connect_addr;
4885 || family != AF_UNIX
4888 errno = EAFNOSUPPORT;
4896 #ifdef EMULATE_SOCKETPAIR_UDP
4897 if (type == SOCK_DGRAM)
4898 return S_socketpair_udp(fd);
4901 listener = PerlSock_socket(AF_INET, type, 0);
4904 memset(&listen_addr, 0, sizeof(listen_addr));
4905 listen_addr.sin_family = AF_INET;
4906 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4907 listen_addr.sin_port = 0; /* kernel choses port. */
4908 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4909 sizeof(listen_addr)) == -1)
4910 goto tidy_up_and_fail;
4911 if (PerlSock_listen(listener, 1) == -1)
4912 goto tidy_up_and_fail;
4914 connector = PerlSock_socket(AF_INET, type, 0);
4915 if (connector == -1)
4916 goto tidy_up_and_fail;
4917 /* We want to find out the port number to connect to. */
4918 size = sizeof(connect_addr);
4919 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4921 goto tidy_up_and_fail;
4922 if (size != sizeof(connect_addr))
4923 goto abort_tidy_up_and_fail;
4924 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4925 sizeof(connect_addr)) == -1)
4926 goto tidy_up_and_fail;
4928 size = sizeof(listen_addr);
4929 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4932 goto tidy_up_and_fail;
4933 if (size != sizeof(listen_addr))
4934 goto abort_tidy_up_and_fail;
4935 PerlLIO_close(listener);
4936 /* Now check we are talking to ourself by matching port and host on the
4938 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4940 goto tidy_up_and_fail;
4941 if (size != sizeof(connect_addr)
4942 || listen_addr.sin_family != connect_addr.sin_family
4943 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4944 || listen_addr.sin_port != connect_addr.sin_port) {
4945 goto abort_tidy_up_and_fail;
4951 abort_tidy_up_and_fail:
4953 errno = ECONNABORTED; /* This would be the standard thing to do. */
4955 # ifdef ECONNREFUSED
4956 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4958 errno = ETIMEDOUT; /* Desperation time. */
4963 const int save_errno = errno;
4965 PerlLIO_close(listener);
4966 if (connector != -1)
4967 PerlLIO_close(connector);
4969 PerlLIO_close(acceptor);
4975 /* In any case have a stub so that there's code corresponding
4976 * to the my_socketpair in global.sym. */
4978 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4979 #ifdef HAS_SOCKETPAIR
4980 return socketpair(family, type, protocol, fd);
4989 =for apidoc sv_nosharing
4991 Dummy routine which "shares" an SV when there is no sharing module present.
4992 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4993 Exists to avoid test for a NULL function pointer and because it could
4994 potentially warn under some level of strict-ness.
5000 Perl_sv_nosharing(pTHX_ SV *sv)
5002 PERL_UNUSED_CONTEXT;
5003 PERL_UNUSED_ARG(sv);
5007 Perl_parse_unicode_opts(pTHX_ const char **popt)
5009 const char *p = *popt;
5014 opt = (U32) atoi(p);
5017 if (*p && *p != '\n' && *p != '\r')
5018 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5023 case PERL_UNICODE_STDIN:
5024 opt |= PERL_UNICODE_STDIN_FLAG; break;
5025 case PERL_UNICODE_STDOUT:
5026 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5027 case PERL_UNICODE_STDERR:
5028 opt |= PERL_UNICODE_STDERR_FLAG; break;
5029 case PERL_UNICODE_STD:
5030 opt |= PERL_UNICODE_STD_FLAG; break;
5031 case PERL_UNICODE_IN:
5032 opt |= PERL_UNICODE_IN_FLAG; break;
5033 case PERL_UNICODE_OUT:
5034 opt |= PERL_UNICODE_OUT_FLAG; break;
5035 case PERL_UNICODE_INOUT:
5036 opt |= PERL_UNICODE_INOUT_FLAG; break;
5037 case PERL_UNICODE_LOCALE:
5038 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5039 case PERL_UNICODE_ARGV:
5040 opt |= PERL_UNICODE_ARGV_FLAG; break;
5041 case PERL_UNICODE_UTF8CACHEASSERT:
5042 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5044 if (*p != '\n' && *p != '\r')
5046 "Unknown Unicode option letter '%c'", *p);
5052 opt = PERL_UNICODE_DEFAULT_FLAGS;
5054 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5055 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5056 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5068 * This is really just a quick hack which grabs various garbage
5069 * values. It really should be a real hash algorithm which
5070 * spreads the effect of every input bit onto every output bit,
5071 * if someone who knows about such things would bother to write it.
5072 * Might be a good idea to add that function to CORE as well.
5073 * No numbers below come from careful analysis or anything here,
5074 * except they are primes and SEED_C1 > 1E6 to get a full-width
5075 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5076 * probably be bigger too.
5079 # define SEED_C1 1000003
5080 #define SEED_C4 73819
5082 # define SEED_C1 25747
5083 #define SEED_C4 20639
5087 #define SEED_C5 26107
5089 #ifndef PERL_NO_DEV_RANDOM
5094 # include <starlet.h>
5095 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5096 * in 100-ns units, typically incremented ever 10 ms. */
5097 unsigned int when[2];
5099 # ifdef HAS_GETTIMEOFDAY
5100 struct timeval when;
5106 /* This test is an escape hatch, this symbol isn't set by Configure. */
5107 #ifndef PERL_NO_DEV_RANDOM
5108 #ifndef PERL_RANDOM_DEVICE
5109 /* /dev/random isn't used by default because reads from it will block
5110 * if there isn't enough entropy available. You can compile with
5111 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5112 * is enough real entropy to fill the seed. */
5113 # define PERL_RANDOM_DEVICE "/dev/urandom"
5115 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5117 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5126 _ckvmssts(sys$gettim(when));
5127 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5129 # ifdef HAS_GETTIMEOFDAY
5130 PerlProc_gettimeofday(&when,NULL);
5131 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5134 u = (U32)SEED_C1 * when;
5137 u += SEED_C3 * (U32)PerlProc_getpid();
5138 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5139 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5140 u += SEED_C5 * (U32)PTR2UV(&when);
5146 Perl_get_hash_seed(pTHX)
5149 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5155 if (s && isDIGIT(*s))
5156 myseed = (UV)Atoul(s);
5158 #ifdef USE_HASH_SEED_EXPLICIT
5162 /* Compute a random seed */
5163 (void)seedDrand01((Rand_seed_t)seed());
5164 myseed = (UV)(Drand01() * (NV)UV_MAX);
5165 #if RANDBITS < (UVSIZE * 8)
5166 /* Since there are not enough randbits to to reach all
5167 * the bits of a UV, the low bits might need extra
5168 * help. Sum in another random number that will
5169 * fill in the low bits. */
5171 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5172 #endif /* RANDBITS < (UVSIZE * 8) */
5173 if (myseed == 0) { /* Superparanoia. */
5174 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5176 Perl_croak(aTHX_ "Your random numbers are not that random");
5179 PL_rehash_seed_set = TRUE;
5186 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5188 const char * const stashpv = CopSTASHPV(c);
5189 const char * const name = HvNAME_get(hv);
5190 PERL_UNUSED_CONTEXT;
5192 if (stashpv == name)
5194 if (stashpv && name)
5195 if (strEQ(stashpv, name))
5202 #ifdef PERL_GLOBAL_STRUCT
5204 #define PERL_GLOBAL_STRUCT_INIT
5205 #include "opcode.h" /* the ppaddr and check */
5208 Perl_init_global_struct(pTHX)
5210 struct perl_vars *plvarsp = NULL;
5211 # ifdef PERL_GLOBAL_STRUCT
5212 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5213 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5214 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5215 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5216 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5220 plvarsp = PL_VarsPtr;
5221 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5227 # define PERLVAR(var,type) /**/
5228 # define PERLVARA(var,n,type) /**/
5229 # define PERLVARI(var,type,init) plvarsp->var = init;
5230 # define PERLVARIC(var,type,init) plvarsp->var = init;
5231 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5232 # include "perlvars.h"
5238 # ifdef PERL_GLOBAL_STRUCT
5241 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5242 if (!plvarsp->Gppaddr)
5246 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5247 if (!plvarsp->Gcheck)
5249 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5250 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5252 # ifdef PERL_SET_VARS
5253 PERL_SET_VARS(plvarsp);
5255 # undef PERL_GLOBAL_STRUCT_INIT
5260 #endif /* PERL_GLOBAL_STRUCT */
5262 #ifdef PERL_GLOBAL_STRUCT
5265 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5267 # ifdef PERL_GLOBAL_STRUCT
5268 # ifdef PERL_UNSET_VARS
5269 PERL_UNSET_VARS(plvarsp);
5271 free(plvarsp->Gppaddr);
5272 free(plvarsp->Gcheck);
5273 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5279 #endif /* PERL_GLOBAL_STRUCT */
5284 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5286 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5287 * variable PERL_MEM_LOG will be consulted, and if the integer value
5288 * of that is true, the logging will happen. (The default is to
5289 * always log if the PERL_MEM_LOG define was in effect.)
5293 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5294 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5296 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5299 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5300 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5301 * in which case the environment variable PERL_MEM_LOG_FD will be
5302 * consulted for the file descriptor number to use.
5304 #ifndef PERL_MEM_LOG_FD
5305 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5309 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)
5311 #ifdef PERL_MEM_LOG_STDERR
5312 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5315 # ifdef PERL_MEM_LOG_ENV
5316 s = getenv("PERL_MEM_LOG");
5317 if (s ? atoi(s) : 0)
5320 /* We can't use SVs or PerlIO for obvious reasons,
5321 * so we'll use stdio and low-level IO instead. */
5322 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5323 # ifdef PERL_MEM_LOG_TIMESTAMP
5325 # ifdef HAS_GETTIMEOFDAY
5326 gettimeofday(&tv, 0);
5328 /* If there are other OS specific ways of hires time than
5329 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5330 * probably that they would be used to fill in the struct
5337 # ifdef PERL_MEM_LOG_TIMESTAMP
5340 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5341 " %s = %"IVdf": %"UVxf"\n",
5342 # ifdef PERL_MEM_LOG_TIMESTAMP
5343 (int)tv.tv_sec, (int)tv.tv_usec,
5345 filename, linenumber, funcname, n, typesize,
5346 typename, n * typesize, PTR2UV(newalloc));
5347 # ifdef PERL_MEM_LOG_ENV_FD
5348 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5349 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5351 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5360 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)
5362 #ifdef PERL_MEM_LOG_STDERR
5363 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5366 # ifdef PERL_MEM_LOG_ENV
5367 s = PerlEnv_getenv("PERL_MEM_LOG");
5368 if (s ? atoi(s) : 0)
5371 /* We can't use SVs or PerlIO for obvious reasons,
5372 * so we'll use stdio and low-level IO instead. */
5373 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5374 # ifdef PERL_MEM_LOG_TIMESTAMP
5376 gettimeofday(&tv, 0);
5382 # ifdef PERL_MEM_LOG_TIMESTAMP
5385 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5386 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5387 # ifdef PERL_MEM_LOG_TIMESTAMP
5388 (int)tv.tv_sec, (int)tv.tv_usec,
5390 filename, linenumber, funcname, n, typesize,
5391 typename, n * typesize, PTR2UV(oldalloc),
5393 # ifdef PERL_MEM_LOG_ENV_FD
5394 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5395 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5397 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5406 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5408 #ifdef PERL_MEM_LOG_STDERR
5409 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5412 # ifdef PERL_MEM_LOG_ENV
5413 s = PerlEnv_getenv("PERL_MEM_LOG");
5414 if (s ? atoi(s) : 0)
5417 /* We can't use SVs or PerlIO for obvious reasons,
5418 * so we'll use stdio and low-level IO instead. */
5419 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5420 # ifdef PERL_MEM_LOG_TIMESTAMP
5422 gettimeofday(&tv, 0);
5428 # ifdef PERL_MEM_LOG_TIMESTAMP
5431 "free: %s:%d:%s: %"UVxf"\n",
5432 # ifdef PERL_MEM_LOG_TIMESTAMP
5433 (int)tv.tv_sec, (int)tv.tv_usec,
5435 filename, linenumber, funcname,
5437 # ifdef PERL_MEM_LOG_ENV_FD
5438 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5439 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5441 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5449 #endif /* PERL_MEM_LOG */
5452 =for apidoc my_sprintf
5454 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5455 the length of the string written to the buffer. Only rare pre-ANSI systems
5456 need the wrapper function - usually this is a direct call to C<sprintf>.
5460 #ifndef SPRINTF_RETURNS_STRLEN
5462 Perl_my_sprintf(char *buffer, const char* pat, ...)
5465 va_start(args, pat);
5466 vsprintf(buffer, pat, args);
5468 return strlen(buffer);
5473 =for apidoc my_snprintf
5475 The C library C<snprintf> functionality, if available and
5476 standards-compliant (uses C<vsnprintf>, actually). However, if the
5477 C<vsnprintf> is not available, will unfortunately use the unsafe
5478 C<vsprintf> which can overrun the buffer (there is an overrun check,
5479 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5480 getting C<vsnprintf>.
5485 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5490 va_start(ap, format);
5491 #ifdef HAS_VSNPRINTF
5492 retval = vsnprintf(buffer, len, format, ap);
5494 retval = vsprintf(buffer, format, ap);
5497 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5498 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5499 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5504 =for apidoc my_vsnprintf
5506 The C library C<vsnprintf> if available and standards-compliant.
5507 However, if if the C<vsnprintf> is not available, will unfortunately
5508 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5509 overrun check, but that may be too late). Consider using
5510 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5515 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5521 Perl_va_copy(ap, apc);
5522 # ifdef HAS_VSNPRINTF
5523 retval = vsnprintf(buffer, len, format, apc);
5525 retval = vsprintf(buffer, format, apc);
5528 # ifdef HAS_VSNPRINTF
5529 retval = vsnprintf(buffer, len, format, ap);
5531 retval = vsprintf(buffer, format, ap);
5533 #endif /* #ifdef NEED_VA_COPY */
5534 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5535 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5536 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5541 Perl_my_clearenv(pTHX)
5544 #if ! defined(PERL_MICRO)
5545 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5547 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5548 # if defined(USE_ENVIRON_ARRAY)
5549 # if defined(USE_ITHREADS)
5550 /* only the parent thread can clobber the process environment */
5551 if (PL_curinterp == aTHX)
5552 # endif /* USE_ITHREADS */
5554 # if ! defined(PERL_USE_SAFE_PUTENV)
5555 if ( !PL_use_safe_putenv) {
5557 if (environ == PL_origenviron)
5558 environ = (char**)safesysmalloc(sizeof(char*));
5560 for (i = 0; environ[i]; i++)
5561 (void)safesysfree(environ[i]);
5564 # else /* PERL_USE_SAFE_PUTENV */
5565 # if defined(HAS_CLEARENV)
5567 # elif defined(HAS_UNSETENV)
5568 int bsiz = 80; /* Most envvar names will be shorter than this. */
5569 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5570 char *buf = (char*)safesysmalloc(bufsiz);
5571 while (*environ != NULL) {
5572 char *e = strchr(*environ, '=');
5573 int l = e ? e - *environ : (int)strlen(*environ);
5575 (void)safesysfree(buf);
5576 bsiz = l + 1; /* + 1 for the \0. */
5577 buf = (char*)safesysmalloc(bufsiz);
5579 my_strlcpy(buf, *environ, l + 1);
5580 (void)unsetenv(buf);
5582 (void)safesysfree(buf);
5583 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5584 /* Just null environ and accept the leakage. */
5586 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5587 # endif /* ! PERL_USE_SAFE_PUTENV */
5589 # endif /* USE_ENVIRON_ARRAY */
5590 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5591 #endif /* PERL_MICRO */
5594 #ifdef PERL_IMPLICIT_CONTEXT
5596 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5597 the global PL_my_cxt_index is incremented, and that value is assigned to
5598 that module's static my_cxt_index (who's address is passed as an arg).
5599 Then, for each interpreter this function is called for, it makes sure a
5600 void* slot is available to hang the static data off, by allocating or
5601 extending the interpreter's PL_my_cxt_list array */
5603 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5605 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5610 /* this module hasn't been allocated an index yet */
5611 MUTEX_LOCK(&PL_my_ctx_mutex);
5612 *index = PL_my_cxt_index++;
5613 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5616 /* make sure the array is big enough */
5617 if (PL_my_cxt_size <= *index) {
5618 if (PL_my_cxt_size) {
5619 while (PL_my_cxt_size <= *index)
5620 PL_my_cxt_size *= 2;
5621 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5624 PL_my_cxt_size = 16;
5625 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5628 /* newSV() allocates one more than needed */
5629 p = (void*)SvPVX(newSV(size-1));
5630 PL_my_cxt_list[*index] = p;
5631 Zero(p, size, char);
5635 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5638 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5643 for (index = 0; index < PL_my_cxt_index; index++) {
5644 const char *key = PL_my_cxt_keys[index];
5645 /* try direct pointer compare first - there are chances to success,
5646 * and it's much faster.
5648 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5655 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5661 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5663 /* this module hasn't been allocated an index yet */
5664 MUTEX_LOCK(&PL_my_ctx_mutex);
5665 index = PL_my_cxt_index++;
5666 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5669 /* make sure the array is big enough */
5670 if (PL_my_cxt_size <= index) {
5671 int old_size = PL_my_cxt_size;
5673 if (PL_my_cxt_size) {
5674 while (PL_my_cxt_size <= index)
5675 PL_my_cxt_size *= 2;
5676 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5677 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5680 PL_my_cxt_size = 16;
5681 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5682 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5684 for (i = old_size; i < PL_my_cxt_size; i++) {
5685 PL_my_cxt_keys[i] = 0;
5686 PL_my_cxt_list[i] = 0;
5689 PL_my_cxt_keys[index] = my_cxt_key;
5690 /* newSV() allocates one more than needed */
5691 p = (void*)SvPVX(newSV(size-1));
5692 PL_my_cxt_list[index] = p;
5693 Zero(p, size, char);
5696 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5697 #endif /* PERL_IMPLICIT_CONTEXT */
5701 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5703 Size_t used, length, copy;
5706 length = strlen(src);
5707 if (size > 0 && used < size - 1) {
5708 copy = (length >= size - used) ? size - used - 1 : length;
5709 memcpy(dst + used, src, copy);
5710 dst[used + copy] = '\0';
5712 return used + length;
5718 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5720 Size_t length, copy;
5722 length = strlen(src);
5724 copy = (length >= size) ? size - 1 : length;
5725 memcpy(dst, src, copy);
5732 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5733 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5734 long _ftol( double ); /* Defined by VC6 C libs. */
5735 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5739 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5742 SV * const dbsv = GvSVn(PL_DBsub);
5743 /* We do not care about using sv to call CV;
5744 * it's for informational purposes only.
5748 if (!PERLDB_SUB_NN) {
5749 GV * const gv = CvGV(cv);
5751 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5752 || strEQ(GvNAME(gv), "END")
5753 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5754 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5755 /* Use GV from the stack as a fallback. */
5756 /* GV is potentially non-unique, or contain different CV. */
5757 SV * const tmp = newRV((SV*)cv);
5758 sv_setsv(dbsv, tmp);
5762 gv_efullname3(dbsv, gv, NULL);
5766 const int type = SvTYPE(dbsv);
5767 if (type < SVt_PVIV && type != SVt_IV)
5768 sv_upgrade(dbsv, SVt_PVIV);
5769 (void)SvIOK_on(dbsv);
5770 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5776 * c-indentation-style: bsd
5778 * indent-tabs-mode: t
5781 * ex: set ts=8 sts=4 sw=4 noet: