3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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)
263 if (size * count > 0xffff) {
264 PerlIO_printf(Perl_error_log,
265 "Allocation too large: %lx\n", size * count) FLUSH;
268 #endif /* HAS_64K_LIMIT */
270 if ((long)size < 0 || (long)count < 0)
271 Perl_croak_nocontext("panic: calloc");
274 #ifdef PERL_TRACK_MEMPOOL
277 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
278 PERL_ALLOC_CHECK(ptr);
279 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
281 memset((void*)ptr, 0, size);
282 #ifdef PERL_TRACK_MEMPOOL
284 struct perl_memory_debug_header *const header
285 = (struct perl_memory_debug_header *)ptr;
287 header->interpreter = aTHX;
288 /* Link us into the list. */
289 header->prev = &PL_memory_debug_header;
290 header->next = PL_memory_debug_header.next;
291 PL_memory_debug_header.next = header;
292 header->next->prev = header;
296 ptr = (Malloc_t)((char*)ptr+sTHX);
303 return write_no_mem();
306 /* These must be defined when not using Perl's malloc for binary
311 Malloc_t Perl_malloc (MEM_SIZE nbytes)
314 return (Malloc_t)PerlMem_malloc(nbytes);
317 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
320 return (Malloc_t)PerlMem_calloc(elements, size);
323 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
326 return (Malloc_t)PerlMem_realloc(where, nbytes);
329 Free_t Perl_mfree (Malloc_t where)
337 /* copy a string up to some (non-backslashed) delimiter, if any */
340 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
345 for (tolen = 0; from < fromend; from++, tolen++) {
347 if (from[1] != delim) {
354 else if (*from == delim)
365 /* return ptr to little string in big string, NULL if not found */
366 /* This routine was donated by Corey Satten. */
369 Perl_instr(pTHX_ register const char *big, register const char *little)
380 register const char *s, *x;
383 for (x=big,s=little; *s; /**/ ) {
394 return (char*)(big-1);
399 /* same as instr but allow embedded nulls */
402 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
408 char first = *little++;
410 bigend -= lend - little;
412 while (big <= bigend) {
415 for (x=big,s=little; s < lend; x++,s++) {
419 return (char*)(big-1);
425 /* reverse of the above--find last substring */
428 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
430 register const char *bigbeg;
431 register const I32 first = *little;
432 register const char * const littleend = lend;
435 if (little >= littleend)
436 return (char*)bigend;
438 big = bigend - (littleend - little++);
439 while (big >= bigbeg) {
440 register const char *s, *x;
443 for (x=big+2,s=little; s < littleend; /**/ ) {
452 return (char*)(big+1);
457 /* As a space optimization, we do not compile tables for strings of length
458 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
459 special-cased in fbm_instr().
461 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
464 =head1 Miscellaneous Functions
466 =for apidoc fbm_compile
468 Analyses the string in order to make fast searches on it using fbm_instr()
469 -- the Boyer-Moore algorithm.
475 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
478 register const U8 *s;
484 if (flags & FBMcf_TAIL) {
485 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
486 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
487 if (mg && mg->mg_len >= 0)
490 s = (U8*)SvPV_force_mutable(sv, len);
491 if (len == 0) /* TAIL might be on a zero-length string. */
493 SvUPGRADE(sv, SVt_PVBM);
496 const unsigned char *sb;
497 const U8 mlen = (len>255) ? 255 : (U8)len;
500 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
502 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
503 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
504 memset((void*)table, mlen, 256);
505 table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] = (U8)flags;
507 sb = s - mlen + 1; /* first char (maybe) */
509 if (table[*s] == mlen)
514 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
517 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
518 for (i = 0; i < len; i++) {
519 if (PL_freq[s[i]] < frequency) {
521 frequency = PL_freq[s[i]];
524 BmRARE(sv) = s[rarest];
525 BmPREVIOUS(sv) = (U16)rarest;
526 BmUSEFUL(sv) = 100; /* Initial value */
527 if (flags & FBMcf_TAIL)
529 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
530 BmRARE(sv),BmPREVIOUS(sv)));
533 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
534 /* If SvTAIL is actually due to \Z or \z, this gives false positives
538 =for apidoc fbm_instr
540 Returns the location of the SV in the string delimited by C<str> and
541 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
542 does not have to be fbm_compiled, but the search will not be as fast
549 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
551 register unsigned char *s;
553 register const unsigned char *little
554 = (const unsigned char *)SvPV_const(littlestr,l);
555 register STRLEN littlelen = l;
556 register const I32 multiline = flags & FBMrf_MULTILINE;
558 if ((STRLEN)(bigend - big) < littlelen) {
559 if ( SvTAIL(littlestr)
560 && ((STRLEN)(bigend - big) == littlelen - 1)
562 || (*big == *little &&
563 memEQ((char *)big, (char *)little, littlelen - 1))))
568 if (littlelen <= 2) { /* Special-cased */
570 if (littlelen == 1) {
571 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
572 /* Know that bigend != big. */
573 if (bigend[-1] == '\n')
574 return (char *)(bigend - 1);
575 return (char *) bigend;
583 if (SvTAIL(littlestr))
584 return (char *) bigend;
588 return (char*)big; /* Cannot be SvTAIL! */
591 if (SvTAIL(littlestr) && !multiline) {
592 if (bigend[-1] == '\n' && bigend[-2] == *little)
593 return (char*)bigend - 2;
594 if (bigend[-1] == *little)
595 return (char*)bigend - 1;
599 /* This should be better than FBM if c1 == c2, and almost
600 as good otherwise: maybe better since we do less indirection.
601 And we save a lot of memory by caching no table. */
602 const unsigned char c1 = little[0];
603 const unsigned char c2 = little[1];
608 while (s <= bigend) {
618 goto check_1char_anchor;
629 goto check_1char_anchor;
632 while (s <= bigend) {
637 goto check_1char_anchor;
646 check_1char_anchor: /* One char and anchor! */
647 if (SvTAIL(littlestr) && (*bigend == *little))
648 return (char *)bigend; /* bigend is already decremented. */
651 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
652 s = bigend - littlelen;
653 if (s >= big && bigend[-1] == '\n' && *s == *little
654 /* Automatically of length > 2 */
655 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
657 return (char*)s; /* how sweet it is */
660 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
662 return (char*)s + 1; /* how sweet it is */
666 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
667 char * const b = ninstr((char*)big,(char*)bigend,
668 (char*)little, (char*)little + littlelen);
670 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
671 /* Chop \n from littlestr: */
672 s = bigend - littlelen + 1;
674 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
684 if (littlelen > (STRLEN)(bigend - big))
688 register const unsigned char * const table
689 = little + littlelen + PERL_FBM_TABLE_OFFSET;
690 register const unsigned char *oldlittle;
692 --littlelen; /* Last char found by table lookup */
695 little += littlelen; /* last char */
701 if ((tmp = table[*s])) {
702 if ((s += tmp) < bigend)
706 else { /* less expensive than calling strncmp() */
707 register unsigned char * const olds = s;
712 if (*--s == *--little)
714 s = olds + 1; /* here we pay the price for failure */
716 if (s < bigend) /* fake up continue to outer loop */
725 && (table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] & FBMcf_TAIL)
726 && memEQ((char *)(bigend - littlelen),
727 (char *)(oldlittle - littlelen), littlelen) )
728 return (char*)bigend - littlelen;
733 /* start_shift, end_shift are positive quantities which give offsets
734 of ends of some substring of bigstr.
735 If "last" we want the last occurrence.
736 old_posp is the way of communication between consequent calls if
737 the next call needs to find the .
738 The initial *old_posp should be -1.
740 Note that we take into account SvTAIL, so one can get extra
741 optimizations if _ALL flag is set.
744 /* If SvTAIL is actually due to \Z or \z, this gives false positives
745 if PL_multiline. In fact if !PL_multiline the authoritative answer
746 is not supported yet. */
749 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
752 register const unsigned char *big;
754 register I32 previous;
756 register const unsigned char *little;
757 register I32 stop_pos;
758 register const unsigned char *littleend;
761 assert(SvTYPE(littlestr) == SVt_PVBM);
764 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
765 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
767 if ( BmRARE(littlestr) == '\n'
768 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
769 little = (const unsigned char *)(SvPVX_const(littlestr));
770 littleend = little + SvCUR(littlestr);
777 little = (const unsigned char *)(SvPVX_const(littlestr));
778 littleend = little + SvCUR(littlestr);
780 /* The value of pos we can start at: */
781 previous = BmPREVIOUS(littlestr);
782 big = (const unsigned char *)(SvPVX_const(bigstr));
783 /* The value of pos we can stop at: */
784 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
785 if (previous + start_shift > stop_pos) {
787 stop_pos does not include SvTAIL in the count, so this check is incorrect
788 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
791 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
796 while (pos < previous + start_shift) {
797 if (!(pos += PL_screamnext[pos]))
802 register const unsigned char *s, *x;
803 if (pos >= stop_pos) break;
804 if (big[pos] != first)
806 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
812 if (s == littleend) {
814 if (!last) return (char *)(big+pos);
817 } while ( pos += PL_screamnext[pos] );
819 return (char *)(big+(*old_posp));
821 if (!SvTAIL(littlestr) || (end_shift > 0))
823 /* Ignore the trailing "\n". This code is not microoptimized */
824 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
825 stop_pos = littleend - little; /* Actual littlestr len */
830 && ((stop_pos == 1) ||
831 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
837 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
839 register const U8 *a = (const U8 *)s1;
840 register const U8 *b = (const U8 *)s2;
844 if (*a != *b && *a != PL_fold[*b])
852 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
855 register const U8 *a = (const U8 *)s1;
856 register const U8 *b = (const U8 *)s2;
860 if (*a != *b && *a != PL_fold_locale[*b])
867 /* copy a string to a safe spot */
870 =head1 Memory Management
874 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
875 string which is a duplicate of C<pv>. The size of the string is
876 determined by C<strlen()>. The memory allocated for the new string can
877 be freed with the C<Safefree()> function.
883 Perl_savepv(pTHX_ const char *pv)
890 const STRLEN pvlen = strlen(pv)+1;
891 Newx(newaddr, pvlen, char);
892 return (char*)memcpy(newaddr, pv, pvlen);
896 /* same thing but with a known length */
901 Perl's version of what C<strndup()> would be if it existed. Returns a
902 pointer to a newly allocated string which is a duplicate of the first
903 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
904 the new string can be freed with the C<Safefree()> function.
910 Perl_savepvn(pTHX_ const char *pv, register I32 len)
912 register char *newaddr;
915 Newx(newaddr,len+1,char);
916 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
918 /* might not be null terminated */
920 return (char *) CopyD(pv,newaddr,len,char);
923 return (char *) ZeroD(newaddr,len+1,char);
928 =for apidoc savesharedpv
930 A version of C<savepv()> which allocates the duplicate string in memory
931 which is shared between threads.
936 Perl_savesharedpv(pTHX_ const char *pv)
938 register char *newaddr;
943 pvlen = strlen(pv)+1;
944 newaddr = (char*)PerlMemShared_malloc(pvlen);
946 return write_no_mem();
948 return (char*)memcpy(newaddr, pv, pvlen);
954 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
955 the passed in SV using C<SvPV()>
961 Perl_savesvpv(pTHX_ SV *sv)
964 const char * const pv = SvPV_const(sv, len);
965 register char *newaddr;
968 Newx(newaddr,len,char);
969 return (char *) CopyD(pv,newaddr,len,char);
973 /* the SV for Perl_form() and mess() is not kept in an arena */
983 return sv_2mortal(newSVpvs(""));
988 /* Create as PVMG now, to avoid any upgrading later */
990 Newxz(any, 1, XPVMG);
991 SvFLAGS(sv) = SVt_PVMG;
992 SvANY(sv) = (void*)any;
994 SvREFCNT(sv) = 1 << 30; /* practically infinite */
999 #if defined(PERL_IMPLICIT_CONTEXT)
1001 Perl_form_nocontext(const char* pat, ...)
1006 va_start(args, pat);
1007 retval = vform(pat, &args);
1011 #endif /* PERL_IMPLICIT_CONTEXT */
1014 =head1 Miscellaneous Functions
1017 Takes a sprintf-style format pattern and conventional
1018 (non-SV) arguments and returns the formatted string.
1020 (char *) Perl_form(pTHX_ const char* pat, ...)
1022 can be used any place a string (char *) is required:
1024 char * s = Perl_form("%d.%d",major,minor);
1026 Uses a single private buffer so if you want to format several strings you
1027 must explicitly copy the earlier strings away (and free the copies when you
1034 Perl_form(pTHX_ const char* pat, ...)
1038 va_start(args, pat);
1039 retval = vform(pat, &args);
1045 Perl_vform(pTHX_ const char *pat, va_list *args)
1047 SV * const sv = mess_alloc();
1048 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1052 #if defined(PERL_IMPLICIT_CONTEXT)
1054 Perl_mess_nocontext(const char *pat, ...)
1059 va_start(args, pat);
1060 retval = vmess(pat, &args);
1064 #endif /* PERL_IMPLICIT_CONTEXT */
1067 Perl_mess(pTHX_ const char *pat, ...)
1071 va_start(args, pat);
1072 retval = vmess(pat, &args);
1078 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1081 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1083 if (!o || o == PL_op)
1086 if (o->op_flags & OPf_KIDS) {
1088 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1091 /* If the OP_NEXTSTATE has been optimised away we can still use it
1092 * the get the file and line number. */
1094 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1095 cop = (const COP *)kid;
1097 /* Keep searching, and return when we've found something. */
1099 new_cop = closest_cop(cop, kid);
1105 /* Nothing found. */
1111 Perl_vmess(pTHX_ const char *pat, va_list *args)
1114 SV * const sv = mess_alloc();
1116 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1117 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1119 * Try and find the file and line for PL_op. This will usually be
1120 * PL_curcop, but it might be a cop that has been optimised away. We
1121 * can try to find such a cop by searching through the optree starting
1122 * from the sibling of PL_curcop.
1125 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1130 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1131 OutCopFILE(cop), (IV)CopLINE(cop));
1132 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1133 const bool line_mode = (RsSIMPLE(PL_rs) &&
1134 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1135 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1136 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1137 line_mode ? "line" : "chunk",
1138 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1141 sv_catpvs(sv, " during global destruction");
1142 sv_catpvs(sv, ".\n");
1148 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1154 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1155 && (io = GvIO(PL_stderrgv))
1156 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1163 SAVESPTR(PL_stderrgv);
1166 PUSHSTACKi(PERLSI_MAGIC);
1170 PUSHs(SvTIED_obj((SV*)io, mg));
1171 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1173 call_method("PRINT", G_SCALAR);
1181 /* SFIO can really mess with your errno */
1182 const int e = errno;
1184 PerlIO * const serr = Perl_error_log;
1186 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1187 (void)PerlIO_flush(serr);
1194 /* Common code used by vcroak, vdie, vwarn and vwarner */
1197 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
1203 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1204 /* sv_2cv might call Perl_croak() or Perl_warner() */
1205 SV * const oldhook = *hook;
1212 cv = sv_2cv(oldhook, &stash, &gv, 0);
1214 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1224 if (warn || message) {
1225 msg = newSVpvn(message, msglen);
1226 SvFLAGS(msg) |= utf8;
1234 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1238 call_sv((SV*)cv, G_DISCARD);
1247 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1251 const char *message;
1254 SV * const msv = vmess(pat, args);
1255 if (PL_errors && SvCUR(PL_errors)) {
1256 sv_catsv(PL_errors, msv);
1257 message = SvPV_const(PL_errors, *msglen);
1258 SvCUR_set(PL_errors, 0);
1261 message = SvPV_const(msv,*msglen);
1262 *utf8 = SvUTF8(msv);
1268 DEBUG_S(PerlIO_printf(Perl_debug_log,
1269 "%p: die/croak: message = %s\ndiehook = %p\n",
1270 thr, message, PL_diehook));
1272 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1278 Perl_vdie(pTHX_ const char* pat, va_list *args)
1281 const char *message;
1282 const int was_in_eval = PL_in_eval;
1286 DEBUG_S(PerlIO_printf(Perl_debug_log,
1287 "%p: die: curstack = %p, mainstack = %p\n",
1288 thr, PL_curstack, PL_mainstack));
1290 message = vdie_croak_common(pat, args, &msglen, &utf8);
1292 PL_restartop = die_where(message, msglen);
1293 SvFLAGS(ERRSV) |= utf8;
1294 DEBUG_S(PerlIO_printf(Perl_debug_log,
1295 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1296 thr, PL_restartop, was_in_eval, PL_top_env));
1297 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1299 return PL_restartop;
1302 #if defined(PERL_IMPLICIT_CONTEXT)
1304 Perl_die_nocontext(const char* pat, ...)
1309 va_start(args, pat);
1310 o = vdie(pat, &args);
1314 #endif /* PERL_IMPLICIT_CONTEXT */
1317 Perl_die(pTHX_ const char* pat, ...)
1321 va_start(args, pat);
1322 o = vdie(pat, &args);
1328 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1331 const char *message;
1335 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1338 PL_restartop = die_where(message, msglen);
1339 SvFLAGS(ERRSV) |= utf8;
1343 message = SvPVx_const(ERRSV, msglen);
1345 write_to_stderr(message, msglen);
1349 #if defined(PERL_IMPLICIT_CONTEXT)
1351 Perl_croak_nocontext(const char *pat, ...)
1355 va_start(args, pat);
1360 #endif /* PERL_IMPLICIT_CONTEXT */
1363 =head1 Warning and Dieing
1367 This is the XSUB-writer's interface to Perl's C<die> function.
1368 Normally call this function the same way you call the C C<printf>
1369 function. Calling C<croak> returns control directly to Perl,
1370 sidestepping the normal C order of execution. See C<warn>.
1372 If you want to throw an exception object, assign the object to
1373 C<$@> and then pass C<NULL> to croak():
1375 errsv = get_sv("@", TRUE);
1376 sv_setsv(errsv, exception_object);
1383 Perl_croak(pTHX_ const char *pat, ...)
1386 va_start(args, pat);
1393 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1397 SV * const msv = vmess(pat, args);
1398 const I32 utf8 = SvUTF8(msv);
1399 const char * const message = SvPV_const(msv, msglen);
1402 if (vdie_common(message, msglen, utf8, TRUE))
1406 write_to_stderr(message, msglen);
1409 #if defined(PERL_IMPLICIT_CONTEXT)
1411 Perl_warn_nocontext(const char *pat, ...)
1415 va_start(args, pat);
1419 #endif /* PERL_IMPLICIT_CONTEXT */
1424 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1425 function the same way you call the C C<printf> function. See C<croak>.
1431 Perl_warn(pTHX_ const char *pat, ...)
1434 va_start(args, pat);
1439 #if defined(PERL_IMPLICIT_CONTEXT)
1441 Perl_warner_nocontext(U32 err, const char *pat, ...)
1445 va_start(args, pat);
1446 vwarner(err, pat, &args);
1449 #endif /* PERL_IMPLICIT_CONTEXT */
1452 Perl_warner(pTHX_ U32 err, const char* pat,...)
1455 va_start(args, pat);
1456 vwarner(err, pat, &args);
1461 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1464 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1465 SV * const msv = vmess(pat, args);
1467 const char * const message = SvPV_const(msv, msglen);
1468 const I32 utf8 = SvUTF8(msv);
1472 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1475 PL_restartop = die_where(message, msglen);
1476 SvFLAGS(ERRSV) |= utf8;
1479 write_to_stderr(message, msglen);
1483 Perl_vwarn(aTHX_ pat, args);
1487 /* implements the ckWARN? macros */
1490 Perl_ckwarn(pTHX_ U32 w)
1496 && PL_curcop->cop_warnings != pWARN_NONE
1498 PL_curcop->cop_warnings == pWARN_ALL
1499 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1500 || (unpackWARN2(w) &&
1501 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1502 || (unpackWARN3(w) &&
1503 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1504 || (unpackWARN4(w) &&
1505 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1510 isLEXWARN_off && PL_dowarn & G_WARN_ON
1515 /* implements the ckWARN?_d macro */
1518 Perl_ckwarn_d(pTHX_ U32 w)
1523 || PL_curcop->cop_warnings == pWARN_ALL
1525 PL_curcop->cop_warnings != pWARN_NONE
1527 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1528 || (unpackWARN2(w) &&
1529 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1530 || (unpackWARN3(w) &&
1531 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1532 || (unpackWARN4(w) &&
1533 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1539 /* Set buffer=NULL to get a new one. */
1541 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1543 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1544 PERL_UNUSED_CONTEXT;
1547 (specialWARN(buffer) ?
1548 PerlMemShared_malloc(len_wanted) :
1549 PerlMemShared_realloc(buffer, len_wanted));
1551 Copy(bits, (buffer + 1), size, char);
1555 /* since we've already done strlen() for both nam and val
1556 * we can use that info to make things faster than
1557 * sprintf(s, "%s=%s", nam, val)
1559 #define my_setenv_format(s, nam, nlen, val, vlen) \
1560 Copy(nam, s, nlen, char); \
1562 Copy(val, s+(nlen+1), vlen, char); \
1563 *(s+(nlen+1+vlen)) = '\0'
1565 #ifdef USE_ENVIRON_ARRAY
1566 /* VMS' my_setenv() is in vms.c */
1567 #if !defined(WIN32) && !defined(NETWARE)
1569 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1573 /* only parent thread can modify process environment */
1574 if (PL_curinterp == aTHX)
1577 #ifndef PERL_USE_SAFE_PUTENV
1578 if (!PL_use_safe_putenv) {
1579 /* most putenv()s leak, so we manipulate environ directly */
1580 register I32 i=setenv_getix(nam); /* where does it go? */
1583 if (environ == PL_origenviron) { /* need we copy environment? */
1589 while (environ[max])
1591 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1592 for (j=0; j<max; j++) { /* copy environment */
1593 const int len = strlen(environ[j]);
1594 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1595 Copy(environ[j], tmpenv[j], len+1, char);
1598 environ = tmpenv; /* tell exec where it is now */
1601 safesysfree(environ[i]);
1602 while (environ[i]) {
1603 environ[i] = environ[i+1];
1608 if (!environ[i]) { /* does not exist yet */
1609 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1610 environ[i+1] = NULL; /* make sure it's null terminated */
1613 safesysfree(environ[i]);
1617 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1618 /* all that work just for this */
1619 my_setenv_format(environ[i], nam, nlen, val, vlen);
1622 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1623 # if defined(HAS_UNSETENV)
1625 (void)unsetenv(nam);
1627 (void)setenv(nam, val, 1);
1629 # else /* ! HAS_UNSETENV */
1630 (void)setenv(nam, val, 1);
1631 # endif /* HAS_UNSETENV */
1633 # if defined(HAS_UNSETENV)
1635 (void)unsetenv(nam);
1637 const int nlen = strlen(nam);
1638 const int vlen = strlen(val);
1639 char * const new_env =
1640 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1641 my_setenv_format(new_env, nam, nlen, val, vlen);
1642 (void)putenv(new_env);
1644 # else /* ! HAS_UNSETENV */
1646 const int nlen = strlen(nam);
1652 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1653 /* all that work just for this */
1654 my_setenv_format(new_env, nam, nlen, val, vlen);
1655 (void)putenv(new_env);
1656 # endif /* HAS_UNSETENV */
1657 # endif /* __CYGWIN__ */
1658 #ifndef PERL_USE_SAFE_PUTENV
1664 #else /* WIN32 || NETWARE */
1667 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1670 register char *envstr;
1671 const int nlen = strlen(nam);
1678 Newx(envstr, nlen+vlen+2, char);
1679 my_setenv_format(envstr, nam, nlen, val, vlen);
1680 (void)PerlEnv_putenv(envstr);
1684 #endif /* WIN32 || NETWARE */
1688 Perl_setenv_getix(pTHX_ const char *nam)
1691 register const I32 len = strlen(nam);
1692 PERL_UNUSED_CONTEXT;
1694 for (i = 0; environ[i]; i++) {
1697 strnicmp(environ[i],nam,len) == 0
1699 strnEQ(environ[i],nam,len)
1701 && environ[i][len] == '=')
1702 break; /* strnEQ must come first to avoid */
1703 } /* potential SEGV's */
1706 #endif /* !PERL_MICRO */
1708 #endif /* !VMS && !EPOC*/
1710 #ifdef UNLINK_ALL_VERSIONS
1712 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1716 while (PerlLIO_unlink(f) >= 0)
1718 return retries ? 0 : -1;
1722 /* this is a drop-in replacement for bcopy() */
1723 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1725 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1727 char * const retval = to;
1729 if (from - to >= 0) {
1737 *(--to) = *(--from);
1743 /* this is a drop-in replacement for memset() */
1746 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1748 char * const retval = loc;
1756 /* this is a drop-in replacement for bzero() */
1757 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1759 Perl_my_bzero(register char *loc, register I32 len)
1761 char * const retval = loc;
1769 /* this is a drop-in replacement for memcmp() */
1770 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1772 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1774 register const U8 *a = (const U8 *)s1;
1775 register const U8 *b = (const U8 *)s2;
1779 if ((tmp = *a++ - *b++))
1784 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1788 #ifdef USE_CHAR_VSPRINTF
1793 vsprintf(char *dest, const char *pat, char *args)
1797 fakebuf._ptr = dest;
1798 fakebuf._cnt = 32767;
1802 fakebuf._flag = _IOWRT|_IOSTRG;
1803 _doprnt(pat, args, &fakebuf); /* what a kludge */
1804 (void)putc('\0', &fakebuf);
1805 #ifdef USE_CHAR_VSPRINTF
1808 return 0; /* perl doesn't use return value */
1812 #endif /* HAS_VPRINTF */
1815 #if BYTEORDER != 0x4321
1817 Perl_my_swap(pTHX_ short s)
1819 #if (BYTEORDER & 1) == 0
1822 result = ((s & 255) << 8) + ((s >> 8) & 255);
1830 Perl_my_htonl(pTHX_ long l)
1834 char c[sizeof(long)];
1837 #if BYTEORDER == 0x1234
1838 u.c[0] = (l >> 24) & 255;
1839 u.c[1] = (l >> 16) & 255;
1840 u.c[2] = (l >> 8) & 255;
1844 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1845 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1850 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1851 u.c[o & 0xf] = (l >> s) & 255;
1859 Perl_my_ntohl(pTHX_ long l)
1863 char c[sizeof(long)];
1866 #if BYTEORDER == 0x1234
1867 u.c[0] = (l >> 24) & 255;
1868 u.c[1] = (l >> 16) & 255;
1869 u.c[2] = (l >> 8) & 255;
1873 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1874 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1881 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1882 l |= (u.c[o & 0xf] & 255) << s;
1889 #endif /* BYTEORDER != 0x4321 */
1893 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1894 * If these functions are defined,
1895 * the BYTEORDER is neither 0x1234 nor 0x4321.
1896 * However, this is not assumed.
1900 #define HTOLE(name,type) \
1902 name (register type n) \
1906 char c[sizeof(type)]; \
1909 register U32 s = 0; \
1910 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1911 u.c[i] = (n >> s) & 0xFF; \
1916 #define LETOH(name,type) \
1918 name (register type n) \
1922 char c[sizeof(type)]; \
1925 register U32 s = 0; \
1928 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1929 n |= ((type)(u.c[i] & 0xFF)) << s; \
1935 * Big-endian byte order functions.
1938 #define HTOBE(name,type) \
1940 name (register type n) \
1944 char c[sizeof(type)]; \
1947 register U32 s = 8*(sizeof(u.c)-1); \
1948 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1949 u.c[i] = (n >> s) & 0xFF; \
1954 #define BETOH(name,type) \
1956 name (register type n) \
1960 char c[sizeof(type)]; \
1963 register U32 s = 8*(sizeof(u.c)-1); \
1966 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1967 n |= ((type)(u.c[i] & 0xFF)) << s; \
1973 * If we just can't do it...
1976 #define NOT_AVAIL(name,type) \
1978 name (register type n) \
1980 Perl_croak_nocontext(#name "() not available"); \
1981 return n; /* not reached */ \
1985 #if defined(HAS_HTOVS) && !defined(htovs)
1988 #if defined(HAS_HTOVL) && !defined(htovl)
1991 #if defined(HAS_VTOHS) && !defined(vtohs)
1994 #if defined(HAS_VTOHL) && !defined(vtohl)
1998 #ifdef PERL_NEED_MY_HTOLE16
2000 HTOLE(Perl_my_htole16,U16)
2002 NOT_AVAIL(Perl_my_htole16,U16)
2005 #ifdef PERL_NEED_MY_LETOH16
2007 LETOH(Perl_my_letoh16,U16)
2009 NOT_AVAIL(Perl_my_letoh16,U16)
2012 #ifdef PERL_NEED_MY_HTOBE16
2014 HTOBE(Perl_my_htobe16,U16)
2016 NOT_AVAIL(Perl_my_htobe16,U16)
2019 #ifdef PERL_NEED_MY_BETOH16
2021 BETOH(Perl_my_betoh16,U16)
2023 NOT_AVAIL(Perl_my_betoh16,U16)
2027 #ifdef PERL_NEED_MY_HTOLE32
2029 HTOLE(Perl_my_htole32,U32)
2031 NOT_AVAIL(Perl_my_htole32,U32)
2034 #ifdef PERL_NEED_MY_LETOH32
2036 LETOH(Perl_my_letoh32,U32)
2038 NOT_AVAIL(Perl_my_letoh32,U32)
2041 #ifdef PERL_NEED_MY_HTOBE32
2043 HTOBE(Perl_my_htobe32,U32)
2045 NOT_AVAIL(Perl_my_htobe32,U32)
2048 #ifdef PERL_NEED_MY_BETOH32
2050 BETOH(Perl_my_betoh32,U32)
2052 NOT_AVAIL(Perl_my_betoh32,U32)
2056 #ifdef PERL_NEED_MY_HTOLE64
2058 HTOLE(Perl_my_htole64,U64)
2060 NOT_AVAIL(Perl_my_htole64,U64)
2063 #ifdef PERL_NEED_MY_LETOH64
2065 LETOH(Perl_my_letoh64,U64)
2067 NOT_AVAIL(Perl_my_letoh64,U64)
2070 #ifdef PERL_NEED_MY_HTOBE64
2072 HTOBE(Perl_my_htobe64,U64)
2074 NOT_AVAIL(Perl_my_htobe64,U64)
2077 #ifdef PERL_NEED_MY_BETOH64
2079 BETOH(Perl_my_betoh64,U64)
2081 NOT_AVAIL(Perl_my_betoh64,U64)
2085 #ifdef PERL_NEED_MY_HTOLES
2086 HTOLE(Perl_my_htoles,short)
2088 #ifdef PERL_NEED_MY_LETOHS
2089 LETOH(Perl_my_letohs,short)
2091 #ifdef PERL_NEED_MY_HTOBES
2092 HTOBE(Perl_my_htobes,short)
2094 #ifdef PERL_NEED_MY_BETOHS
2095 BETOH(Perl_my_betohs,short)
2098 #ifdef PERL_NEED_MY_HTOLEI
2099 HTOLE(Perl_my_htolei,int)
2101 #ifdef PERL_NEED_MY_LETOHI
2102 LETOH(Perl_my_letohi,int)
2104 #ifdef PERL_NEED_MY_HTOBEI
2105 HTOBE(Perl_my_htobei,int)
2107 #ifdef PERL_NEED_MY_BETOHI
2108 BETOH(Perl_my_betohi,int)
2111 #ifdef PERL_NEED_MY_HTOLEL
2112 HTOLE(Perl_my_htolel,long)
2114 #ifdef PERL_NEED_MY_LETOHL
2115 LETOH(Perl_my_letohl,long)
2117 #ifdef PERL_NEED_MY_HTOBEL
2118 HTOBE(Perl_my_htobel,long)
2120 #ifdef PERL_NEED_MY_BETOHL
2121 BETOH(Perl_my_betohl,long)
2125 Perl_my_swabn(void *ptr, int n)
2127 register char *s = (char *)ptr;
2128 register char *e = s + (n-1);
2131 for (n /= 2; n > 0; s++, e--, n--) {
2139 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2141 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2144 register I32 This, that;
2150 PERL_FLUSHALL_FOR_CHILD;
2151 This = (*mode == 'w');
2155 taint_proper("Insecure %s%s", "EXEC");
2157 if (PerlProc_pipe(p) < 0)
2159 /* Try for another pipe pair for error return */
2160 if (PerlProc_pipe(pp) >= 0)
2162 while ((pid = PerlProc_fork()) < 0) {
2163 if (errno != EAGAIN) {
2164 PerlLIO_close(p[This]);
2165 PerlLIO_close(p[that]);
2167 PerlLIO_close(pp[0]);
2168 PerlLIO_close(pp[1]);
2180 /* Close parent's end of error status pipe (if any) */
2182 PerlLIO_close(pp[0]);
2183 #if defined(HAS_FCNTL) && defined(F_SETFD)
2184 /* Close error pipe automatically if exec works */
2185 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2188 /* Now dup our end of _the_ pipe to right position */
2189 if (p[THIS] != (*mode == 'r')) {
2190 PerlLIO_dup2(p[THIS], *mode == 'r');
2191 PerlLIO_close(p[THIS]);
2192 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2193 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2196 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2197 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2198 /* No automatic close - do it by hand */
2205 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2211 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2217 do_execfree(); /* free any memory malloced by child on fork */
2219 PerlLIO_close(pp[1]);
2220 /* Keep the lower of the two fd numbers */
2221 if (p[that] < p[This]) {
2222 PerlLIO_dup2(p[This], p[that]);
2223 PerlLIO_close(p[This]);
2227 PerlLIO_close(p[that]); /* close child's end of pipe */
2230 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2232 SvUPGRADE(sv,SVt_IV);
2234 PL_forkprocess = pid;
2235 /* If we managed to get status pipe check for exec fail */
2236 if (did_pipes && pid > 0) {
2241 while (n < sizeof(int)) {
2242 n1 = PerlLIO_read(pp[0],
2243 (void*)(((char*)&errkid)+n),
2249 PerlLIO_close(pp[0]);
2251 if (n) { /* Error */
2253 PerlLIO_close(p[This]);
2254 if (n != sizeof(int))
2255 Perl_croak(aTHX_ "panic: kid popen errno read");
2257 pid2 = wait4pid(pid, &status, 0);
2258 } while (pid2 == -1 && errno == EINTR);
2259 errno = errkid; /* Propagate errno from kid */
2264 PerlLIO_close(pp[0]);
2265 return PerlIO_fdopen(p[This], mode);
2267 Perl_croak(aTHX_ "List form of piped open not implemented");
2268 return (PerlIO *) NULL;
2272 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2273 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2275 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2279 register I32 This, that;
2282 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2286 PERL_FLUSHALL_FOR_CHILD;
2289 return my_syspopen(aTHX_ cmd,mode);
2292 This = (*mode == 'w');
2294 if (doexec && PL_tainting) {
2296 taint_proper("Insecure %s%s", "EXEC");
2298 if (PerlProc_pipe(p) < 0)
2300 if (doexec && PerlProc_pipe(pp) >= 0)
2302 while ((pid = PerlProc_fork()) < 0) {
2303 if (errno != EAGAIN) {
2304 PerlLIO_close(p[This]);
2305 PerlLIO_close(p[that]);
2307 PerlLIO_close(pp[0]);
2308 PerlLIO_close(pp[1]);
2311 Perl_croak(aTHX_ "Can't fork");
2324 PerlLIO_close(pp[0]);
2325 #if defined(HAS_FCNTL) && defined(F_SETFD)
2326 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2329 if (p[THIS] != (*mode == 'r')) {
2330 PerlLIO_dup2(p[THIS], *mode == 'r');
2331 PerlLIO_close(p[THIS]);
2332 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2333 PerlLIO_close(p[THAT]);
2336 PerlLIO_close(p[THAT]);
2339 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2346 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2351 /* may or may not use the shell */
2352 do_exec3(cmd, pp[1], did_pipes);
2355 #endif /* defined OS2 */
2356 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2357 SvREADONLY_off(GvSV(tmpgv));
2358 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2359 SvREADONLY_on(GvSV(tmpgv));
2361 #ifdef THREADS_HAVE_PIDS
2362 PL_ppid = (IV)getppid();
2365 #ifdef PERL_USES_PL_PIDSTATUS
2366 hv_clear(PL_pidstatus); /* we have no children */
2372 do_execfree(); /* free any memory malloced by child on vfork */
2374 PerlLIO_close(pp[1]);
2375 if (p[that] < p[This]) {
2376 PerlLIO_dup2(p[This], p[that]);
2377 PerlLIO_close(p[This]);
2381 PerlLIO_close(p[that]);
2384 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2386 SvUPGRADE(sv,SVt_IV);
2388 PL_forkprocess = pid;
2389 if (did_pipes && pid > 0) {
2394 while (n < sizeof(int)) {
2395 n1 = PerlLIO_read(pp[0],
2396 (void*)(((char*)&errkid)+n),
2402 PerlLIO_close(pp[0]);
2404 if (n) { /* Error */
2406 PerlLIO_close(p[This]);
2407 if (n != sizeof(int))
2408 Perl_croak(aTHX_ "panic: kid popen errno read");
2410 pid2 = wait4pid(pid, &status, 0);
2411 } while (pid2 == -1 && errno == EINTR);
2412 errno = errkid; /* Propagate errno from kid */
2417 PerlLIO_close(pp[0]);
2418 return PerlIO_fdopen(p[This], mode);
2421 #if defined(atarist) || defined(EPOC)
2424 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2426 PERL_FLUSHALL_FOR_CHILD;
2427 /* Call system's popen() to get a FILE *, then import it.
2428 used 0 for 2nd parameter to PerlIO_importFILE;
2431 return PerlIO_importFILE(popen(cmd, mode), 0);
2435 FILE *djgpp_popen();
2437 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2439 PERL_FLUSHALL_FOR_CHILD;
2440 /* Call system's popen() to get a FILE *, then import it.
2441 used 0 for 2nd parameter to PerlIO_importFILE;
2444 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2449 #endif /* !DOSISH */
2451 /* this is called in parent before the fork() */
2453 Perl_atfork_lock(void)
2456 #if defined(USE_ITHREADS)
2457 /* locks must be held in locking order (if any) */
2459 MUTEX_LOCK(&PL_malloc_mutex);
2465 /* this is called in both parent and child after the fork() */
2467 Perl_atfork_unlock(void)
2470 #if defined(USE_ITHREADS)
2471 /* locks must be released in same order as in atfork_lock() */
2473 MUTEX_UNLOCK(&PL_malloc_mutex);
2482 #if defined(HAS_FORK)
2484 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2489 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2490 * handlers elsewhere in the code */
2495 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2496 Perl_croak_nocontext("fork() not available");
2498 #endif /* HAS_FORK */
2503 Perl_dump_fds(pTHX_ char *s)
2508 PerlIO_printf(Perl_debug_log,"%s", s);
2509 for (fd = 0; fd < 32; fd++) {
2510 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2511 PerlIO_printf(Perl_debug_log," %d",fd);
2513 PerlIO_printf(Perl_debug_log,"\n");
2516 #endif /* DUMP_FDS */
2520 dup2(int oldfd, int newfd)
2522 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2525 PerlLIO_close(newfd);
2526 return fcntl(oldfd, F_DUPFD, newfd);
2528 #define DUP2_MAX_FDS 256
2529 int fdtmp[DUP2_MAX_FDS];
2535 PerlLIO_close(newfd);
2536 /* good enough for low fd's... */
2537 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2538 if (fdx >= DUP2_MAX_FDS) {
2546 PerlLIO_close(fdtmp[--fdx]);
2553 #ifdef HAS_SIGACTION
2555 #ifdef MACOS_TRADITIONAL
2556 /* We don't want restart behavior on MacOS */
2561 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2564 struct sigaction act, oact;
2567 /* only "parent" interpreter can diddle signals */
2568 if (PL_curinterp != aTHX)
2569 return (Sighandler_t) SIG_ERR;
2572 act.sa_handler = (void(*)(int))handler;
2573 sigemptyset(&act.sa_mask);
2576 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2577 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2579 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2580 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2581 act.sa_flags |= SA_NOCLDWAIT;
2583 if (sigaction(signo, &act, &oact) == -1)
2584 return (Sighandler_t) SIG_ERR;
2586 return (Sighandler_t) oact.sa_handler;
2590 Perl_rsignal_state(pTHX_ int signo)
2592 struct sigaction oact;
2593 PERL_UNUSED_CONTEXT;
2595 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2596 return (Sighandler_t) SIG_ERR;
2598 return (Sighandler_t) oact.sa_handler;
2602 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2605 struct sigaction act;
2608 /* only "parent" interpreter can diddle signals */
2609 if (PL_curinterp != aTHX)
2613 act.sa_handler = (void(*)(int))handler;
2614 sigemptyset(&act.sa_mask);
2617 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2618 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2620 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2621 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2622 act.sa_flags |= SA_NOCLDWAIT;
2624 return sigaction(signo, &act, save);
2628 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2632 /* only "parent" interpreter can diddle signals */
2633 if (PL_curinterp != aTHX)
2637 return sigaction(signo, save, (struct sigaction *)NULL);
2640 #else /* !HAS_SIGACTION */
2643 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2645 #if defined(USE_ITHREADS) && !defined(WIN32)
2646 /* only "parent" interpreter can diddle signals */
2647 if (PL_curinterp != aTHX)
2648 return (Sighandler_t) SIG_ERR;
2651 return PerlProc_signal(signo, handler);
2662 Perl_rsignal_state(pTHX_ int signo)
2665 Sighandler_t oldsig;
2667 #if defined(USE_ITHREADS) && !defined(WIN32)
2668 /* only "parent" interpreter can diddle signals */
2669 if (PL_curinterp != aTHX)
2670 return (Sighandler_t) SIG_ERR;
2674 oldsig = PerlProc_signal(signo, sig_trap);
2675 PerlProc_signal(signo, oldsig);
2677 PerlProc_kill(PerlProc_getpid(), signo);
2682 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2684 #if defined(USE_ITHREADS) && !defined(WIN32)
2685 /* only "parent" interpreter can diddle signals */
2686 if (PL_curinterp != aTHX)
2689 *save = PerlProc_signal(signo, handler);
2690 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2694 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2696 #if defined(USE_ITHREADS) && !defined(WIN32)
2697 /* only "parent" interpreter can diddle signals */
2698 if (PL_curinterp != aTHX)
2701 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2704 #endif /* !HAS_SIGACTION */
2705 #endif /* !PERL_MICRO */
2707 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2708 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2710 Perl_my_pclose(pTHX_ PerlIO *ptr)
2713 Sigsave_t hstat, istat, qstat;
2719 int saved_errno = 0;
2721 int saved_win32_errno;
2725 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2727 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2729 *svp = &PL_sv_undef;
2731 if (pid == -1) { /* Opened by popen. */
2732 return my_syspclose(ptr);
2735 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2736 saved_errno = errno;
2738 saved_win32_errno = GetLastError();
2742 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2745 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2746 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2747 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2750 pid2 = wait4pid(pid, &status, 0);
2751 } while (pid2 == -1 && errno == EINTR);
2753 rsignal_restore(SIGHUP, &hstat);
2754 rsignal_restore(SIGINT, &istat);
2755 rsignal_restore(SIGQUIT, &qstat);
2758 SETERRNO(saved_errno, 0);
2761 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2763 #endif /* !DOSISH */
2765 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2767 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2773 #ifdef PERL_USES_PL_PIDSTATUS
2776 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2777 pid, rather than a string form. */
2778 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2779 if (svp && *svp != &PL_sv_undef) {
2780 *statusp = SvIVX(*svp);
2781 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2789 hv_iterinit(PL_pidstatus);
2790 if ((entry = hv_iternext(PL_pidstatus))) {
2791 SV * const sv = hv_iterval(PL_pidstatus,entry);
2793 const char * const spid = hv_iterkey(entry,&len);
2795 assert (len == sizeof(Pid_t));
2796 memcpy((char *)&pid, spid, len);
2797 *statusp = SvIVX(sv);
2798 /* The hash iterator is currently on this entry, so simply
2799 calling hv_delete would trigger the lazy delete, which on
2800 aggregate does more work, beacuse next call to hv_iterinit()
2801 would spot the flag, and have to call the delete routine,
2802 while in the meantime any new entries can't re-use that
2804 hv_iterinit(PL_pidstatus);
2805 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2812 # ifdef HAS_WAITPID_RUNTIME
2813 if (!HAS_WAITPID_RUNTIME)
2816 result = PerlProc_waitpid(pid,statusp,flags);
2819 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2820 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2823 #ifdef PERL_USES_PL_PIDSTATUS
2824 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2829 Perl_croak(aTHX_ "Can't do waitpid with flags");
2831 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2832 pidgone(result,*statusp);
2838 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2841 if (result < 0 && errno == EINTR) {
2846 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2848 #ifdef PERL_USES_PL_PIDSTATUS
2850 Perl_pidgone(pTHX_ Pid_t pid, int status)
2854 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2855 SvUPGRADE(sv,SVt_IV);
2856 SvIV_set(sv, status);
2861 #if defined(atarist) || defined(OS2) || defined(EPOC)
2864 int /* Cannot prototype with I32
2866 my_syspclose(PerlIO *ptr)
2869 Perl_my_pclose(pTHX_ PerlIO *ptr)
2872 /* Needs work for PerlIO ! */
2873 FILE * const f = PerlIO_findFILE(ptr);
2874 const I32 result = pclose(f);
2875 PerlIO_releaseFILE(ptr,f);
2883 Perl_my_pclose(pTHX_ PerlIO *ptr)
2885 /* Needs work for PerlIO ! */
2886 FILE * const f = PerlIO_findFILE(ptr);
2887 I32 result = djgpp_pclose(f);
2888 result = (result << 8) & 0xff00;
2889 PerlIO_releaseFILE(ptr,f);
2895 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2898 register const char * const frombase = from;
2899 PERL_UNUSED_CONTEXT;
2902 register const char c = *from;
2907 while (count-- > 0) {
2908 for (todo = len; todo > 0; todo--) {
2917 Perl_same_dirent(pTHX_ const char *a, const char *b)
2919 char *fa = strrchr(a,'/');
2920 char *fb = strrchr(b,'/');
2923 SV * const tmpsv = sv_newmortal();
2936 sv_setpvn(tmpsv, ".", 1);
2938 sv_setpvn(tmpsv, a, fa - a);
2939 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2942 sv_setpvn(tmpsv, ".", 1);
2944 sv_setpvn(tmpsv, b, fb - b);
2945 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2947 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2948 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2950 #endif /* !HAS_RENAME */
2953 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2954 const char *const *const search_ext, I32 flags)
2957 const char *xfound = NULL;
2958 char *xfailed = NULL;
2959 char tmpbuf[MAXPATHLEN];
2963 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2964 # define SEARCH_EXTS ".bat", ".cmd", NULL
2965 # define MAX_EXT_LEN 4
2968 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2969 # define MAX_EXT_LEN 4
2972 # define SEARCH_EXTS ".pl", ".com", NULL
2973 # define MAX_EXT_LEN 4
2975 /* additional extensions to try in each dir if scriptname not found */
2977 static const char *const exts[] = { SEARCH_EXTS };
2978 const char *const *const ext = search_ext ? search_ext : exts;
2979 int extidx = 0, i = 0;
2980 const char *curext = NULL;
2982 PERL_UNUSED_ARG(search_ext);
2983 # define MAX_EXT_LEN 0
2987 * If dosearch is true and if scriptname does not contain path
2988 * delimiters, search the PATH for scriptname.
2990 * If SEARCH_EXTS is also defined, will look for each
2991 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2992 * while searching the PATH.
2994 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2995 * proceeds as follows:
2996 * If DOSISH or VMSISH:
2997 * + look for ./scriptname{,.foo,.bar}
2998 * + search the PATH for scriptname{,.foo,.bar}
3001 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3002 * this will not look in '.' if it's not in the PATH)
3007 # ifdef ALWAYS_DEFTYPES
3008 len = strlen(scriptname);
3009 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3010 int idx = 0, deftypes = 1;
3013 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3016 int idx = 0, deftypes = 1;
3019 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3021 /* The first time through, just add SEARCH_EXTS to whatever we
3022 * already have, so we can check for default file types. */
3024 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3030 if ((strlen(tmpbuf) + strlen(scriptname)
3031 + MAX_EXT_LEN) >= sizeof tmpbuf)
3032 continue; /* don't search dir with too-long name */
3033 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3037 if (strEQ(scriptname, "-"))
3039 if (dosearch) { /* Look in '.' first. */
3040 const char *cur = scriptname;
3042 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3044 if (strEQ(ext[i++],curext)) {
3045 extidx = -1; /* already has an ext */
3050 DEBUG_p(PerlIO_printf(Perl_debug_log,
3051 "Looking for %s\n",cur));
3052 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3053 && !S_ISDIR(PL_statbuf.st_mode)) {
3061 if (cur == scriptname) {
3062 len = strlen(scriptname);
3063 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3065 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3068 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3069 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3074 #ifdef MACOS_TRADITIONAL
3075 if (dosearch && !strchr(scriptname, ':') &&
3076 (s = PerlEnv_getenv("Commands")))
3078 if (dosearch && !strchr(scriptname, '/')
3080 && !strchr(scriptname, '\\')
3082 && (s = PerlEnv_getenv("PATH")))
3087 PL_bufend = s + strlen(s);
3088 while (s < PL_bufend) {
3089 #ifdef MACOS_TRADITIONAL
3090 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3094 #if defined(atarist) || defined(DOSISH)
3099 && *s != ';'; len++, s++) {
3100 if (len < sizeof tmpbuf)
3103 if (len < sizeof tmpbuf)
3105 #else /* ! (atarist || DOSISH) */
3106 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3109 #endif /* ! (atarist || DOSISH) */
3110 #endif /* MACOS_TRADITIONAL */
3113 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3114 continue; /* don't search dir with too-long name */
3115 #ifdef MACOS_TRADITIONAL
3116 if (len && tmpbuf[len - 1] != ':')
3117 tmpbuf[len++] = ':';
3120 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3121 && tmpbuf[len - 1] != '/'
3122 && tmpbuf[len - 1] != '\\'
3125 tmpbuf[len++] = '/';
3126 if (len == 2 && tmpbuf[0] == '.')
3129 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3133 len = strlen(tmpbuf);
3134 if (extidx > 0) /* reset after previous loop */
3138 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3139 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3140 if (S_ISDIR(PL_statbuf.st_mode)) {
3144 } while ( retval < 0 /* not there */
3145 && extidx>=0 && ext[extidx] /* try an extension? */
3146 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3151 if (S_ISREG(PL_statbuf.st_mode)
3152 && cando(S_IRUSR,TRUE,&PL_statbuf)
3153 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3154 && cando(S_IXUSR,TRUE,&PL_statbuf)
3158 xfound = tmpbuf; /* bingo! */
3162 xfailed = savepv(tmpbuf);
3165 if (!xfound && !seen_dot && !xfailed &&
3166 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3167 || S_ISDIR(PL_statbuf.st_mode)))
3169 seen_dot = 1; /* Disable message. */
3171 if (flags & 1) { /* do or die? */
3172 Perl_croak(aTHX_ "Can't %s %s%s%s",
3173 (xfailed ? "execute" : "find"),
3174 (xfailed ? xfailed : scriptname),
3175 (xfailed ? "" : " on PATH"),
3176 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3181 scriptname = xfound;
3183 return (scriptname ? savepv(scriptname) : NULL);
3186 #ifndef PERL_GET_CONTEXT_DEFINED
3189 Perl_get_context(void)
3192 #if defined(USE_ITHREADS)
3193 # ifdef OLD_PTHREADS_API
3195 if (pthread_getspecific(PL_thr_key, &t))
3196 Perl_croak_nocontext("panic: pthread_getspecific");
3199 # ifdef I_MACH_CTHREADS
3200 return (void*)cthread_data(cthread_self());
3202 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3211 Perl_set_context(void *t)
3214 #if defined(USE_ITHREADS)
3215 # ifdef I_MACH_CTHREADS
3216 cthread_set_data(cthread_self(), t);
3218 if (pthread_setspecific(PL_thr_key, t))
3219 Perl_croak_nocontext("panic: pthread_setspecific");
3226 #endif /* !PERL_GET_CONTEXT_DEFINED */
3228 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3237 Perl_get_op_names(pTHX)
3239 PERL_UNUSED_CONTEXT;
3240 return (char **)PL_op_name;
3244 Perl_get_op_descs(pTHX)
3246 PERL_UNUSED_CONTEXT;
3247 return (char **)PL_op_desc;
3251 Perl_get_no_modify(pTHX)
3253 PERL_UNUSED_CONTEXT;
3254 return PL_no_modify;
3258 Perl_get_opargs(pTHX)
3260 PERL_UNUSED_CONTEXT;
3261 return (U32 *)PL_opargs;
3265 Perl_get_ppaddr(pTHX)
3268 PERL_UNUSED_CONTEXT;
3269 return (PPADDR_t*)PL_ppaddr;
3272 #ifndef HAS_GETENV_LEN
3274 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3276 char * const env_trans = PerlEnv_getenv(env_elem);
3277 PERL_UNUSED_CONTEXT;
3279 *len = strlen(env_trans);
3286 Perl_get_vtbl(pTHX_ int vtbl_id)
3288 const MGVTBL* result;
3289 PERL_UNUSED_CONTEXT;
3293 result = &PL_vtbl_sv;
3296 result = &PL_vtbl_env;
3298 case want_vtbl_envelem:
3299 result = &PL_vtbl_envelem;
3302 result = &PL_vtbl_sig;
3304 case want_vtbl_sigelem:
3305 result = &PL_vtbl_sigelem;
3307 case want_vtbl_pack:
3308 result = &PL_vtbl_pack;
3310 case want_vtbl_packelem:
3311 result = &PL_vtbl_packelem;
3313 case want_vtbl_dbline:
3314 result = &PL_vtbl_dbline;
3317 result = &PL_vtbl_isa;
3319 case want_vtbl_isaelem:
3320 result = &PL_vtbl_isaelem;
3322 case want_vtbl_arylen:
3323 result = &PL_vtbl_arylen;
3325 case want_vtbl_mglob:
3326 result = &PL_vtbl_mglob;
3328 case want_vtbl_nkeys:
3329 result = &PL_vtbl_nkeys;
3331 case want_vtbl_taint:
3332 result = &PL_vtbl_taint;
3334 case want_vtbl_substr:
3335 result = &PL_vtbl_substr;
3338 result = &PL_vtbl_vec;
3341 result = &PL_vtbl_pos;
3344 result = &PL_vtbl_bm;
3347 result = &PL_vtbl_fm;
3349 case want_vtbl_uvar:
3350 result = &PL_vtbl_uvar;
3352 case want_vtbl_defelem:
3353 result = &PL_vtbl_defelem;
3355 case want_vtbl_regexp:
3356 result = &PL_vtbl_regexp;
3358 case want_vtbl_regdata:
3359 result = &PL_vtbl_regdata;
3361 case want_vtbl_regdatum:
3362 result = &PL_vtbl_regdatum;
3364 #ifdef USE_LOCALE_COLLATE
3365 case want_vtbl_collxfrm:
3366 result = &PL_vtbl_collxfrm;
3369 case want_vtbl_amagic:
3370 result = &PL_vtbl_amagic;
3372 case want_vtbl_amagicelem:
3373 result = &PL_vtbl_amagicelem;
3375 case want_vtbl_backref:
3376 result = &PL_vtbl_backref;
3378 case want_vtbl_utf8:
3379 result = &PL_vtbl_utf8;
3385 return (MGVTBL*)result;
3389 Perl_my_fflush_all(pTHX)
3391 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3392 return PerlIO_flush(NULL);
3394 # if defined(HAS__FWALK)
3395 extern int fflush(FILE *);
3396 /* undocumented, unprototyped, but very useful BSDism */
3397 extern void _fwalk(int (*)(FILE *));
3401 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3403 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3404 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3406 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3407 open_max = sysconf(_SC_OPEN_MAX);
3410 open_max = FOPEN_MAX;
3413 open_max = OPEN_MAX;
3424 for (i = 0; i < open_max; i++)
3425 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3426 STDIO_STREAM_ARRAY[i]._file < open_max &&
3427 STDIO_STREAM_ARRAY[i]._flag)
3428 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3432 SETERRNO(EBADF,RMS_IFI);
3439 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3441 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3443 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3444 if (ckWARN(WARN_IO)) {
3445 const char * const direction =
3446 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3448 Perl_warner(aTHX_ packWARN(WARN_IO),
3449 "Filehandle %s opened only for %sput",
3452 Perl_warner(aTHX_ packWARN(WARN_IO),
3453 "Filehandle opened only for %sput", direction);
3460 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3462 warn_type = WARN_CLOSED;
3466 warn_type = WARN_UNOPENED;
3469 if (ckWARN(warn_type)) {
3470 const char * const pars =
3471 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3472 const char * const func =
3474 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3475 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3476 op < 0 ? "" : /* handle phoney cases */
3478 const char * const type =
3480 (OP_IS_SOCKET(op) ||
3481 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3482 "socket" : "filehandle");
3483 if (name && *name) {
3484 Perl_warner(aTHX_ packWARN(warn_type),
3485 "%s%s on %s %s %s", func, pars, vile, type, name);
3486 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3488 aTHX_ packWARN(warn_type),
3489 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3494 Perl_warner(aTHX_ packWARN(warn_type),
3495 "%s%s on %s %s", func, pars, vile, type);
3496 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3498 aTHX_ packWARN(warn_type),
3499 "\t(Are you trying to call %s%s on dirhandle?)\n",
3508 /* in ASCII order, not that it matters */
3509 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3512 Perl_ebcdic_control(pTHX_ int ch)
3520 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3521 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3524 if (ctlp == controllablechars)
3525 return('\177'); /* DEL */
3527 return((unsigned char)(ctlp - controllablechars - 1));
3528 } else { /* Want uncontrol */
3529 if (ch == '\177' || ch == -1)
3531 else if (ch == '\157')
3533 else if (ch == '\174')
3535 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3537 else if (ch == '\155')
3539 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3540 return(controllablechars[ch+1]);
3542 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3547 /* To workaround core dumps from the uninitialised tm_zone we get the
3548 * system to give us a reasonable struct to copy. This fix means that
3549 * strftime uses the tm_zone and tm_gmtoff values returned by
3550 * localtime(time()). That should give the desired result most of the
3551 * time. But probably not always!
3553 * This does not address tzname aspects of NETaa14816.
3558 # ifndef STRUCT_TM_HASZONE
3559 # define STRUCT_TM_HASZONE
3563 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3564 # ifndef HAS_TM_TM_ZONE
3565 # define HAS_TM_TM_ZONE
3570 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3572 #ifdef HAS_TM_TM_ZONE
3574 const struct tm* my_tm;
3576 my_tm = localtime(&now);
3578 Copy(my_tm, ptm, 1, struct tm);
3580 PERL_UNUSED_ARG(ptm);
3585 * mini_mktime - normalise struct tm values without the localtime()
3586 * semantics (and overhead) of mktime().
3589 Perl_mini_mktime(pTHX_ struct tm *ptm)
3593 int month, mday, year, jday;
3594 int odd_cent, odd_year;
3595 PERL_UNUSED_CONTEXT;
3597 #define DAYS_PER_YEAR 365
3598 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3599 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3600 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3601 #define SECS_PER_HOUR (60*60)
3602 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3603 /* parentheses deliberately absent on these two, otherwise they don't work */
3604 #define MONTH_TO_DAYS 153/5
3605 #define DAYS_TO_MONTH 5/153
3606 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3607 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3608 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3609 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3612 * Year/day algorithm notes:
3614 * With a suitable offset for numeric value of the month, one can find
3615 * an offset into the year by considering months to have 30.6 (153/5) days,
3616 * using integer arithmetic (i.e., with truncation). To avoid too much
3617 * messing about with leap days, we consider January and February to be
3618 * the 13th and 14th month of the previous year. After that transformation,
3619 * we need the month index we use to be high by 1 from 'normal human' usage,
3620 * so the month index values we use run from 4 through 15.
3622 * Given that, and the rules for the Gregorian calendar (leap years are those
3623 * divisible by 4 unless also divisible by 100, when they must be divisible
3624 * by 400 instead), we can simply calculate the number of days since some
3625 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3626 * the days we derive from our month index, and adding in the day of the
3627 * month. The value used here is not adjusted for the actual origin which
3628 * it normally would use (1 January A.D. 1), since we're not exposing it.
3629 * We're only building the value so we can turn around and get the
3630 * normalised values for the year, month, day-of-month, and day-of-year.
3632 * For going backward, we need to bias the value we're using so that we find
3633 * the right year value. (Basically, we don't want the contribution of
3634 * March 1st to the number to apply while deriving the year). Having done
3635 * that, we 'count up' the contribution to the year number by accounting for
3636 * full quadracenturies (400-year periods) with their extra leap days, plus
3637 * the contribution from full centuries (to avoid counting in the lost leap
3638 * days), plus the contribution from full quad-years (to count in the normal
3639 * leap days), plus the leftover contribution from any non-leap years.
3640 * At this point, if we were working with an actual leap day, we'll have 0
3641 * days left over. This is also true for March 1st, however. So, we have
3642 * to special-case that result, and (earlier) keep track of the 'odd'
3643 * century and year contributions. If we got 4 extra centuries in a qcent,
3644 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3645 * Otherwise, we add back in the earlier bias we removed (the 123 from
3646 * figuring in March 1st), find the month index (integer division by 30.6),
3647 * and the remainder is the day-of-month. We then have to convert back to
3648 * 'real' months (including fixing January and February from being 14/15 in
3649 * the previous year to being in the proper year). After that, to get
3650 * tm_yday, we work with the normalised year and get a new yearday value for
3651 * January 1st, which we subtract from the yearday value we had earlier,
3652 * representing the date we've re-built. This is done from January 1
3653 * because tm_yday is 0-origin.
3655 * Since POSIX time routines are only guaranteed to work for times since the
3656 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3657 * applies Gregorian calendar rules even to dates before the 16th century
3658 * doesn't bother me. Besides, you'd need cultural context for a given
3659 * date to know whether it was Julian or Gregorian calendar, and that's
3660 * outside the scope for this routine. Since we convert back based on the
3661 * same rules we used to build the yearday, you'll only get strange results
3662 * for input which needed normalising, or for the 'odd' century years which
3663 * were leap years in the Julian calander but not in the Gregorian one.
3664 * I can live with that.
3666 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3667 * that's still outside the scope for POSIX time manipulation, so I don't
3671 year = 1900 + ptm->tm_year;
3672 month = ptm->tm_mon;
3673 mday = ptm->tm_mday;
3674 /* allow given yday with no month & mday to dominate the result */
3675 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3678 jday = 1 + ptm->tm_yday;
3687 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3688 yearday += month*MONTH_TO_DAYS + mday + jday;
3690 * Note that we don't know when leap-seconds were or will be,
3691 * so we have to trust the user if we get something which looks
3692 * like a sensible leap-second. Wild values for seconds will
3693 * be rationalised, however.
3695 if ((unsigned) ptm->tm_sec <= 60) {
3702 secs += 60 * ptm->tm_min;
3703 secs += SECS_PER_HOUR * ptm->tm_hour;
3705 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3706 /* got negative remainder, but need positive time */
3707 /* back off an extra day to compensate */
3708 yearday += (secs/SECS_PER_DAY)-1;
3709 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3712 yearday += (secs/SECS_PER_DAY);
3713 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3716 else if (secs >= SECS_PER_DAY) {
3717 yearday += (secs/SECS_PER_DAY);
3718 secs %= SECS_PER_DAY;
3720 ptm->tm_hour = secs/SECS_PER_HOUR;
3721 secs %= SECS_PER_HOUR;
3722 ptm->tm_min = secs/60;
3724 ptm->tm_sec += secs;
3725 /* done with time of day effects */
3727 * The algorithm for yearday has (so far) left it high by 428.
3728 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3729 * bias it by 123 while trying to figure out what year it
3730 * really represents. Even with this tweak, the reverse
3731 * translation fails for years before A.D. 0001.
3732 * It would still fail for Feb 29, but we catch that one below.
3734 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3735 yearday -= YEAR_ADJUST;
3736 year = (yearday / DAYS_PER_QCENT) * 400;
3737 yearday %= DAYS_PER_QCENT;
3738 odd_cent = yearday / DAYS_PER_CENT;
3739 year += odd_cent * 100;
3740 yearday %= DAYS_PER_CENT;
3741 year += (yearday / DAYS_PER_QYEAR) * 4;
3742 yearday %= DAYS_PER_QYEAR;
3743 odd_year = yearday / DAYS_PER_YEAR;
3745 yearday %= DAYS_PER_YEAR;
3746 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3751 yearday += YEAR_ADJUST; /* recover March 1st crock */
3752 month = yearday*DAYS_TO_MONTH;
3753 yearday -= month*MONTH_TO_DAYS;
3754 /* recover other leap-year adjustment */
3763 ptm->tm_year = year - 1900;
3765 ptm->tm_mday = yearday;
3766 ptm->tm_mon = month;
3770 ptm->tm_mon = month - 1;
3772 /* re-build yearday based on Jan 1 to get tm_yday */
3774 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3775 yearday += 14*MONTH_TO_DAYS + 1;
3776 ptm->tm_yday = jday - yearday;
3777 /* fix tm_wday if not overridden by caller */
3778 if ((unsigned)ptm->tm_wday > 6)
3779 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3783 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)
3791 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3794 mytm.tm_hour = hour;
3795 mytm.tm_mday = mday;
3797 mytm.tm_year = year;
3798 mytm.tm_wday = wday;
3799 mytm.tm_yday = yday;
3800 mytm.tm_isdst = isdst;
3802 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3803 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3808 #ifdef HAS_TM_TM_GMTOFF
3809 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3811 #ifdef HAS_TM_TM_ZONE
3812 mytm.tm_zone = mytm2.tm_zone;
3817 Newx(buf, buflen, char);
3818 len = strftime(buf, buflen, fmt, &mytm);
3820 ** The following is needed to handle to the situation where
3821 ** tmpbuf overflows. Basically we want to allocate a buffer
3822 ** and try repeatedly. The reason why it is so complicated
3823 ** is that getting a return value of 0 from strftime can indicate
3824 ** one of the following:
3825 ** 1. buffer overflowed,
3826 ** 2. illegal conversion specifier, or
3827 ** 3. the format string specifies nothing to be returned(not
3828 ** an error). This could be because format is an empty string
3829 ** or it specifies %p that yields an empty string in some locale.
3830 ** If there is a better way to make it portable, go ahead by
3833 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3836 /* Possibly buf overflowed - try again with a bigger buf */
3837 const int fmtlen = strlen(fmt);
3838 int bufsize = fmtlen + buflen;
3840 Newx(buf, bufsize, char);
3842 buflen = strftime(buf, bufsize, fmt, &mytm);
3843 if (buflen > 0 && buflen < bufsize)
3845 /* heuristic to prevent out-of-memory errors */
3846 if (bufsize > 100*fmtlen) {
3852 Renew(buf, bufsize, char);
3857 Perl_croak(aTHX_ "panic: no strftime");
3863 #define SV_CWD_RETURN_UNDEF \
3864 sv_setsv(sv, &PL_sv_undef); \
3867 #define SV_CWD_ISDOT(dp) \
3868 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3869 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3872 =head1 Miscellaneous Functions
3874 =for apidoc getcwd_sv
3876 Fill the sv with current working directory
3881 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3882 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3883 * getcwd(3) if available
3884 * Comments from the orignal:
3885 * This is a faster version of getcwd. It's also more dangerous
3886 * because you might chdir out of a directory that you can't chdir
3890 Perl_getcwd_sv(pTHX_ register SV *sv)
3894 #ifndef INCOMPLETE_TAINTS
3900 char buf[MAXPATHLEN];
3902 /* Some getcwd()s automatically allocate a buffer of the given
3903 * size from the heap if they are given a NULL buffer pointer.
3904 * The problem is that this behaviour is not portable. */
3905 if (getcwd(buf, sizeof(buf) - 1)) {
3910 sv_setsv(sv, &PL_sv_undef);
3918 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3922 SvUPGRADE(sv, SVt_PV);
3924 if (PerlLIO_lstat(".", &statbuf) < 0) {
3925 SV_CWD_RETURN_UNDEF;
3928 orig_cdev = statbuf.st_dev;
3929 orig_cino = statbuf.st_ino;
3938 if (PerlDir_chdir("..") < 0) {
3939 SV_CWD_RETURN_UNDEF;
3941 if (PerlLIO_stat(".", &statbuf) < 0) {
3942 SV_CWD_RETURN_UNDEF;
3945 cdev = statbuf.st_dev;
3946 cino = statbuf.st_ino;
3948 if (odev == cdev && oino == cino) {
3951 if (!(dir = PerlDir_open("."))) {
3952 SV_CWD_RETURN_UNDEF;
3955 while ((dp = PerlDir_read(dir)) != NULL) {
3957 const int namelen = dp->d_namlen;
3959 const int namelen = strlen(dp->d_name);
3962 if (SV_CWD_ISDOT(dp)) {
3966 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3967 SV_CWD_RETURN_UNDEF;
3970 tdev = statbuf.st_dev;
3971 tino = statbuf.st_ino;
3972 if (tino == oino && tdev == odev) {
3978 SV_CWD_RETURN_UNDEF;
3981 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3982 SV_CWD_RETURN_UNDEF;
3985 SvGROW(sv, pathlen + namelen + 1);
3989 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3992 /* prepend current directory to the front */
3994 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3995 pathlen += (namelen + 1);
3997 #ifdef VOID_CLOSEDIR
4000 if (PerlDir_close(dir) < 0) {
4001 SV_CWD_RETURN_UNDEF;
4007 SvCUR_set(sv, pathlen);
4011 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4012 SV_CWD_RETURN_UNDEF;
4015 if (PerlLIO_stat(".", &statbuf) < 0) {
4016 SV_CWD_RETURN_UNDEF;
4019 cdev = statbuf.st_dev;
4020 cino = statbuf.st_ino;
4022 if (cdev != orig_cdev || cino != orig_cino) {
4023 Perl_croak(aTHX_ "Unstable directory path, "
4024 "current directory changed unexpectedly");
4036 =for apidoc scan_version
4038 Returns a pointer to the next character after the parsed
4039 version string, as well as upgrading the passed in SV to
4042 Function must be called with an already existing SV like
4045 s = scan_version(s,SV *sv, bool qv);
4047 Performs some preprocessing to the string to ensure that
4048 it has the correct characteristics of a version. Flags the
4049 object if it contains an underscore (which denotes this
4050 is a alpha version). The boolean qv denotes that the version
4051 should be interpreted as if it had multiple decimals, even if
4058 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4066 AV * const av = newAV();
4067 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4068 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4070 #ifndef NODEFAULT_SHAREKEYS
4071 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4074 while (isSPACE(*s)) /* leading whitespace is OK */
4078 s++; /* get past 'v' */
4079 qv = 1; /* force quoted version processing */
4082 start = last = pos = s;
4084 /* pre-scan the input string to check for decimals/underbars */
4085 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4090 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4094 else if ( *pos == '_' )
4097 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4099 width = pos - last - 1; /* natural width of sub-version */
4104 if ( alpha && !saw_period )
4105 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4107 if ( saw_period > 1 )
4108 qv = 1; /* force quoted version processing */
4113 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4115 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4116 if ( !qv && width < 3 )
4117 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4119 while (isDIGIT(*pos))
4121 if (!isALPHA(*pos)) {
4127 /* this is atoi() that delimits on underscores */
4128 const char *end = pos;
4132 /* the following if() will only be true after the decimal
4133 * point of a version originally created with a bare
4134 * floating point number, i.e. not quoted in any way
4136 if ( !qv && s > start && saw_period == 1 ) {
4140 rev += (*s - '0') * mult;
4142 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4143 Perl_croak(aTHX_ "Integer overflow in version");
4150 while (--end >= s) {
4152 rev += (*end - '0') * mult;
4154 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4155 Perl_croak(aTHX_ "Integer overflow in version");
4160 /* Append revision */
4161 av_push(av, newSViv(rev));
4164 else if ( *pos == '_' && isDIGIT(pos[1]) )
4166 else if ( isDIGIT(*pos) )
4173 while ( isDIGIT(*pos) )
4178 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4186 if ( qv ) { /* quoted versions always get at least three terms*/
4187 I32 len = av_len(av);
4188 /* This for loop appears to trigger a compiler bug on OS X, as it
4189 loops infinitely. Yes, len is negative. No, it makes no sense.
4190 Compiler in question is:
4191 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4192 for ( len = 2 - len; len > 0; len-- )
4193 av_push((AV *)sv, newSViv(0));
4197 av_push(av, newSViv(0));
4200 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4201 av_push(av, newSViv(0));
4203 /* fix RT#19517 - special case 'undef' as string */
4204 if ( *s == 'u' && strEQ(s,"undef") ) {
4208 /* And finally, store the AV in the hash */
4209 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4214 =for apidoc new_version
4216 Returns a new version object based on the passed in SV:
4218 SV *sv = new_version(SV *ver);
4220 Does not alter the passed in ver SV. See "upg_version" if you
4221 want to upgrade the SV.
4227 Perl_new_version(pTHX_ SV *ver)
4230 SV * const rv = newSV(0);
4231 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4234 AV * const av = newAV();
4236 /* This will get reblessed later if a derived class*/
4237 SV * const hv = newSVrv(rv, "version");
4238 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4239 #ifndef NODEFAULT_SHAREKEYS
4240 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4246 /* Begin copying all of the elements */
4247 if ( hv_exists((HV *)ver, "qv", 2) )
4248 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4250 if ( hv_exists((HV *)ver, "alpha", 5) )
4251 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4253 if ( hv_exists((HV*)ver, "width", 5 ) )
4255 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4256 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4259 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4260 /* This will get reblessed later if a derived class*/
4261 for ( key = 0; key <= av_len(sav); key++ )
4263 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4264 av_push(av, newSViv(rev));
4267 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4272 const MAGIC* const mg = SvVSTRING_mg(ver);
4273 if ( mg ) { /* already a v-string */
4274 const STRLEN len = mg->mg_len;
4275 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4276 sv_setpvn(rv,version,len);
4281 sv_setsv(rv,ver); /* make a duplicate */
4286 return upg_version(rv);
4290 =for apidoc upg_version
4292 In-place upgrade of the supplied SV to a version object.
4294 SV *sv = upg_version(SV *sv);
4296 Returns a pointer to the upgraded SV.
4302 Perl_upg_version(pTHX_ SV *ver)
4304 const char *version, *s;
4310 if ( SvNOK(ver) ) /* may get too much accuracy */
4313 #ifdef USE_LOCALE_NUMERIC
4314 char *loc = setlocale(LC_NUMERIC, "C");
4316 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4317 #ifdef USE_LOCALE_NUMERIC
4318 setlocale(LC_NUMERIC, loc);
4320 while (tbuf[len-1] == '0' && len > 0) len--;
4321 version = savepvn(tbuf, len);
4324 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4325 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4329 else /* must be a string or something like a string */
4331 version = savepv(SvPV_nolen(ver));
4334 s = scan_version(version, ver, qv);
4336 if(ckWARN(WARN_MISC))
4337 Perl_warner(aTHX_ packWARN(WARN_MISC),
4338 "Version string '%s' contains invalid data; "
4339 "ignoring: '%s'", version, s);
4347 Validates that the SV contains a valid version object.
4349 bool vverify(SV *vobj);
4351 Note that it only confirms the bare minimum structure (so as not to get
4352 confused by derived classes which may contain additional hash entries):
4356 =item * The SV contains a [reference to a] hash
4358 =item * The hash contains a "version" key
4360 =item * The "version" key has [a reference to] an AV as its value
4368 Perl_vverify(pTHX_ SV *vs)
4374 /* see if the appropriate elements exist */
4375 if ( SvTYPE(vs) == SVt_PVHV
4376 && hv_exists((HV*)vs, "version", 7)
4377 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4378 && SvTYPE(sv) == SVt_PVAV )
4387 Accepts a version object and returns the normalized floating
4388 point representation. Call like:
4392 NOTE: you can pass either the object directly or the SV
4393 contained within the RV.
4399 Perl_vnumify(pTHX_ SV *vs)
4404 SV * const sv = newSV(0);
4410 Perl_croak(aTHX_ "Invalid version object");
4412 /* see if various flags exist */
4413 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4415 if ( hv_exists((HV*)vs, "width", 5 ) )
4416 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4421 /* attempt to retrieve the version array */
4422 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4434 digit = SvIV(*av_fetch(av, 0, 0));
4435 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4436 for ( i = 1 ; i < len ; i++ )
4438 digit = SvIV(*av_fetch(av, i, 0));
4440 const int denom = (width == 2 ? 10 : 100);
4441 const div_t term = div((int)PERL_ABS(digit),denom);
4442 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4445 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4451 digit = SvIV(*av_fetch(av, len, 0));
4452 if ( alpha && width == 3 ) /* alpha version */
4454 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4458 sv_catpvs(sv, "000");
4466 Accepts a version object and returns the normalized string
4467 representation. Call like:
4471 NOTE: you can pass either the object directly or the SV
4472 contained within the RV.
4478 Perl_vnormal(pTHX_ SV *vs)
4482 SV * const sv = newSV(0);
4488 Perl_croak(aTHX_ "Invalid version object");
4490 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4492 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4500 digit = SvIV(*av_fetch(av, 0, 0));
4501 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4502 for ( i = 1 ; i < len ; i++ ) {
4503 digit = SvIV(*av_fetch(av, i, 0));
4504 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4509 /* handle last digit specially */
4510 digit = SvIV(*av_fetch(av, len, 0));
4512 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4514 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4517 if ( len <= 2 ) { /* short version, must be at least three */
4518 for ( len = 2 - len; len != 0; len-- )
4525 =for apidoc vstringify
4527 In order to maintain maximum compatibility with earlier versions
4528 of Perl, this function will return either the floating point
4529 notation or the multiple dotted notation, depending on whether
4530 the original version contained 1 or more dots, respectively
4536 Perl_vstringify(pTHX_ SV *vs)
4542 Perl_croak(aTHX_ "Invalid version object");
4544 if ( hv_exists((HV *)vs, "qv", 2) )
4553 Version object aware cmp. Both operands must already have been
4554 converted into version objects.
4560 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4563 bool lalpha = FALSE;
4564 bool ralpha = FALSE;
4573 if ( !vverify(lhv) )
4574 Perl_croak(aTHX_ "Invalid version object");
4576 if ( !vverify(rhv) )
4577 Perl_croak(aTHX_ "Invalid version object");
4579 /* get the left hand term */
4580 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4581 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4584 /* and the right hand term */
4585 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4586 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4594 while ( i <= m && retval == 0 )
4596 left = SvIV(*av_fetch(lav,i,0));
4597 right = SvIV(*av_fetch(rav,i,0));
4605 /* tiebreaker for alpha with identical terms */
4606 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4608 if ( lalpha && !ralpha )
4612 else if ( ralpha && !lalpha)
4618 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4622 while ( i <= r && retval == 0 )
4624 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4625 retval = -1; /* not a match after all */
4631 while ( i <= l && retval == 0 )
4633 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4634 retval = +1; /* not a match after all */
4642 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4643 # define EMULATE_SOCKETPAIR_UDP
4646 #ifdef EMULATE_SOCKETPAIR_UDP
4648 S_socketpair_udp (int fd[2]) {
4650 /* Fake a datagram socketpair using UDP to localhost. */
4651 int sockets[2] = {-1, -1};
4652 struct sockaddr_in addresses[2];
4654 Sock_size_t size = sizeof(struct sockaddr_in);
4655 unsigned short port;
4658 memset(&addresses, 0, sizeof(addresses));
4661 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4662 if (sockets[i] == -1)
4663 goto tidy_up_and_fail;
4665 addresses[i].sin_family = AF_INET;
4666 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4667 addresses[i].sin_port = 0; /* kernel choses port. */
4668 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4669 sizeof(struct sockaddr_in)) == -1)
4670 goto tidy_up_and_fail;
4673 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4674 for each connect the other socket to it. */
4677 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4679 goto tidy_up_and_fail;
4680 if (size != sizeof(struct sockaddr_in))
4681 goto abort_tidy_up_and_fail;
4682 /* !1 is 0, !0 is 1 */
4683 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4684 sizeof(struct sockaddr_in)) == -1)
4685 goto tidy_up_and_fail;
4688 /* Now we have 2 sockets connected to each other. I don't trust some other
4689 process not to have already sent a packet to us (by random) so send
4690 a packet from each to the other. */
4693 /* I'm going to send my own port number. As a short.
4694 (Who knows if someone somewhere has sin_port as a bitfield and needs
4695 this routine. (I'm assuming crays have socketpair)) */
4696 port = addresses[i].sin_port;
4697 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4698 if (got != sizeof(port)) {
4700 goto tidy_up_and_fail;
4701 goto abort_tidy_up_and_fail;
4705 /* Packets sent. I don't trust them to have arrived though.
4706 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4707 connect to localhost will use a second kernel thread. In 2.6 the
4708 first thread running the connect() returns before the second completes,
4709 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4710 returns 0. Poor programs have tripped up. One poor program's authors'
4711 had a 50-1 reverse stock split. Not sure how connected these were.)
4712 So I don't trust someone not to have an unpredictable UDP stack.
4716 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4717 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4721 FD_SET((unsigned int)sockets[0], &rset);
4722 FD_SET((unsigned int)sockets[1], &rset);
4724 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4725 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4726 || !FD_ISSET(sockets[1], &rset)) {
4727 /* I hope this is portable and appropriate. */
4729 goto tidy_up_and_fail;
4730 goto abort_tidy_up_and_fail;
4734 /* And the paranoia department even now doesn't trust it to have arrive
4735 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4737 struct sockaddr_in readfrom;
4738 unsigned short buffer[2];
4743 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4744 sizeof(buffer), MSG_DONTWAIT,
4745 (struct sockaddr *) &readfrom, &size);
4747 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4749 (struct sockaddr *) &readfrom, &size);
4753 goto tidy_up_and_fail;
4754 if (got != sizeof(port)
4755 || size != sizeof(struct sockaddr_in)
4756 /* Check other socket sent us its port. */
4757 || buffer[0] != (unsigned short) addresses[!i].sin_port
4758 /* Check kernel says we got the datagram from that socket */
4759 || readfrom.sin_family != addresses[!i].sin_family
4760 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4761 || readfrom.sin_port != addresses[!i].sin_port)
4762 goto abort_tidy_up_and_fail;
4765 /* My caller (my_socketpair) has validated that this is non-NULL */
4768 /* I hereby declare this connection open. May God bless all who cross
4772 abort_tidy_up_and_fail:
4773 errno = ECONNABORTED;
4776 const int save_errno = errno;
4777 if (sockets[0] != -1)
4778 PerlLIO_close(sockets[0]);
4779 if (sockets[1] != -1)
4780 PerlLIO_close(sockets[1]);
4785 #endif /* EMULATE_SOCKETPAIR_UDP */
4787 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4789 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4790 /* Stevens says that family must be AF_LOCAL, protocol 0.
4791 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4796 struct sockaddr_in listen_addr;
4797 struct sockaddr_in connect_addr;
4802 || family != AF_UNIX
4805 errno = EAFNOSUPPORT;
4813 #ifdef EMULATE_SOCKETPAIR_UDP
4814 if (type == SOCK_DGRAM)
4815 return S_socketpair_udp(fd);
4818 listener = PerlSock_socket(AF_INET, type, 0);
4821 memset(&listen_addr, 0, sizeof(listen_addr));
4822 listen_addr.sin_family = AF_INET;
4823 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4824 listen_addr.sin_port = 0; /* kernel choses port. */
4825 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4826 sizeof(listen_addr)) == -1)
4827 goto tidy_up_and_fail;
4828 if (PerlSock_listen(listener, 1) == -1)
4829 goto tidy_up_and_fail;
4831 connector = PerlSock_socket(AF_INET, type, 0);
4832 if (connector == -1)
4833 goto tidy_up_and_fail;
4834 /* We want to find out the port number to connect to. */
4835 size = sizeof(connect_addr);
4836 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4838 goto tidy_up_and_fail;
4839 if (size != sizeof(connect_addr))
4840 goto abort_tidy_up_and_fail;
4841 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4842 sizeof(connect_addr)) == -1)
4843 goto tidy_up_and_fail;
4845 size = sizeof(listen_addr);
4846 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4849 goto tidy_up_and_fail;
4850 if (size != sizeof(listen_addr))
4851 goto abort_tidy_up_and_fail;
4852 PerlLIO_close(listener);
4853 /* Now check we are talking to ourself by matching port and host on the
4855 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4857 goto tidy_up_and_fail;
4858 if (size != sizeof(connect_addr)
4859 || listen_addr.sin_family != connect_addr.sin_family
4860 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4861 || listen_addr.sin_port != connect_addr.sin_port) {
4862 goto abort_tidy_up_and_fail;
4868 abort_tidy_up_and_fail:
4870 errno = ECONNABORTED; /* This would be the standard thing to do. */
4872 # ifdef ECONNREFUSED
4873 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4875 errno = ETIMEDOUT; /* Desperation time. */
4880 const int save_errno = errno;
4882 PerlLIO_close(listener);
4883 if (connector != -1)
4884 PerlLIO_close(connector);
4886 PerlLIO_close(acceptor);
4892 /* In any case have a stub so that there's code corresponding
4893 * to the my_socketpair in global.sym. */
4895 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4896 #ifdef HAS_SOCKETPAIR
4897 return socketpair(family, type, protocol, fd);
4906 =for apidoc sv_nosharing
4908 Dummy routine which "shares" an SV when there is no sharing module present.
4909 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4910 Exists to avoid test for a NULL function pointer and because it could
4911 potentially warn under some level of strict-ness.
4917 Perl_sv_nosharing(pTHX_ SV *sv)
4919 PERL_UNUSED_CONTEXT;
4920 PERL_UNUSED_ARG(sv);
4924 Perl_parse_unicode_opts(pTHX_ const char **popt)
4926 const char *p = *popt;
4931 opt = (U32) atoi(p);
4934 if (*p && *p != '\n' && *p != '\r')
4935 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4940 case PERL_UNICODE_STDIN:
4941 opt |= PERL_UNICODE_STDIN_FLAG; break;
4942 case PERL_UNICODE_STDOUT:
4943 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4944 case PERL_UNICODE_STDERR:
4945 opt |= PERL_UNICODE_STDERR_FLAG; break;
4946 case PERL_UNICODE_STD:
4947 opt |= PERL_UNICODE_STD_FLAG; break;
4948 case PERL_UNICODE_IN:
4949 opt |= PERL_UNICODE_IN_FLAG; break;
4950 case PERL_UNICODE_OUT:
4951 opt |= PERL_UNICODE_OUT_FLAG; break;
4952 case PERL_UNICODE_INOUT:
4953 opt |= PERL_UNICODE_INOUT_FLAG; break;
4954 case PERL_UNICODE_LOCALE:
4955 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4956 case PERL_UNICODE_ARGV:
4957 opt |= PERL_UNICODE_ARGV_FLAG; break;
4958 case PERL_UNICODE_UTF8CACHEASSERT:
4959 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4961 if (*p != '\n' && *p != '\r')
4963 "Unknown Unicode option letter '%c'", *p);
4969 opt = PERL_UNICODE_DEFAULT_FLAGS;
4971 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4972 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4973 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4985 * This is really just a quick hack which grabs various garbage
4986 * values. It really should be a real hash algorithm which
4987 * spreads the effect of every input bit onto every output bit,
4988 * if someone who knows about such things would bother to write it.
4989 * Might be a good idea to add that function to CORE as well.
4990 * No numbers below come from careful analysis or anything here,
4991 * except they are primes and SEED_C1 > 1E6 to get a full-width
4992 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4993 * probably be bigger too.
4996 # define SEED_C1 1000003
4997 #define SEED_C4 73819
4999 # define SEED_C1 25747
5000 #define SEED_C4 20639
5004 #define SEED_C5 26107
5006 #ifndef PERL_NO_DEV_RANDOM
5011 # include <starlet.h>
5012 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5013 * in 100-ns units, typically incremented ever 10 ms. */
5014 unsigned int when[2];
5016 # ifdef HAS_GETTIMEOFDAY
5017 struct timeval when;
5023 /* This test is an escape hatch, this symbol isn't set by Configure. */
5024 #ifndef PERL_NO_DEV_RANDOM
5025 #ifndef PERL_RANDOM_DEVICE
5026 /* /dev/random isn't used by default because reads from it will block
5027 * if there isn't enough entropy available. You can compile with
5028 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5029 * is enough real entropy to fill the seed. */
5030 # define PERL_RANDOM_DEVICE "/dev/urandom"
5032 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5034 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5043 _ckvmssts(sys$gettim(when));
5044 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5046 # ifdef HAS_GETTIMEOFDAY
5047 PerlProc_gettimeofday(&when,NULL);
5048 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5051 u = (U32)SEED_C1 * when;
5054 u += SEED_C3 * (U32)PerlProc_getpid();
5055 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5056 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5057 u += SEED_C5 * (U32)PTR2UV(&when);
5063 Perl_get_hash_seed(pTHX)
5066 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5072 if (s && isDIGIT(*s))
5073 myseed = (UV)Atoul(s);
5075 #ifdef USE_HASH_SEED_EXPLICIT
5079 /* Compute a random seed */
5080 (void)seedDrand01((Rand_seed_t)seed());
5081 myseed = (UV)(Drand01() * (NV)UV_MAX);
5082 #if RANDBITS < (UVSIZE * 8)
5083 /* Since there are not enough randbits to to reach all
5084 * the bits of a UV, the low bits might need extra
5085 * help. Sum in another random number that will
5086 * fill in the low bits. */
5088 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5089 #endif /* RANDBITS < (UVSIZE * 8) */
5090 if (myseed == 0) { /* Superparanoia. */
5091 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5093 Perl_croak(aTHX_ "Your random numbers are not that random");
5096 PL_rehash_seed_set = TRUE;
5103 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5105 const char * const stashpv = CopSTASHPV(c);
5106 const char * const name = HvNAME_get(hv);
5107 PERL_UNUSED_CONTEXT;
5109 if (stashpv == name)
5111 if (stashpv && name)
5112 if (strEQ(stashpv, name))
5119 #ifdef PERL_GLOBAL_STRUCT
5122 Perl_init_global_struct(pTHX)
5124 struct perl_vars *plvarsp = NULL;
5125 #ifdef PERL_GLOBAL_STRUCT
5126 # define PERL_GLOBAL_STRUCT_INIT
5127 # include "opcode.h" /* the ppaddr and check */
5128 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5129 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5130 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5131 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5132 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5136 plvarsp = PL_VarsPtr;
5137 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5143 # define PERLVAR(var,type) /**/
5144 # define PERLVARA(var,n,type) /**/
5145 # define PERLVARI(var,type,init) plvarsp->var = init;
5146 # define PERLVARIC(var,type,init) plvarsp->var = init;
5147 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5148 # include "perlvars.h"
5154 # ifdef PERL_GLOBAL_STRUCT
5155 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5156 if (!plvarsp->Gppaddr)
5158 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5159 if (!plvarsp->Gcheck)
5161 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5162 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5164 # ifdef PERL_SET_VARS
5165 PERL_SET_VARS(plvarsp);
5167 # undef PERL_GLOBAL_STRUCT_INIT
5172 #endif /* PERL_GLOBAL_STRUCT */
5174 #ifdef PERL_GLOBAL_STRUCT
5177 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5179 #ifdef PERL_GLOBAL_STRUCT
5180 # ifdef PERL_UNSET_VARS
5181 PERL_UNSET_VARS(plvarsp);
5183 free(plvarsp->Gppaddr);
5184 free(plvarsp->Gcheck);
5185 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5191 #endif /* PERL_GLOBAL_STRUCT */
5196 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5198 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5199 * variable PERL_MEM_LOG will be consulted, and if the integer value
5200 * of that is true, the logging will happen. (The default is to
5201 * always log if the PERL_MEM_LOG define was in effect.)
5205 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5206 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5208 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5211 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5212 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5213 * in which case the environment variable PERL_MEM_LOG_FD will be
5214 * consulted for the file descriptor number to use.
5216 #ifndef PERL_MEM_LOG_FD
5217 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5221 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)
5223 #ifdef PERL_MEM_LOG_STDERR
5224 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5227 # ifdef PERL_MEM_LOG_ENV
5228 s = getenv("PERL_MEM_LOG");
5229 if (s ? atoi(s) : 0)
5232 /* We can't use SVs or PerlIO for obvious reasons,
5233 * so we'll use stdio and low-level IO instead. */
5234 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5235 # ifdef PERL_MEM_LOG_TIMESTAMP
5237 # ifdef HAS_GETTIMEOFDAY
5238 gettimeofday(&tv, 0);
5240 /* If there are other OS specific ways of hires time than
5241 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5242 * probably that they would be used to fill in the struct
5249 # ifdef PERL_MEM_LOG_TIMESTAMP
5252 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5253 " %s = %"IVdf": %"UVxf"\n",
5254 # ifdef PERL_MEM_LOG_TIMESTAMP
5255 (int)tv.tv_sec, (int)tv.tv_usec,
5257 filename, linenumber, funcname, n, typesize,
5258 typename, n * typesize, PTR2UV(newalloc));
5259 # ifdef PERL_MEM_LOG_ENV_FD
5260 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5261 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5263 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5272 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)
5274 #ifdef PERL_MEM_LOG_STDERR
5275 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5278 # ifdef PERL_MEM_LOG_ENV
5279 s = PerlEnv_getenv("PERL_MEM_LOG");
5280 if (s ? atoi(s) : 0)
5283 /* We can't use SVs or PerlIO for obvious reasons,
5284 * so we'll use stdio and low-level IO instead. */
5285 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5286 # ifdef PERL_MEM_LOG_TIMESTAMP
5288 gettimeofday(&tv, 0);
5294 # ifdef PERL_MEM_LOG_TIMESTAMP
5297 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5298 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5299 # ifdef PERL_MEM_LOG_TIMESTAMP
5300 (int)tv.tv_sec, (int)tv.tv_usec,
5302 filename, linenumber, funcname, n, typesize,
5303 typename, n * typesize, PTR2UV(oldalloc),
5305 # ifdef PERL_MEM_LOG_ENV_FD
5306 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5307 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5309 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5318 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5320 #ifdef PERL_MEM_LOG_STDERR
5321 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5324 # ifdef PERL_MEM_LOG_ENV
5325 s = PerlEnv_getenv("PERL_MEM_LOG");
5326 if (s ? atoi(s) : 0)
5329 /* We can't use SVs or PerlIO for obvious reasons,
5330 * so we'll use stdio and low-level IO instead. */
5331 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5332 # ifdef PERL_MEM_LOG_TIMESTAMP
5334 gettimeofday(&tv, 0);
5340 # ifdef PERL_MEM_LOG_TIMESTAMP
5343 "free: %s:%d:%s: %"UVxf"\n",
5344 # ifdef PERL_MEM_LOG_TIMESTAMP
5345 (int)tv.tv_sec, (int)tv.tv_usec,
5347 filename, linenumber, funcname,
5349 # ifdef PERL_MEM_LOG_ENV_FD
5350 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5351 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5353 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5361 #endif /* PERL_MEM_LOG */
5364 =for apidoc my_sprintf
5366 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5367 the length of the string written to the buffer. Only rare pre-ANSI systems
5368 need the wrapper function - usually this is a direct call to C<sprintf>.
5372 #ifndef SPRINTF_RETURNS_STRLEN
5374 Perl_my_sprintf(char *buffer, const char* pat, ...)
5377 va_start(args, pat);
5378 vsprintf(buffer, pat, args);
5380 return strlen(buffer);
5385 =for apidoc my_snprintf
5387 The C library C<snprintf> functionality, if available and
5388 standards-compliant (uses C<vsnprintf>, actually). However, if the
5389 C<vsnprintf> is not available, will unfortunately use the unsafe
5390 C<vsprintf> which can overrun the buffer (there is an overrun check,
5391 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5392 getting C<vsnprintf>.
5397 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5402 va_start(ap, format);
5403 #ifdef HAS_VSNPRINTF
5404 retval = vsnprintf(buffer, len, format, ap);
5406 retval = vsprintf(buffer, format, ap);
5409 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5410 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5411 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5416 =for apidoc my_vsnprintf
5418 The C library C<vsnprintf> if available and standards-compliant.
5419 However, if if the C<vsnprintf> is not available, will unfortunately
5420 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5421 overrun check, but that may be too late). Consider using
5422 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5427 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5433 Perl_va_copy(ap, apc);
5434 # ifdef HAS_VSNPRINTF
5435 retval = vsnprintf(buffer, len, format, apc);
5437 retval = vsprintf(buffer, format, apc);
5440 # ifdef HAS_VSNPRINTF
5441 retval = vsnprintf(buffer, len, format, ap);
5443 retval = vsprintf(buffer, format, ap);
5445 #endif /* #ifdef NEED_VA_COPY */
5446 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5447 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5448 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5453 Perl_my_clearenv(pTHX)
5456 #if ! defined(PERL_MICRO)
5457 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5459 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5460 # if defined(USE_ENVIRON_ARRAY)
5461 # if defined(USE_ITHREADS)
5462 /* only the parent thread can clobber the process environment */
5463 if (PL_curinterp == aTHX)
5464 # endif /* USE_ITHREADS */
5466 # if ! defined(PERL_USE_SAFE_PUTENV)
5467 if ( !PL_use_safe_putenv) {
5469 if (environ == PL_origenviron)
5470 environ = (char**)safesysmalloc(sizeof(char*));
5472 for (i = 0; environ[i]; i++)
5473 (void)safesysfree(environ[i]);
5476 # else /* PERL_USE_SAFE_PUTENV */
5477 # if defined(HAS_CLEARENV)
5479 # elif defined(HAS_UNSETENV)
5480 int bsiz = 80; /* Most envvar names will be shorter than this. */
5481 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5482 char *buf = (char*)safesysmalloc(bufsiz);
5483 while (*environ != NULL) {
5484 char *e = strchr(*environ, '=');
5485 int l = e ? e - *environ : (int)strlen(*environ);
5487 (void)safesysfree(buf);
5488 bsiz = l + 1; /* + 1 for the \0. */
5489 buf = (char*)safesysmalloc(bufsiz);
5491 my_strlcpy(buf, *environ, l + 1);
5492 (void)unsetenv(buf);
5494 (void)safesysfree(buf);
5495 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5496 /* Just null environ and accept the leakage. */
5498 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5499 # endif /* ! PERL_USE_SAFE_PUTENV */
5501 # endif /* USE_ENVIRON_ARRAY */
5502 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5503 #endif /* PERL_MICRO */
5506 #ifdef PERL_IMPLICIT_CONTEXT
5508 /* implements the MY_CXT_INIT macro. The first time a module is loaded,
5509 the global PL_my_cxt_index is incremented, and that value is assigned to
5510 that module's static my_cxt_index (who's address is passed as an arg).
5511 Then, for each interpreter this function is called for, it makes sure a
5512 void* slot is available to hang the static data off, by allocating or
5513 extending the interpreter's PL_my_cxt_list array */
5516 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5521 /* this module hasn't been allocated an index yet */
5522 MUTEX_LOCK(&PL_my_ctx_mutex);
5523 *index = PL_my_cxt_index++;
5524 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5527 /* make sure the array is big enough */
5528 if (PL_my_cxt_size <= *index) {
5529 if (PL_my_cxt_size) {
5530 while (PL_my_cxt_size <= *index)
5531 PL_my_cxt_size *= 2;
5532 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5535 PL_my_cxt_size = 16;
5536 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5539 /* newSV() allocates one more than needed */
5540 p = (void*)SvPVX(newSV(size-1));
5541 PL_my_cxt_list[*index] = p;
5542 Zero(p, size, char);
5549 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5551 Size_t used, length, copy;
5554 length = strlen(src);
5555 if (size > 0 && used < size - 1) {
5556 copy = (length >= size - used) ? size - used - 1 : length;
5557 memcpy(dst + used, src, copy);
5558 dst[used + copy] = '\0';
5560 return used + length;
5566 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5568 Size_t length, copy;
5570 length = strlen(src);
5572 copy = (length >= size) ? size - 1 : length;
5573 memcpy(dst, src, copy);
5581 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5584 SV * const dbsv = GvSVn(PL_DBsub);
5585 /* We do not care about using sv to call CV;
5586 * it's for informational purposes only.
5590 if (!PERLDB_SUB_NN) {
5591 GV * const gv = CvGV(cv);
5593 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5594 || strEQ(GvNAME(gv), "END")
5595 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5596 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5597 /* Use GV from the stack as a fallback. */
5598 /* GV is potentially non-unique, or contain different CV. */
5599 SV * const tmp = newRV((SV*)cv);
5600 sv_setsv(dbsv, tmp);
5604 gv_efullname3(dbsv, gv, NULL);
5608 const int type = SvTYPE(dbsv);
5609 if (type < SVt_PVIV && type != SVt_IV)
5610 sv_upgrade(dbsv, SVt_PVIV);
5611 (void)SvIOK_on(dbsv);
5612 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5618 * c-indentation-style: bsd
5620 * indent-tabs-mode: t
5623 * ex: set ts=8 sts=4 sw=4 noet: