3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
16 /* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
23 #define PERL_IN_UTIL_C
29 # define SIG_ERR ((Sighandler_t) -1)
34 /* Missing protos on LynxOS */
39 # include <sys/wait.h>
44 # include <sys/select.h>
50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51 # define FD_CLOEXEC 1 /* NeXT needs this */
54 /* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
64 /* Can't use PerlIO to write as it allocates memory */
65 PerlLIO_write(PerlIO_fileno(Perl_error_log),
66 PL_no_mem, strlen(PL_no_mem));
68 NORETURN_FUNCTION_END;
71 /* paranoid version of system's malloc() */
74 Perl_safesysmalloc(MEM_SIZE size)
80 PerlIO_printf(Perl_error_log,
81 "Allocation too large: %lx\n", size) FLUSH;
84 #endif /* HAS_64K_LIMIT */
85 #ifdef PERL_TRACK_MEMPOOL
90 Perl_croak_nocontext("panic: malloc");
92 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
93 PERL_ALLOC_CHECK(ptr);
94 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
96 #ifdef PERL_TRACK_MEMPOOL
97 struct perl_memory_debug_header *const header
98 = (struct perl_memory_debug_header *)ptr;
102 PoisonNew(((char *)ptr), size, char);
105 #ifdef PERL_TRACK_MEMPOOL
106 header->interpreter = aTHX;
107 /* Link us into the list. */
108 header->prev = &PL_memory_debug_header;
109 header->next = PL_memory_debug_header.next;
110 PL_memory_debug_header.next = header;
111 header->next->prev = header;
115 ptr = (Malloc_t)((char*)ptr+sTHX);
122 return write_no_mem();
127 /* paranoid version of system's realloc() */
130 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
134 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
135 Malloc_t PerlMem_realloc();
136 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
140 PerlIO_printf(Perl_error_log,
141 "Reallocation too large: %lx\n", size) FLUSH;
144 #endif /* HAS_64K_LIMIT */
151 return safesysmalloc(size);
152 #ifdef PERL_TRACK_MEMPOOL
153 where = (Malloc_t)((char*)where-sTHX);
156 struct perl_memory_debug_header *const header
157 = (struct perl_memory_debug_header *)where;
159 if (header->interpreter != aTHX) {
160 Perl_croak_nocontext("panic: realloc from wrong pool");
162 assert(header->next->prev == header);
163 assert(header->prev->next == header);
165 if (header->size > size) {
166 const MEM_SIZE freed_up = header->size - size;
167 char *start_of_freed = ((char *)where) + size;
168 PoisonFree(start_of_freed, freed_up, char);
176 Perl_croak_nocontext("panic: realloc");
178 ptr = (Malloc_t)PerlMem_realloc(where,size);
179 PERL_ALLOC_CHECK(ptr);
181 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
182 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
185 #ifdef PERL_TRACK_MEMPOOL
186 struct perl_memory_debug_header *const header
187 = (struct perl_memory_debug_header *)ptr;
190 if (header->size < size) {
191 const MEM_SIZE fresh = size - header->size;
192 char *start_of_fresh = ((char *)ptr) + size;
193 PoisonNew(start_of_fresh, fresh, char);
197 header->next->prev = header;
198 header->prev->next = header;
200 ptr = (Malloc_t)((char*)ptr+sTHX);
207 return write_no_mem();
212 /* safe version of system's free() */
215 Perl_safesysfree(Malloc_t where)
217 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
222 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
224 #ifdef PERL_TRACK_MEMPOOL
225 where = (Malloc_t)((char*)where-sTHX);
227 struct perl_memory_debug_header *const header
228 = (struct perl_memory_debug_header *)where;
230 if (header->interpreter != aTHX) {
231 Perl_croak_nocontext("panic: free from wrong pool");
234 Perl_croak_nocontext("panic: duplicate free");
236 if (!(header->next) || header->next->prev != header
237 || header->prev->next != header) {
238 Perl_croak_nocontext("panic: bad free");
240 /* Unlink us from the chain. */
241 header->next->prev = header->prev;
242 header->prev->next = header->next;
244 PoisonNew(where, header->size, char);
246 /* Trigger the duplicate free warning. */
254 /* safe version of system's calloc() */
257 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
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_PVGV);
498 const unsigned char *sb;
499 const U8 mlen = (len>255) ? 255 : (U8)len;
502 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
504 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
505 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
506 memset((void*)table, mlen, 256);
507 BmFLAGS(sv) = (U8)flags;
509 sb = s - mlen + 1; /* first char (maybe) */
511 if (table[*s] == mlen)
516 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
518 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
520 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
521 for (i = 0; i < len; i++) {
522 if (PL_freq[s[i]] < frequency) {
524 frequency = PL_freq[s[i]];
527 BmRARE(sv) = s[rarest];
528 BmPREVIOUS(sv) = rarest;
529 BmUSEFUL(sv) = 100; /* Initial value */
530 if (flags & FBMcf_TAIL)
532 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
533 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
536 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
537 /* If SvTAIL is actually due to \Z or \z, this gives false positives
541 =for apidoc fbm_instr
543 Returns the location of the SV in the string delimited by C<str> and
544 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
545 does not have to be fbm_compiled, but the search will not be as fast
552 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
554 register unsigned char *s;
556 register const unsigned char *little
557 = (const unsigned char *)SvPV_const(littlestr,l);
558 register STRLEN littlelen = l;
559 register const I32 multiline = flags & FBMrf_MULTILINE;
561 if ((STRLEN)(bigend - big) < littlelen) {
562 if ( SvTAIL(littlestr)
563 && ((STRLEN)(bigend - big) == littlelen - 1)
565 || (*big == *little &&
566 memEQ((char *)big, (char *)little, littlelen - 1))))
571 if (littlelen <= 2) { /* Special-cased */
573 if (littlelen == 1) {
574 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
575 /* Know that bigend != big. */
576 if (bigend[-1] == '\n')
577 return (char *)(bigend - 1);
578 return (char *) bigend;
586 if (SvTAIL(littlestr))
587 return (char *) bigend;
591 return (char*)big; /* Cannot be SvTAIL! */
594 if (SvTAIL(littlestr) && !multiline) {
595 if (bigend[-1] == '\n' && bigend[-2] == *little)
596 return (char*)bigend - 2;
597 if (bigend[-1] == *little)
598 return (char*)bigend - 1;
602 /* This should be better than FBM if c1 == c2, and almost
603 as good otherwise: maybe better since we do less indirection.
604 And we save a lot of memory by caching no table. */
605 const unsigned char c1 = little[0];
606 const unsigned char c2 = little[1];
611 while (s <= bigend) {
621 goto check_1char_anchor;
632 goto check_1char_anchor;
635 while (s <= bigend) {
640 goto check_1char_anchor;
649 check_1char_anchor: /* One char and anchor! */
650 if (SvTAIL(littlestr) && (*bigend == *little))
651 return (char *)bigend; /* bigend is already decremented. */
654 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
655 s = bigend - littlelen;
656 if (s >= big && bigend[-1] == '\n' && *s == *little
657 /* Automatically of length > 2 */
658 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
660 return (char*)s; /* how sweet it is */
663 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
665 return (char*)s + 1; /* how sweet it is */
669 if (!SvVALID(littlestr)) {
670 char * const b = ninstr((char*)big,(char*)bigend,
671 (char*)little, (char*)little + littlelen);
673 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
674 /* Chop \n from littlestr: */
675 s = bigend - littlelen + 1;
677 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
687 if (littlelen > (STRLEN)(bigend - big))
691 register const unsigned char * const table
692 = little + littlelen + PERL_FBM_TABLE_OFFSET;
693 register const unsigned char *oldlittle;
695 --littlelen; /* Last char found by table lookup */
698 little += littlelen; /* last char */
704 if ((tmp = table[*s])) {
705 if ((s += tmp) < bigend)
709 else { /* less expensive than calling strncmp() */
710 register unsigned char * const olds = s;
715 if (*--s == *--little)
717 s = olds + 1; /* here we pay the price for failure */
719 if (s < bigend) /* fake up continue to outer loop */
728 && (BmFLAGS(littlestr) & FBMcf_TAIL)
729 && memEQ((char *)(bigend - littlelen),
730 (char *)(oldlittle - littlelen), littlelen) )
731 return (char*)bigend - littlelen;
736 /* start_shift, end_shift are positive quantities which give offsets
737 of ends of some substring of bigstr.
738 If "last" we want the last occurrence.
739 old_posp is the way of communication between consequent calls if
740 the next call needs to find the .
741 The initial *old_posp should be -1.
743 Note that we take into account SvTAIL, so one can get extra
744 optimizations if _ALL flag is set.
747 /* If SvTAIL is actually due to \Z or \z, this gives false positives
748 if PL_multiline. In fact if !PL_multiline the authoritative answer
749 is not supported yet. */
752 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
755 register const unsigned char *big;
757 register I32 previous;
759 register const unsigned char *little;
760 register I32 stop_pos;
761 register const unsigned char *littleend;
764 assert(SvTYPE(littlestr) == SVt_PVGV);
765 assert(SvVALID(littlestr));
768 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
769 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
771 if ( BmRARE(littlestr) == '\n'
772 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
773 little = (const unsigned char *)(SvPVX_const(littlestr));
774 littleend = little + SvCUR(littlestr);
781 little = (const unsigned char *)(SvPVX_const(littlestr));
782 littleend = little + SvCUR(littlestr);
784 /* The value of pos we can start at: */
785 previous = BmPREVIOUS(littlestr);
786 big = (const unsigned char *)(SvPVX_const(bigstr));
787 /* The value of pos we can stop at: */
788 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
789 if (previous + start_shift > stop_pos) {
791 stop_pos does not include SvTAIL in the count, so this check is incorrect
792 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
795 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
800 while (pos < previous + start_shift) {
801 if (!(pos += PL_screamnext[pos]))
806 register const unsigned char *s, *x;
807 if (pos >= stop_pos) break;
808 if (big[pos] != first)
810 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
816 if (s == littleend) {
818 if (!last) return (char *)(big+pos);
821 } while ( pos += PL_screamnext[pos] );
823 return (char *)(big+(*old_posp));
825 if (!SvTAIL(littlestr) || (end_shift > 0))
827 /* Ignore the trailing "\n". This code is not microoptimized */
828 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
829 stop_pos = littleend - little; /* Actual littlestr len */
834 && ((stop_pos == 1) ||
835 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
841 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
843 register const U8 *a = (const U8 *)s1;
844 register const U8 *b = (const U8 *)s2;
848 if (*a != *b && *a != PL_fold[*b])
856 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
859 register const U8 *a = (const U8 *)s1;
860 register const U8 *b = (const U8 *)s2;
864 if (*a != *b && *a != PL_fold_locale[*b])
871 /* copy a string to a safe spot */
874 =head1 Memory Management
878 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
879 string which is a duplicate of C<pv>. The size of the string is
880 determined by C<strlen()>. The memory allocated for the new string can
881 be freed with the C<Safefree()> function.
887 Perl_savepv(pTHX_ const char *pv)
894 const STRLEN pvlen = strlen(pv)+1;
895 Newx(newaddr, pvlen, char);
896 return (char*)memcpy(newaddr, pv, pvlen);
900 /* same thing but with a known length */
905 Perl's version of what C<strndup()> would be if it existed. Returns a
906 pointer to a newly allocated string which is a duplicate of the first
907 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
908 the new string can be freed with the C<Safefree()> function.
914 Perl_savepvn(pTHX_ const char *pv, register I32 len)
916 register char *newaddr;
919 Newx(newaddr,len+1,char);
920 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
922 /* might not be null terminated */
924 return (char *) CopyD(pv,newaddr,len,char);
927 return (char *) ZeroD(newaddr,len+1,char);
932 =for apidoc savesharedpv
934 A version of C<savepv()> which allocates the duplicate string in memory
935 which is shared between threads.
940 Perl_savesharedpv(pTHX_ const char *pv)
942 register char *newaddr;
947 pvlen = strlen(pv)+1;
948 newaddr = (char*)PerlMemShared_malloc(pvlen);
950 return write_no_mem();
952 return (char*)memcpy(newaddr, pv, pvlen);
956 =for apidoc savesharedpvn
958 A version of C<savepvn()> which allocates the duplicate string in memory
959 which is shared between threads. (With the specific difference that a NULL
960 pointer is not acceptable)
965 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
967 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
970 return write_no_mem();
973 return (char*)memcpy(newaddr, pv, len);
979 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
980 the passed in SV using C<SvPV()>
986 Perl_savesvpv(pTHX_ SV *sv)
989 const char * const pv = SvPV_const(sv, len);
990 register char *newaddr;
993 Newx(newaddr,len,char);
994 return (char *) CopyD(pv,newaddr,len,char);
998 /* the SV for Perl_form() and mess() is not kept in an arena */
1008 return sv_2mortal(newSVpvs(""));
1013 /* Create as PVMG now, to avoid any upgrading later */
1015 Newxz(any, 1, XPVMG);
1016 SvFLAGS(sv) = SVt_PVMG;
1017 SvANY(sv) = (void*)any;
1019 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1024 #if defined(PERL_IMPLICIT_CONTEXT)
1026 Perl_form_nocontext(const char* pat, ...)
1031 va_start(args, pat);
1032 retval = vform(pat, &args);
1036 #endif /* PERL_IMPLICIT_CONTEXT */
1039 =head1 Miscellaneous Functions
1042 Takes a sprintf-style format pattern and conventional
1043 (non-SV) arguments and returns the formatted string.
1045 (char *) Perl_form(pTHX_ const char* pat, ...)
1047 can be used any place a string (char *) is required:
1049 char * s = Perl_form("%d.%d",major,minor);
1051 Uses a single private buffer so if you want to format several strings you
1052 must explicitly copy the earlier strings away (and free the copies when you
1059 Perl_form(pTHX_ const char* pat, ...)
1063 va_start(args, pat);
1064 retval = vform(pat, &args);
1070 Perl_vform(pTHX_ const char *pat, va_list *args)
1072 SV * const sv = mess_alloc();
1073 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1077 #if defined(PERL_IMPLICIT_CONTEXT)
1079 Perl_mess_nocontext(const char *pat, ...)
1084 va_start(args, pat);
1085 retval = vmess(pat, &args);
1089 #endif /* PERL_IMPLICIT_CONTEXT */
1092 Perl_mess(pTHX_ const char *pat, ...)
1096 va_start(args, pat);
1097 retval = vmess(pat, &args);
1103 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1106 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1108 if (!o || o == PL_op)
1111 if (o->op_flags & OPf_KIDS) {
1113 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1116 /* If the OP_NEXTSTATE has been optimised away we can still use it
1117 * the get the file and line number. */
1119 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1120 cop = (const COP *)kid;
1122 /* Keep searching, and return when we've found something. */
1124 new_cop = closest_cop(cop, kid);
1130 /* Nothing found. */
1136 Perl_vmess(pTHX_ const char *pat, va_list *args)
1139 SV * const sv = mess_alloc();
1141 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1142 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1144 * Try and find the file and line for PL_op. This will usually be
1145 * PL_curcop, but it might be a cop that has been optimised away. We
1146 * can try to find such a cop by searching through the optree starting
1147 * from the sibling of PL_curcop.
1150 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1155 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1156 OutCopFILE(cop), (IV)CopLINE(cop));
1157 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1158 const bool line_mode = (RsSIMPLE(PL_rs) &&
1159 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1160 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1161 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1162 line_mode ? "line" : "chunk",
1163 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1166 sv_catpvs(sv, " during global destruction");
1167 sv_catpvs(sv, ".\n");
1173 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1179 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1180 && (io = GvIO(PL_stderrgv))
1181 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1188 SAVESPTR(PL_stderrgv);
1191 PUSHSTACKi(PERLSI_MAGIC);
1195 PUSHs(SvTIED_obj((SV*)io, mg));
1196 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1198 call_method("PRINT", G_SCALAR);
1206 /* SFIO can really mess with your errno */
1207 const int e = errno;
1209 PerlIO * const serr = Perl_error_log;
1211 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1212 (void)PerlIO_flush(serr);
1219 /* Common code used by vcroak, vdie, vwarn and vwarner */
1222 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
1228 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1229 /* sv_2cv might call Perl_croak() or Perl_warner() */
1230 SV * const oldhook = *hook;
1237 cv = sv_2cv(oldhook, &stash, &gv, 0);
1239 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1249 if (warn || message) {
1250 msg = newSVpvn(message, msglen);
1251 SvFLAGS(msg) |= utf8;
1259 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1263 call_sv((SV*)cv, G_DISCARD);
1272 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1276 const char *message;
1279 SV * const msv = vmess(pat, args);
1280 if (PL_errors && SvCUR(PL_errors)) {
1281 sv_catsv(PL_errors, msv);
1282 message = SvPV_const(PL_errors, *msglen);
1283 SvCUR_set(PL_errors, 0);
1286 message = SvPV_const(msv,*msglen);
1287 *utf8 = SvUTF8(msv);
1293 DEBUG_S(PerlIO_printf(Perl_debug_log,
1294 "%p: die/croak: message = %s\ndiehook = %p\n",
1295 (void*)thr, message, (void*)PL_diehook));
1297 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1303 Perl_vdie(pTHX_ const char* pat, va_list *args)
1306 const char *message;
1307 const int was_in_eval = PL_in_eval;
1311 DEBUG_S(PerlIO_printf(Perl_debug_log,
1312 "%p: die: curstack = %p, mainstack = %p\n",
1313 (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
1315 message = vdie_croak_common(pat, args, &msglen, &utf8);
1317 PL_restartop = die_where(message, msglen);
1318 SvFLAGS(ERRSV) |= utf8;
1319 DEBUG_S(PerlIO_printf(Perl_debug_log,
1320 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1321 (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env));
1322 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1324 return PL_restartop;
1327 #if defined(PERL_IMPLICIT_CONTEXT)
1329 Perl_die_nocontext(const char* pat, ...)
1334 va_start(args, pat);
1335 o = vdie(pat, &args);
1339 #endif /* PERL_IMPLICIT_CONTEXT */
1342 Perl_die(pTHX_ const char* pat, ...)
1346 va_start(args, pat);
1347 o = vdie(pat, &args);
1353 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1356 const char *message;
1360 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1363 PL_restartop = die_where(message, msglen);
1364 SvFLAGS(ERRSV) |= utf8;
1368 message = SvPVx_const(ERRSV, msglen);
1370 write_to_stderr(message, msglen);
1374 #if defined(PERL_IMPLICIT_CONTEXT)
1376 Perl_croak_nocontext(const char *pat, ...)
1380 va_start(args, pat);
1385 #endif /* PERL_IMPLICIT_CONTEXT */
1388 =head1 Warning and Dieing
1392 This is the XSUB-writer's interface to Perl's C<die> function.
1393 Normally call this function the same way you call the C C<printf>
1394 function. Calling C<croak> returns control directly to Perl,
1395 sidestepping the normal C order of execution. See C<warn>.
1397 If you want to throw an exception object, assign the object to
1398 C<$@> and then pass C<NULL> to croak():
1400 errsv = get_sv("@", TRUE);
1401 sv_setsv(errsv, exception_object);
1408 Perl_croak(pTHX_ const char *pat, ...)
1411 va_start(args, pat);
1418 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1422 SV * const msv = vmess(pat, args);
1423 const I32 utf8 = SvUTF8(msv);
1424 const char * const message = SvPV_const(msv, msglen);
1427 if (vdie_common(message, msglen, utf8, TRUE))
1431 write_to_stderr(message, msglen);
1434 #if defined(PERL_IMPLICIT_CONTEXT)
1436 Perl_warn_nocontext(const char *pat, ...)
1440 va_start(args, pat);
1444 #endif /* PERL_IMPLICIT_CONTEXT */
1449 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1450 function the same way you call the C C<printf> function. See C<croak>.
1456 Perl_warn(pTHX_ const char *pat, ...)
1459 va_start(args, pat);
1464 #if defined(PERL_IMPLICIT_CONTEXT)
1466 Perl_warner_nocontext(U32 err, const char *pat, ...)
1470 va_start(args, pat);
1471 vwarner(err, pat, &args);
1474 #endif /* PERL_IMPLICIT_CONTEXT */
1477 Perl_warner(pTHX_ U32 err, const char* pat,...)
1480 va_start(args, pat);
1481 vwarner(err, pat, &args);
1486 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1489 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1490 SV * const msv = vmess(pat, args);
1492 const char * const message = SvPV_const(msv, msglen);
1493 const I32 utf8 = SvUTF8(msv);
1497 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1500 PL_restartop = die_where(message, msglen);
1501 SvFLAGS(ERRSV) |= utf8;
1504 write_to_stderr(message, msglen);
1508 Perl_vwarn(aTHX_ pat, args);
1512 /* implements the ckWARN? macros */
1515 Perl_ckwarn(pTHX_ U32 w)
1521 && PL_curcop->cop_warnings != pWARN_NONE
1523 PL_curcop->cop_warnings == pWARN_ALL
1524 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1525 || (unpackWARN2(w) &&
1526 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1527 || (unpackWARN3(w) &&
1528 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1529 || (unpackWARN4(w) &&
1530 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1535 isLEXWARN_off && PL_dowarn & G_WARN_ON
1540 /* implements the ckWARN?_d macro */
1543 Perl_ckwarn_d(pTHX_ U32 w)
1548 || PL_curcop->cop_warnings == pWARN_ALL
1550 PL_curcop->cop_warnings != pWARN_NONE
1552 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1553 || (unpackWARN2(w) &&
1554 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1555 || (unpackWARN3(w) &&
1556 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1557 || (unpackWARN4(w) &&
1558 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1564 /* Set buffer=NULL to get a new one. */
1566 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1568 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1569 PERL_UNUSED_CONTEXT;
1572 (specialWARN(buffer) ?
1573 PerlMemShared_malloc(len_wanted) :
1574 PerlMemShared_realloc(buffer, len_wanted));
1576 Copy(bits, (buffer + 1), size, char);
1580 /* since we've already done strlen() for both nam and val
1581 * we can use that info to make things faster than
1582 * sprintf(s, "%s=%s", nam, val)
1584 #define my_setenv_format(s, nam, nlen, val, vlen) \
1585 Copy(nam, s, nlen, char); \
1587 Copy(val, s+(nlen+1), vlen, char); \
1588 *(s+(nlen+1+vlen)) = '\0'
1590 #ifdef USE_ENVIRON_ARRAY
1591 /* VMS' my_setenv() is in vms.c */
1592 #if !defined(WIN32) && !defined(NETWARE)
1594 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1598 /* only parent thread can modify process environment */
1599 if (PL_curinterp == aTHX)
1602 #ifndef PERL_USE_SAFE_PUTENV
1603 if (!PL_use_safe_putenv) {
1604 /* most putenv()s leak, so we manipulate environ directly */
1605 register I32 i=setenv_getix(nam); /* where does it go? */
1608 if (environ == PL_origenviron) { /* need we copy environment? */
1614 while (environ[max])
1616 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1617 for (j=0; j<max; j++) { /* copy environment */
1618 const int len = strlen(environ[j]);
1619 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1620 Copy(environ[j], tmpenv[j], len+1, char);
1623 environ = tmpenv; /* tell exec where it is now */
1626 safesysfree(environ[i]);
1627 while (environ[i]) {
1628 environ[i] = environ[i+1];
1633 if (!environ[i]) { /* does not exist yet */
1634 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1635 environ[i+1] = NULL; /* make sure it's null terminated */
1638 safesysfree(environ[i]);
1642 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1643 /* all that work just for this */
1644 my_setenv_format(environ[i], nam, nlen, val, vlen);
1647 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1648 # if defined(HAS_UNSETENV)
1650 (void)unsetenv(nam);
1652 (void)setenv(nam, val, 1);
1654 # else /* ! HAS_UNSETENV */
1655 (void)setenv(nam, val, 1);
1656 # endif /* HAS_UNSETENV */
1658 # if defined(HAS_UNSETENV)
1660 (void)unsetenv(nam);
1662 const int nlen = strlen(nam);
1663 const int vlen = strlen(val);
1664 char * const new_env =
1665 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1666 my_setenv_format(new_env, nam, nlen, val, vlen);
1667 (void)putenv(new_env);
1669 # else /* ! HAS_UNSETENV */
1671 const int nlen = strlen(nam);
1677 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1678 /* all that work just for this */
1679 my_setenv_format(new_env, nam, nlen, val, vlen);
1680 (void)putenv(new_env);
1681 # endif /* HAS_UNSETENV */
1682 # endif /* __CYGWIN__ */
1683 #ifndef PERL_USE_SAFE_PUTENV
1689 #else /* WIN32 || NETWARE */
1692 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1695 register char *envstr;
1696 const int nlen = strlen(nam);
1703 Newx(envstr, nlen+vlen+2, char);
1704 my_setenv_format(envstr, nam, nlen, val, vlen);
1705 (void)PerlEnv_putenv(envstr);
1709 #endif /* WIN32 || NETWARE */
1713 Perl_setenv_getix(pTHX_ const char *nam)
1716 register const I32 len = strlen(nam);
1717 PERL_UNUSED_CONTEXT;
1719 for (i = 0; environ[i]; i++) {
1722 strnicmp(environ[i],nam,len) == 0
1724 strnEQ(environ[i],nam,len)
1726 && environ[i][len] == '=')
1727 break; /* strnEQ must come first to avoid */
1728 } /* potential SEGV's */
1731 #endif /* !PERL_MICRO */
1733 #endif /* !VMS && !EPOC*/
1735 #ifdef UNLINK_ALL_VERSIONS
1737 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1741 while (PerlLIO_unlink(f) >= 0)
1743 return retries ? 0 : -1;
1747 /* this is a drop-in replacement for bcopy() */
1748 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1750 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1752 char * const retval = to;
1754 if (from - to >= 0) {
1762 *(--to) = *(--from);
1768 /* this is a drop-in replacement for memset() */
1771 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1773 char * const retval = loc;
1781 /* this is a drop-in replacement for bzero() */
1782 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1784 Perl_my_bzero(register char *loc, register I32 len)
1786 char * const retval = loc;
1794 /* this is a drop-in replacement for memcmp() */
1795 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1797 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1799 register const U8 *a = (const U8 *)s1;
1800 register const U8 *b = (const U8 *)s2;
1804 if ((tmp = *a++ - *b++))
1809 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1813 #ifdef USE_CHAR_VSPRINTF
1818 vsprintf(char *dest, const char *pat, char *args)
1822 fakebuf._ptr = dest;
1823 fakebuf._cnt = 32767;
1827 fakebuf._flag = _IOWRT|_IOSTRG;
1828 _doprnt(pat, args, &fakebuf); /* what a kludge */
1829 (void)putc('\0', &fakebuf);
1830 #ifdef USE_CHAR_VSPRINTF
1833 return 0; /* perl doesn't use return value */
1837 #endif /* HAS_VPRINTF */
1840 #if BYTEORDER != 0x4321
1842 Perl_my_swap(pTHX_ short s)
1844 #if (BYTEORDER & 1) == 0
1847 result = ((s & 255) << 8) + ((s >> 8) & 255);
1855 Perl_my_htonl(pTHX_ long l)
1859 char c[sizeof(long)];
1862 #if BYTEORDER == 0x1234
1863 u.c[0] = (l >> 24) & 255;
1864 u.c[1] = (l >> 16) & 255;
1865 u.c[2] = (l >> 8) & 255;
1869 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1870 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1875 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1876 u.c[o & 0xf] = (l >> s) & 255;
1884 Perl_my_ntohl(pTHX_ long l)
1888 char c[sizeof(long)];
1891 #if BYTEORDER == 0x1234
1892 u.c[0] = (l >> 24) & 255;
1893 u.c[1] = (l >> 16) & 255;
1894 u.c[2] = (l >> 8) & 255;
1898 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1899 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1906 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1907 l |= (u.c[o & 0xf] & 255) << s;
1914 #endif /* BYTEORDER != 0x4321 */
1918 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1919 * If these functions are defined,
1920 * the BYTEORDER is neither 0x1234 nor 0x4321.
1921 * However, this is not assumed.
1925 #define HTOLE(name,type) \
1927 name (register type n) \
1931 char c[sizeof(type)]; \
1934 register U32 s = 0; \
1935 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1936 u.c[i] = (n >> s) & 0xFF; \
1941 #define LETOH(name,type) \
1943 name (register type n) \
1947 char c[sizeof(type)]; \
1950 register U32 s = 0; \
1953 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1954 n |= ((type)(u.c[i] & 0xFF)) << s; \
1960 * Big-endian byte order functions.
1963 #define HTOBE(name,type) \
1965 name (register type n) \
1969 char c[sizeof(type)]; \
1972 register U32 s = 8*(sizeof(u.c)-1); \
1973 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1974 u.c[i] = (n >> s) & 0xFF; \
1979 #define BETOH(name,type) \
1981 name (register type n) \
1985 char c[sizeof(type)]; \
1988 register U32 s = 8*(sizeof(u.c)-1); \
1991 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1992 n |= ((type)(u.c[i] & 0xFF)) << s; \
1998 * If we just can't do it...
2001 #define NOT_AVAIL(name,type) \
2003 name (register type n) \
2005 Perl_croak_nocontext(#name "() not available"); \
2006 return n; /* not reached */ \
2010 #if defined(HAS_HTOVS) && !defined(htovs)
2013 #if defined(HAS_HTOVL) && !defined(htovl)
2016 #if defined(HAS_VTOHS) && !defined(vtohs)
2019 #if defined(HAS_VTOHL) && !defined(vtohl)
2023 #ifdef PERL_NEED_MY_HTOLE16
2025 HTOLE(Perl_my_htole16,U16)
2027 NOT_AVAIL(Perl_my_htole16,U16)
2030 #ifdef PERL_NEED_MY_LETOH16
2032 LETOH(Perl_my_letoh16,U16)
2034 NOT_AVAIL(Perl_my_letoh16,U16)
2037 #ifdef PERL_NEED_MY_HTOBE16
2039 HTOBE(Perl_my_htobe16,U16)
2041 NOT_AVAIL(Perl_my_htobe16,U16)
2044 #ifdef PERL_NEED_MY_BETOH16
2046 BETOH(Perl_my_betoh16,U16)
2048 NOT_AVAIL(Perl_my_betoh16,U16)
2052 #ifdef PERL_NEED_MY_HTOLE32
2054 HTOLE(Perl_my_htole32,U32)
2056 NOT_AVAIL(Perl_my_htole32,U32)
2059 #ifdef PERL_NEED_MY_LETOH32
2061 LETOH(Perl_my_letoh32,U32)
2063 NOT_AVAIL(Perl_my_letoh32,U32)
2066 #ifdef PERL_NEED_MY_HTOBE32
2068 HTOBE(Perl_my_htobe32,U32)
2070 NOT_AVAIL(Perl_my_htobe32,U32)
2073 #ifdef PERL_NEED_MY_BETOH32
2075 BETOH(Perl_my_betoh32,U32)
2077 NOT_AVAIL(Perl_my_betoh32,U32)
2081 #ifdef PERL_NEED_MY_HTOLE64
2083 HTOLE(Perl_my_htole64,U64)
2085 NOT_AVAIL(Perl_my_htole64,U64)
2088 #ifdef PERL_NEED_MY_LETOH64
2090 LETOH(Perl_my_letoh64,U64)
2092 NOT_AVAIL(Perl_my_letoh64,U64)
2095 #ifdef PERL_NEED_MY_HTOBE64
2097 HTOBE(Perl_my_htobe64,U64)
2099 NOT_AVAIL(Perl_my_htobe64,U64)
2102 #ifdef PERL_NEED_MY_BETOH64
2104 BETOH(Perl_my_betoh64,U64)
2106 NOT_AVAIL(Perl_my_betoh64,U64)
2110 #ifdef PERL_NEED_MY_HTOLES
2111 HTOLE(Perl_my_htoles,short)
2113 #ifdef PERL_NEED_MY_LETOHS
2114 LETOH(Perl_my_letohs,short)
2116 #ifdef PERL_NEED_MY_HTOBES
2117 HTOBE(Perl_my_htobes,short)
2119 #ifdef PERL_NEED_MY_BETOHS
2120 BETOH(Perl_my_betohs,short)
2123 #ifdef PERL_NEED_MY_HTOLEI
2124 HTOLE(Perl_my_htolei,int)
2126 #ifdef PERL_NEED_MY_LETOHI
2127 LETOH(Perl_my_letohi,int)
2129 #ifdef PERL_NEED_MY_HTOBEI
2130 HTOBE(Perl_my_htobei,int)
2132 #ifdef PERL_NEED_MY_BETOHI
2133 BETOH(Perl_my_betohi,int)
2136 #ifdef PERL_NEED_MY_HTOLEL
2137 HTOLE(Perl_my_htolel,long)
2139 #ifdef PERL_NEED_MY_LETOHL
2140 LETOH(Perl_my_letohl,long)
2142 #ifdef PERL_NEED_MY_HTOBEL
2143 HTOBE(Perl_my_htobel,long)
2145 #ifdef PERL_NEED_MY_BETOHL
2146 BETOH(Perl_my_betohl,long)
2150 Perl_my_swabn(void *ptr, int n)
2152 register char *s = (char *)ptr;
2153 register char *e = s + (n-1);
2156 for (n /= 2; n > 0; s++, e--, n--) {
2164 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2166 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2169 register I32 This, that;
2175 PERL_FLUSHALL_FOR_CHILD;
2176 This = (*mode == 'w');
2180 taint_proper("Insecure %s%s", "EXEC");
2182 if (PerlProc_pipe(p) < 0)
2184 /* Try for another pipe pair for error return */
2185 if (PerlProc_pipe(pp) >= 0)
2187 while ((pid = PerlProc_fork()) < 0) {
2188 if (errno != EAGAIN) {
2189 PerlLIO_close(p[This]);
2190 PerlLIO_close(p[that]);
2192 PerlLIO_close(pp[0]);
2193 PerlLIO_close(pp[1]);
2205 /* Close parent's end of error status pipe (if any) */
2207 PerlLIO_close(pp[0]);
2208 #if defined(HAS_FCNTL) && defined(F_SETFD)
2209 /* Close error pipe automatically if exec works */
2210 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2213 /* Now dup our end of _the_ pipe to right position */
2214 if (p[THIS] != (*mode == 'r')) {
2215 PerlLIO_dup2(p[THIS], *mode == 'r');
2216 PerlLIO_close(p[THIS]);
2217 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2218 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2221 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2222 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2223 /* No automatic close - do it by hand */
2230 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2236 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2242 do_execfree(); /* free any memory malloced by child on fork */
2244 PerlLIO_close(pp[1]);
2245 /* Keep the lower of the two fd numbers */
2246 if (p[that] < p[This]) {
2247 PerlLIO_dup2(p[This], p[that]);
2248 PerlLIO_close(p[This]);
2252 PerlLIO_close(p[that]); /* close child's end of pipe */
2255 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2257 SvUPGRADE(sv,SVt_IV);
2259 PL_forkprocess = pid;
2260 /* If we managed to get status pipe check for exec fail */
2261 if (did_pipes && pid > 0) {
2266 while (n < sizeof(int)) {
2267 n1 = PerlLIO_read(pp[0],
2268 (void*)(((char*)&errkid)+n),
2274 PerlLIO_close(pp[0]);
2276 if (n) { /* Error */
2278 PerlLIO_close(p[This]);
2279 if (n != sizeof(int))
2280 Perl_croak(aTHX_ "panic: kid popen errno read");
2282 pid2 = wait4pid(pid, &status, 0);
2283 } while (pid2 == -1 && errno == EINTR);
2284 errno = errkid; /* Propagate errno from kid */
2289 PerlLIO_close(pp[0]);
2290 return PerlIO_fdopen(p[This], mode);
2292 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2293 return my_syspopen4(aTHX_ Nullch, mode, n, args);
2295 Perl_croak(aTHX_ "List form of piped open not implemented");
2296 return (PerlIO *) NULL;
2301 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2302 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2304 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2308 register I32 This, that;
2311 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2315 PERL_FLUSHALL_FOR_CHILD;
2318 return my_syspopen(aTHX_ cmd,mode);
2321 This = (*mode == 'w');
2323 if (doexec && PL_tainting) {
2325 taint_proper("Insecure %s%s", "EXEC");
2327 if (PerlProc_pipe(p) < 0)
2329 if (doexec && PerlProc_pipe(pp) >= 0)
2331 while ((pid = PerlProc_fork()) < 0) {
2332 if (errno != EAGAIN) {
2333 PerlLIO_close(p[This]);
2334 PerlLIO_close(p[that]);
2336 PerlLIO_close(pp[0]);
2337 PerlLIO_close(pp[1]);
2340 Perl_croak(aTHX_ "Can't fork");
2353 PerlLIO_close(pp[0]);
2354 #if defined(HAS_FCNTL) && defined(F_SETFD)
2355 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2358 if (p[THIS] != (*mode == 'r')) {
2359 PerlLIO_dup2(p[THIS], *mode == 'r');
2360 PerlLIO_close(p[THIS]);
2361 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2362 PerlLIO_close(p[THAT]);
2365 PerlLIO_close(p[THAT]);
2368 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2375 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2380 /* may or may not use the shell */
2381 do_exec3(cmd, pp[1], did_pipes);
2384 #endif /* defined OS2 */
2386 #ifdef PERLIO_USING_CRLF
2387 /* Since we circumvent IO layers when we manipulate low-level
2388 filedescriptors directly, need to manually switch to the
2389 default, binary, low-level mode; see PerlIOBuf_open(). */
2390 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2393 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2394 SvREADONLY_off(GvSV(tmpgv));
2395 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2396 SvREADONLY_on(GvSV(tmpgv));
2398 #ifdef THREADS_HAVE_PIDS
2399 PL_ppid = (IV)getppid();
2402 #ifdef PERL_USES_PL_PIDSTATUS
2403 hv_clear(PL_pidstatus); /* we have no children */
2409 do_execfree(); /* free any memory malloced by child on vfork */
2411 PerlLIO_close(pp[1]);
2412 if (p[that] < p[This]) {
2413 PerlLIO_dup2(p[This], p[that]);
2414 PerlLIO_close(p[This]);
2418 PerlLIO_close(p[that]);
2421 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2423 SvUPGRADE(sv,SVt_IV);
2425 PL_forkprocess = pid;
2426 if (did_pipes && pid > 0) {
2431 while (n < sizeof(int)) {
2432 n1 = PerlLIO_read(pp[0],
2433 (void*)(((char*)&errkid)+n),
2439 PerlLIO_close(pp[0]);
2441 if (n) { /* Error */
2443 PerlLIO_close(p[This]);
2444 if (n != sizeof(int))
2445 Perl_croak(aTHX_ "panic: kid popen errno read");
2447 pid2 = wait4pid(pid, &status, 0);
2448 } while (pid2 == -1 && errno == EINTR);
2449 errno = errkid; /* Propagate errno from kid */
2454 PerlLIO_close(pp[0]);
2455 return PerlIO_fdopen(p[This], mode);
2458 #if defined(atarist) || defined(EPOC)
2461 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2463 PERL_FLUSHALL_FOR_CHILD;
2464 /* Call system's popen() to get a FILE *, then import it.
2465 used 0 for 2nd parameter to PerlIO_importFILE;
2468 return PerlIO_importFILE(popen(cmd, mode), 0);
2472 FILE *djgpp_popen();
2474 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2476 PERL_FLUSHALL_FOR_CHILD;
2477 /* Call system's popen() to get a FILE *, then import it.
2478 used 0 for 2nd parameter to PerlIO_importFILE;
2481 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2486 #endif /* !DOSISH */
2488 /* this is called in parent before the fork() */
2490 Perl_atfork_lock(void)
2493 #if defined(USE_ITHREADS)
2494 /* locks must be held in locking order (if any) */
2496 MUTEX_LOCK(&PL_malloc_mutex);
2502 /* this is called in both parent and child after the fork() */
2504 Perl_atfork_unlock(void)
2507 #if defined(USE_ITHREADS)
2508 /* locks must be released in same order as in atfork_lock() */
2510 MUTEX_UNLOCK(&PL_malloc_mutex);
2519 #if defined(HAS_FORK)
2521 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2526 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2527 * handlers elsewhere in the code */
2532 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2533 Perl_croak_nocontext("fork() not available");
2535 #endif /* HAS_FORK */
2540 Perl_dump_fds(pTHX_ char *s)
2545 PerlIO_printf(Perl_debug_log,"%s", s);
2546 for (fd = 0; fd < 32; fd++) {
2547 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2548 PerlIO_printf(Perl_debug_log," %d",fd);
2550 PerlIO_printf(Perl_debug_log,"\n");
2553 #endif /* DUMP_FDS */
2557 dup2(int oldfd, int newfd)
2559 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2562 PerlLIO_close(newfd);
2563 return fcntl(oldfd, F_DUPFD, newfd);
2565 #define DUP2_MAX_FDS 256
2566 int fdtmp[DUP2_MAX_FDS];
2572 PerlLIO_close(newfd);
2573 /* good enough for low fd's... */
2574 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2575 if (fdx >= DUP2_MAX_FDS) {
2583 PerlLIO_close(fdtmp[--fdx]);
2590 #ifdef HAS_SIGACTION
2592 #ifdef MACOS_TRADITIONAL
2593 /* We don't want restart behavior on MacOS */
2598 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2601 struct sigaction act, oact;
2604 /* only "parent" interpreter can diddle signals */
2605 if (PL_curinterp != aTHX)
2606 return (Sighandler_t) SIG_ERR;
2609 act.sa_handler = (void(*)(int))handler;
2610 sigemptyset(&act.sa_mask);
2613 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2614 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2616 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2617 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2618 act.sa_flags |= SA_NOCLDWAIT;
2620 if (sigaction(signo, &act, &oact) == -1)
2621 return (Sighandler_t) SIG_ERR;
2623 return (Sighandler_t) oact.sa_handler;
2627 Perl_rsignal_state(pTHX_ int signo)
2629 struct sigaction oact;
2630 PERL_UNUSED_CONTEXT;
2632 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2633 return (Sighandler_t) SIG_ERR;
2635 return (Sighandler_t) oact.sa_handler;
2639 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2642 struct sigaction act;
2645 /* only "parent" interpreter can diddle signals */
2646 if (PL_curinterp != aTHX)
2650 act.sa_handler = (void(*)(int))handler;
2651 sigemptyset(&act.sa_mask);
2654 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2655 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2657 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2658 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2659 act.sa_flags |= SA_NOCLDWAIT;
2661 return sigaction(signo, &act, save);
2665 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2669 /* only "parent" interpreter can diddle signals */
2670 if (PL_curinterp != aTHX)
2674 return sigaction(signo, save, (struct sigaction *)NULL);
2677 #else /* !HAS_SIGACTION */
2680 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2682 #if defined(USE_ITHREADS) && !defined(WIN32)
2683 /* only "parent" interpreter can diddle signals */
2684 if (PL_curinterp != aTHX)
2685 return (Sighandler_t) SIG_ERR;
2688 return PerlProc_signal(signo, handler);
2699 Perl_rsignal_state(pTHX_ int signo)
2702 Sighandler_t oldsig;
2704 #if defined(USE_ITHREADS) && !defined(WIN32)
2705 /* only "parent" interpreter can diddle signals */
2706 if (PL_curinterp != aTHX)
2707 return (Sighandler_t) SIG_ERR;
2711 oldsig = PerlProc_signal(signo, sig_trap);
2712 PerlProc_signal(signo, oldsig);
2714 PerlProc_kill(PerlProc_getpid(), signo);
2719 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2721 #if defined(USE_ITHREADS) && !defined(WIN32)
2722 /* only "parent" interpreter can diddle signals */
2723 if (PL_curinterp != aTHX)
2726 *save = PerlProc_signal(signo, handler);
2727 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2731 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2733 #if defined(USE_ITHREADS) && !defined(WIN32)
2734 /* only "parent" interpreter can diddle signals */
2735 if (PL_curinterp != aTHX)
2738 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2741 #endif /* !HAS_SIGACTION */
2742 #endif /* !PERL_MICRO */
2744 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2745 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2747 Perl_my_pclose(pTHX_ PerlIO *ptr)
2750 Sigsave_t hstat, istat, qstat;
2756 int saved_errno = 0;
2758 int saved_win32_errno;
2762 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2764 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2766 *svp = &PL_sv_undef;
2768 if (pid == -1) { /* Opened by popen. */
2769 return my_syspclose(ptr);
2772 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2773 saved_errno = errno;
2775 saved_win32_errno = GetLastError();
2779 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2782 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2783 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2784 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2787 pid2 = wait4pid(pid, &status, 0);
2788 } while (pid2 == -1 && errno == EINTR);
2790 rsignal_restore(SIGHUP, &hstat);
2791 rsignal_restore(SIGINT, &istat);
2792 rsignal_restore(SIGQUIT, &qstat);
2795 SETERRNO(saved_errno, 0);
2798 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2800 #endif /* !DOSISH */
2802 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2804 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2810 #ifdef PERL_USES_PL_PIDSTATUS
2813 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2814 pid, rather than a string form. */
2815 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2816 if (svp && *svp != &PL_sv_undef) {
2817 *statusp = SvIVX(*svp);
2818 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2826 hv_iterinit(PL_pidstatus);
2827 if ((entry = hv_iternext(PL_pidstatus))) {
2828 SV * const sv = hv_iterval(PL_pidstatus,entry);
2830 const char * const spid = hv_iterkey(entry,&len);
2832 assert (len == sizeof(Pid_t));
2833 memcpy((char *)&pid, spid, len);
2834 *statusp = SvIVX(sv);
2835 /* The hash iterator is currently on this entry, so simply
2836 calling hv_delete would trigger the lazy delete, which on
2837 aggregate does more work, beacuse next call to hv_iterinit()
2838 would spot the flag, and have to call the delete routine,
2839 while in the meantime any new entries can't re-use that
2841 hv_iterinit(PL_pidstatus);
2842 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2849 # ifdef HAS_WAITPID_RUNTIME
2850 if (!HAS_WAITPID_RUNTIME)
2853 result = PerlProc_waitpid(pid,statusp,flags);
2856 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2857 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2860 #ifdef PERL_USES_PL_PIDSTATUS
2861 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2866 Perl_croak(aTHX_ "Can't do waitpid with flags");
2868 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2869 pidgone(result,*statusp);
2875 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2878 if (result < 0 && errno == EINTR) {
2883 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2885 #ifdef PERL_USES_PL_PIDSTATUS
2887 Perl_pidgone(pTHX_ Pid_t pid, int status)
2891 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2892 SvUPGRADE(sv,SVt_IV);
2893 SvIV_set(sv, status);
2898 #if defined(atarist) || defined(OS2) || defined(EPOC)
2901 int /* Cannot prototype with I32
2903 my_syspclose(PerlIO *ptr)
2906 Perl_my_pclose(pTHX_ PerlIO *ptr)
2909 /* Needs work for PerlIO ! */
2910 FILE * const f = PerlIO_findFILE(ptr);
2911 const I32 result = pclose(f);
2912 PerlIO_releaseFILE(ptr,f);
2920 Perl_my_pclose(pTHX_ PerlIO *ptr)
2922 /* Needs work for PerlIO ! */
2923 FILE * const f = PerlIO_findFILE(ptr);
2924 I32 result = djgpp_pclose(f);
2925 result = (result << 8) & 0xff00;
2926 PerlIO_releaseFILE(ptr,f);
2932 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2935 register const char * const frombase = from;
2936 PERL_UNUSED_CONTEXT;
2939 register const char c = *from;
2944 while (count-- > 0) {
2945 for (todo = len; todo > 0; todo--) {
2954 Perl_same_dirent(pTHX_ const char *a, const char *b)
2956 char *fa = strrchr(a,'/');
2957 char *fb = strrchr(b,'/');
2960 SV * const tmpsv = sv_newmortal();
2973 sv_setpvn(tmpsv, ".", 1);
2975 sv_setpvn(tmpsv, a, fa - a);
2976 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2979 sv_setpvn(tmpsv, ".", 1);
2981 sv_setpvn(tmpsv, b, fb - b);
2982 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2984 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2985 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2987 #endif /* !HAS_RENAME */
2990 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2991 const char *const *const search_ext, I32 flags)
2994 const char *xfound = NULL;
2995 char *xfailed = NULL;
2996 char tmpbuf[MAXPATHLEN];
3000 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3001 # define SEARCH_EXTS ".bat", ".cmd", NULL
3002 # define MAX_EXT_LEN 4
3005 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3006 # define MAX_EXT_LEN 4
3009 # define SEARCH_EXTS ".pl", ".com", NULL
3010 # define MAX_EXT_LEN 4
3012 /* additional extensions to try in each dir if scriptname not found */
3014 static const char *const exts[] = { SEARCH_EXTS };
3015 const char *const *const ext = search_ext ? search_ext : exts;
3016 int extidx = 0, i = 0;
3017 const char *curext = NULL;
3019 PERL_UNUSED_ARG(search_ext);
3020 # define MAX_EXT_LEN 0
3024 * If dosearch is true and if scriptname does not contain path
3025 * delimiters, search the PATH for scriptname.
3027 * If SEARCH_EXTS is also defined, will look for each
3028 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3029 * while searching the PATH.
3031 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3032 * proceeds as follows:
3033 * If DOSISH or VMSISH:
3034 * + look for ./scriptname{,.foo,.bar}
3035 * + search the PATH for scriptname{,.foo,.bar}
3038 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3039 * this will not look in '.' if it's not in the PATH)
3044 # ifdef ALWAYS_DEFTYPES
3045 len = strlen(scriptname);
3046 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3047 int idx = 0, deftypes = 1;
3050 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3053 int idx = 0, deftypes = 1;
3056 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3058 /* The first time through, just add SEARCH_EXTS to whatever we
3059 * already have, so we can check for default file types. */
3061 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3067 if ((strlen(tmpbuf) + strlen(scriptname)
3068 + MAX_EXT_LEN) >= sizeof tmpbuf)
3069 continue; /* don't search dir with too-long name */
3070 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3074 if (strEQ(scriptname, "-"))
3076 if (dosearch) { /* Look in '.' first. */
3077 const char *cur = scriptname;
3079 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3081 if (strEQ(ext[i++],curext)) {
3082 extidx = -1; /* already has an ext */
3087 DEBUG_p(PerlIO_printf(Perl_debug_log,
3088 "Looking for %s\n",cur));
3089 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3090 && !S_ISDIR(PL_statbuf.st_mode)) {
3098 if (cur == scriptname) {
3099 len = strlen(scriptname);
3100 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3102 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3105 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3106 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3111 #ifdef MACOS_TRADITIONAL
3112 if (dosearch && !strchr(scriptname, ':') &&
3113 (s = PerlEnv_getenv("Commands")))
3115 if (dosearch && !strchr(scriptname, '/')
3117 && !strchr(scriptname, '\\')
3119 && (s = PerlEnv_getenv("PATH")))
3124 PL_bufend = s + strlen(s);
3125 while (s < PL_bufend) {
3126 #ifdef MACOS_TRADITIONAL
3127 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3131 #if defined(atarist) || defined(DOSISH)
3136 && *s != ';'; len++, s++) {
3137 if (len < sizeof tmpbuf)
3140 if (len < sizeof tmpbuf)
3142 #else /* ! (atarist || DOSISH) */
3143 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3146 #endif /* ! (atarist || DOSISH) */
3147 #endif /* MACOS_TRADITIONAL */
3150 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3151 continue; /* don't search dir with too-long name */
3152 #ifdef MACOS_TRADITIONAL
3153 if (len && tmpbuf[len - 1] != ':')
3154 tmpbuf[len++] = ':';
3157 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3158 && tmpbuf[len - 1] != '/'
3159 && tmpbuf[len - 1] != '\\'
3162 tmpbuf[len++] = '/';
3163 if (len == 2 && tmpbuf[0] == '.')
3166 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3170 len = strlen(tmpbuf);
3171 if (extidx > 0) /* reset after previous loop */
3175 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3176 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3177 if (S_ISDIR(PL_statbuf.st_mode)) {
3181 } while ( retval < 0 /* not there */
3182 && extidx>=0 && ext[extidx] /* try an extension? */
3183 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3188 if (S_ISREG(PL_statbuf.st_mode)
3189 && cando(S_IRUSR,TRUE,&PL_statbuf)
3190 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3191 && cando(S_IXUSR,TRUE,&PL_statbuf)
3195 xfound = tmpbuf; /* bingo! */
3199 xfailed = savepv(tmpbuf);
3202 if (!xfound && !seen_dot && !xfailed &&
3203 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3204 || S_ISDIR(PL_statbuf.st_mode)))
3206 seen_dot = 1; /* Disable message. */
3208 if (flags & 1) { /* do or die? */
3209 Perl_croak(aTHX_ "Can't %s %s%s%s",
3210 (xfailed ? "execute" : "find"),
3211 (xfailed ? xfailed : scriptname),
3212 (xfailed ? "" : " on PATH"),
3213 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3218 scriptname = xfound;
3220 return (scriptname ? savepv(scriptname) : NULL);
3223 #ifndef PERL_GET_CONTEXT_DEFINED
3226 Perl_get_context(void)
3229 #if defined(USE_ITHREADS)
3230 # ifdef OLD_PTHREADS_API
3232 if (pthread_getspecific(PL_thr_key, &t))
3233 Perl_croak_nocontext("panic: pthread_getspecific");
3236 # ifdef I_MACH_CTHREADS
3237 return (void*)cthread_data(cthread_self());
3239 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3248 Perl_set_context(void *t)
3251 #if defined(USE_ITHREADS)
3252 # ifdef I_MACH_CTHREADS
3253 cthread_set_data(cthread_self(), t);
3255 if (pthread_setspecific(PL_thr_key, t))
3256 Perl_croak_nocontext("panic: pthread_setspecific");
3263 #endif /* !PERL_GET_CONTEXT_DEFINED */
3265 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3274 Perl_get_op_names(pTHX)
3276 PERL_UNUSED_CONTEXT;
3277 return (char **)PL_op_name;
3281 Perl_get_op_descs(pTHX)
3283 PERL_UNUSED_CONTEXT;
3284 return (char **)PL_op_desc;
3288 Perl_get_no_modify(pTHX)
3290 PERL_UNUSED_CONTEXT;
3291 return PL_no_modify;
3295 Perl_get_opargs(pTHX)
3297 PERL_UNUSED_CONTEXT;
3298 return (U32 *)PL_opargs;
3302 Perl_get_ppaddr(pTHX)
3305 PERL_UNUSED_CONTEXT;
3306 return (PPADDR_t*)PL_ppaddr;
3309 #ifndef HAS_GETENV_LEN
3311 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3313 char * const env_trans = PerlEnv_getenv(env_elem);
3314 PERL_UNUSED_CONTEXT;
3316 *len = strlen(env_trans);
3323 Perl_get_vtbl(pTHX_ int vtbl_id)
3325 const MGVTBL* result;
3326 PERL_UNUSED_CONTEXT;
3330 result = &PL_vtbl_sv;
3333 result = &PL_vtbl_env;
3335 case want_vtbl_envelem:
3336 result = &PL_vtbl_envelem;
3339 result = &PL_vtbl_sig;
3341 case want_vtbl_sigelem:
3342 result = &PL_vtbl_sigelem;
3344 case want_vtbl_pack:
3345 result = &PL_vtbl_pack;
3347 case want_vtbl_packelem:
3348 result = &PL_vtbl_packelem;
3350 case want_vtbl_dbline:
3351 result = &PL_vtbl_dbline;
3354 result = &PL_vtbl_isa;
3356 case want_vtbl_isaelem:
3357 result = &PL_vtbl_isaelem;
3359 case want_vtbl_arylen:
3360 result = &PL_vtbl_arylen;
3362 case want_vtbl_mglob:
3363 result = &PL_vtbl_mglob;
3365 case want_vtbl_nkeys:
3366 result = &PL_vtbl_nkeys;
3368 case want_vtbl_taint:
3369 result = &PL_vtbl_taint;
3371 case want_vtbl_substr:
3372 result = &PL_vtbl_substr;
3375 result = &PL_vtbl_vec;
3378 result = &PL_vtbl_pos;
3381 result = &PL_vtbl_bm;
3384 result = &PL_vtbl_fm;
3386 case want_vtbl_uvar:
3387 result = &PL_vtbl_uvar;
3389 case want_vtbl_defelem:
3390 result = &PL_vtbl_defelem;
3392 case want_vtbl_regexp:
3393 result = &PL_vtbl_regexp;
3395 case want_vtbl_regdata:
3396 result = &PL_vtbl_regdata;
3398 case want_vtbl_regdatum:
3399 result = &PL_vtbl_regdatum;
3401 #ifdef USE_LOCALE_COLLATE
3402 case want_vtbl_collxfrm:
3403 result = &PL_vtbl_collxfrm;
3406 case want_vtbl_amagic:
3407 result = &PL_vtbl_amagic;
3409 case want_vtbl_amagicelem:
3410 result = &PL_vtbl_amagicelem;
3412 case want_vtbl_backref:
3413 result = &PL_vtbl_backref;
3415 case want_vtbl_utf8:
3416 result = &PL_vtbl_utf8;
3422 return (MGVTBL*)result;
3426 Perl_my_fflush_all(pTHX)
3428 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3429 return PerlIO_flush(NULL);
3431 # if defined(HAS__FWALK)
3432 extern int fflush(FILE *);
3433 /* undocumented, unprototyped, but very useful BSDism */
3434 extern void _fwalk(int (*)(FILE *));
3438 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3440 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3441 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3443 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3444 open_max = sysconf(_SC_OPEN_MAX);
3447 open_max = FOPEN_MAX;
3450 open_max = OPEN_MAX;
3461 for (i = 0; i < open_max; i++)
3462 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3463 STDIO_STREAM_ARRAY[i]._file < open_max &&
3464 STDIO_STREAM_ARRAY[i]._flag)
3465 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3469 SETERRNO(EBADF,RMS_IFI);
3476 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3478 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3480 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3481 if (ckWARN(WARN_IO)) {
3482 const char * const direction =
3483 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3485 Perl_warner(aTHX_ packWARN(WARN_IO),
3486 "Filehandle %s opened only for %sput",
3489 Perl_warner(aTHX_ packWARN(WARN_IO),
3490 "Filehandle opened only for %sput", direction);
3497 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3499 warn_type = WARN_CLOSED;
3503 warn_type = WARN_UNOPENED;
3506 if (ckWARN(warn_type)) {
3507 const char * const pars =
3508 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3509 const char * const func =
3511 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3512 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3513 op < 0 ? "" : /* handle phoney cases */
3515 const char * const type =
3517 (OP_IS_SOCKET(op) ||
3518 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3519 "socket" : "filehandle");
3520 if (name && *name) {
3521 Perl_warner(aTHX_ packWARN(warn_type),
3522 "%s%s on %s %s %s", func, pars, vile, type, name);
3523 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3525 aTHX_ packWARN(warn_type),
3526 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3531 Perl_warner(aTHX_ packWARN(warn_type),
3532 "%s%s on %s %s", func, pars, vile, type);
3533 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3535 aTHX_ packWARN(warn_type),
3536 "\t(Are you trying to call %s%s on dirhandle?)\n",
3545 /* in ASCII order, not that it matters */
3546 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3549 Perl_ebcdic_control(pTHX_ int ch)
3557 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3558 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3561 if (ctlp == controllablechars)
3562 return('\177'); /* DEL */
3564 return((unsigned char)(ctlp - controllablechars - 1));
3565 } else { /* Want uncontrol */
3566 if (ch == '\177' || ch == -1)
3568 else if (ch == '\157')
3570 else if (ch == '\174')
3572 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3574 else if (ch == '\155')
3576 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3577 return(controllablechars[ch+1]);
3579 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3584 /* To workaround core dumps from the uninitialised tm_zone we get the
3585 * system to give us a reasonable struct to copy. This fix means that
3586 * strftime uses the tm_zone and tm_gmtoff values returned by
3587 * localtime(time()). That should give the desired result most of the
3588 * time. But probably not always!
3590 * This does not address tzname aspects of NETaa14816.
3595 # ifndef STRUCT_TM_HASZONE
3596 # define STRUCT_TM_HASZONE
3600 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3601 # ifndef HAS_TM_TM_ZONE
3602 # define HAS_TM_TM_ZONE
3607 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3609 #ifdef HAS_TM_TM_ZONE
3611 const struct tm* my_tm;
3613 my_tm = localtime(&now);
3615 Copy(my_tm, ptm, 1, struct tm);
3617 PERL_UNUSED_ARG(ptm);
3622 * mini_mktime - normalise struct tm values without the localtime()
3623 * semantics (and overhead) of mktime().
3626 Perl_mini_mktime(pTHX_ struct tm *ptm)
3630 int month, mday, year, jday;
3631 int odd_cent, odd_year;
3632 PERL_UNUSED_CONTEXT;
3634 #define DAYS_PER_YEAR 365
3635 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3636 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3637 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3638 #define SECS_PER_HOUR (60*60)
3639 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3640 /* parentheses deliberately absent on these two, otherwise they don't work */
3641 #define MONTH_TO_DAYS 153/5
3642 #define DAYS_TO_MONTH 5/153
3643 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3644 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3645 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3646 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3649 * Year/day algorithm notes:
3651 * With a suitable offset for numeric value of the month, one can find
3652 * an offset into the year by considering months to have 30.6 (153/5) days,
3653 * using integer arithmetic (i.e., with truncation). To avoid too much
3654 * messing about with leap days, we consider January and February to be
3655 * the 13th and 14th month of the previous year. After that transformation,
3656 * we need the month index we use to be high by 1 from 'normal human' usage,
3657 * so the month index values we use run from 4 through 15.
3659 * Given that, and the rules for the Gregorian calendar (leap years are those
3660 * divisible by 4 unless also divisible by 100, when they must be divisible
3661 * by 400 instead), we can simply calculate the number of days since some
3662 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3663 * the days we derive from our month index, and adding in the day of the
3664 * month. The value used here is not adjusted for the actual origin which
3665 * it normally would use (1 January A.D. 1), since we're not exposing it.
3666 * We're only building the value so we can turn around and get the
3667 * normalised values for the year, month, day-of-month, and day-of-year.
3669 * For going backward, we need to bias the value we're using so that we find
3670 * the right year value. (Basically, we don't want the contribution of
3671 * March 1st to the number to apply while deriving the year). Having done
3672 * that, we 'count up' the contribution to the year number by accounting for
3673 * full quadracenturies (400-year periods) with their extra leap days, plus
3674 * the contribution from full centuries (to avoid counting in the lost leap
3675 * days), plus the contribution from full quad-years (to count in the normal
3676 * leap days), plus the leftover contribution from any non-leap years.
3677 * At this point, if we were working with an actual leap day, we'll have 0
3678 * days left over. This is also true for March 1st, however. So, we have
3679 * to special-case that result, and (earlier) keep track of the 'odd'
3680 * century and year contributions. If we got 4 extra centuries in a qcent,
3681 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3682 * Otherwise, we add back in the earlier bias we removed (the 123 from
3683 * figuring in March 1st), find the month index (integer division by 30.6),
3684 * and the remainder is the day-of-month. We then have to convert back to
3685 * 'real' months (including fixing January and February from being 14/15 in
3686 * the previous year to being in the proper year). After that, to get
3687 * tm_yday, we work with the normalised year and get a new yearday value for
3688 * January 1st, which we subtract from the yearday value we had earlier,
3689 * representing the date we've re-built. This is done from January 1
3690 * because tm_yday is 0-origin.
3692 * Since POSIX time routines are only guaranteed to work for times since the
3693 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3694 * applies Gregorian calendar rules even to dates before the 16th century
3695 * doesn't bother me. Besides, you'd need cultural context for a given
3696 * date to know whether it was Julian or Gregorian calendar, and that's
3697 * outside the scope for this routine. Since we convert back based on the
3698 * same rules we used to build the yearday, you'll only get strange results
3699 * for input which needed normalising, or for the 'odd' century years which
3700 * were leap years in the Julian calander but not in the Gregorian one.
3701 * I can live with that.
3703 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3704 * that's still outside the scope for POSIX time manipulation, so I don't
3708 year = 1900 + ptm->tm_year;
3709 month = ptm->tm_mon;
3710 mday = ptm->tm_mday;
3711 /* allow given yday with no month & mday to dominate the result */
3712 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3715 jday = 1 + ptm->tm_yday;
3724 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3725 yearday += month*MONTH_TO_DAYS + mday + jday;
3727 * Note that we don't know when leap-seconds were or will be,
3728 * so we have to trust the user if we get something which looks
3729 * like a sensible leap-second. Wild values for seconds will
3730 * be rationalised, however.
3732 if ((unsigned) ptm->tm_sec <= 60) {
3739 secs += 60 * ptm->tm_min;
3740 secs += SECS_PER_HOUR * ptm->tm_hour;
3742 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3743 /* got negative remainder, but need positive time */
3744 /* back off an extra day to compensate */
3745 yearday += (secs/SECS_PER_DAY)-1;
3746 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3749 yearday += (secs/SECS_PER_DAY);
3750 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3753 else if (secs >= SECS_PER_DAY) {
3754 yearday += (secs/SECS_PER_DAY);
3755 secs %= SECS_PER_DAY;
3757 ptm->tm_hour = secs/SECS_PER_HOUR;
3758 secs %= SECS_PER_HOUR;
3759 ptm->tm_min = secs/60;
3761 ptm->tm_sec += secs;
3762 /* done with time of day effects */
3764 * The algorithm for yearday has (so far) left it high by 428.
3765 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3766 * bias it by 123 while trying to figure out what year it
3767 * really represents. Even with this tweak, the reverse
3768 * translation fails for years before A.D. 0001.
3769 * It would still fail for Feb 29, but we catch that one below.
3771 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3772 yearday -= YEAR_ADJUST;
3773 year = (yearday / DAYS_PER_QCENT) * 400;
3774 yearday %= DAYS_PER_QCENT;
3775 odd_cent = yearday / DAYS_PER_CENT;
3776 year += odd_cent * 100;
3777 yearday %= DAYS_PER_CENT;
3778 year += (yearday / DAYS_PER_QYEAR) * 4;
3779 yearday %= DAYS_PER_QYEAR;
3780 odd_year = yearday / DAYS_PER_YEAR;
3782 yearday %= DAYS_PER_YEAR;
3783 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3788 yearday += YEAR_ADJUST; /* recover March 1st crock */
3789 month = yearday*DAYS_TO_MONTH;
3790 yearday -= month*MONTH_TO_DAYS;
3791 /* recover other leap-year adjustment */
3800 ptm->tm_year = year - 1900;
3802 ptm->tm_mday = yearday;
3803 ptm->tm_mon = month;
3807 ptm->tm_mon = month - 1;
3809 /* re-build yearday based on Jan 1 to get tm_yday */
3811 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3812 yearday += 14*MONTH_TO_DAYS + 1;
3813 ptm->tm_yday = jday - yearday;
3814 /* fix tm_wday if not overridden by caller */
3815 if ((unsigned)ptm->tm_wday > 6)
3816 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3820 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)
3828 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3831 mytm.tm_hour = hour;
3832 mytm.tm_mday = mday;
3834 mytm.tm_year = year;
3835 mytm.tm_wday = wday;
3836 mytm.tm_yday = yday;
3837 mytm.tm_isdst = isdst;
3839 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3840 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3845 #ifdef HAS_TM_TM_GMTOFF
3846 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3848 #ifdef HAS_TM_TM_ZONE
3849 mytm.tm_zone = mytm2.tm_zone;
3854 Newx(buf, buflen, char);
3855 len = strftime(buf, buflen, fmt, &mytm);
3857 ** The following is needed to handle to the situation where
3858 ** tmpbuf overflows. Basically we want to allocate a buffer
3859 ** and try repeatedly. The reason why it is so complicated
3860 ** is that getting a return value of 0 from strftime can indicate
3861 ** one of the following:
3862 ** 1. buffer overflowed,
3863 ** 2. illegal conversion specifier, or
3864 ** 3. the format string specifies nothing to be returned(not
3865 ** an error). This could be because format is an empty string
3866 ** or it specifies %p that yields an empty string in some locale.
3867 ** If there is a better way to make it portable, go ahead by
3870 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3873 /* Possibly buf overflowed - try again with a bigger buf */
3874 const int fmtlen = strlen(fmt);
3875 int bufsize = fmtlen + buflen;
3877 Newx(buf, bufsize, char);
3879 buflen = strftime(buf, bufsize, fmt, &mytm);
3880 if (buflen > 0 && buflen < bufsize)
3882 /* heuristic to prevent out-of-memory errors */
3883 if (bufsize > 100*fmtlen) {
3889 Renew(buf, bufsize, char);
3894 Perl_croak(aTHX_ "panic: no strftime");
3900 #define SV_CWD_RETURN_UNDEF \
3901 sv_setsv(sv, &PL_sv_undef); \
3904 #define SV_CWD_ISDOT(dp) \
3905 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3906 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3909 =head1 Miscellaneous Functions
3911 =for apidoc getcwd_sv
3913 Fill the sv with current working directory
3918 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3919 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3920 * getcwd(3) if available
3921 * Comments from the orignal:
3922 * This is a faster version of getcwd. It's also more dangerous
3923 * because you might chdir out of a directory that you can't chdir
3927 Perl_getcwd_sv(pTHX_ register SV *sv)
3931 #ifndef INCOMPLETE_TAINTS
3937 char buf[MAXPATHLEN];
3939 /* Some getcwd()s automatically allocate a buffer of the given
3940 * size from the heap if they are given a NULL buffer pointer.
3941 * The problem is that this behaviour is not portable. */
3942 if (getcwd(buf, sizeof(buf) - 1)) {
3947 sv_setsv(sv, &PL_sv_undef);
3955 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3959 SvUPGRADE(sv, SVt_PV);
3961 if (PerlLIO_lstat(".", &statbuf) < 0) {
3962 SV_CWD_RETURN_UNDEF;
3965 orig_cdev = statbuf.st_dev;
3966 orig_cino = statbuf.st_ino;
3975 if (PerlDir_chdir("..") < 0) {
3976 SV_CWD_RETURN_UNDEF;
3978 if (PerlLIO_stat(".", &statbuf) < 0) {
3979 SV_CWD_RETURN_UNDEF;
3982 cdev = statbuf.st_dev;
3983 cino = statbuf.st_ino;
3985 if (odev == cdev && oino == cino) {
3988 if (!(dir = PerlDir_open("."))) {
3989 SV_CWD_RETURN_UNDEF;
3992 while ((dp = PerlDir_read(dir)) != NULL) {
3994 const int namelen = dp->d_namlen;
3996 const int namelen = strlen(dp->d_name);
3999 if (SV_CWD_ISDOT(dp)) {
4003 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4004 SV_CWD_RETURN_UNDEF;
4007 tdev = statbuf.st_dev;
4008 tino = statbuf.st_ino;
4009 if (tino == oino && tdev == odev) {
4015 SV_CWD_RETURN_UNDEF;
4018 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4019 SV_CWD_RETURN_UNDEF;
4022 SvGROW(sv, pathlen + namelen + 1);
4026 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4029 /* prepend current directory to the front */
4031 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4032 pathlen += (namelen + 1);
4034 #ifdef VOID_CLOSEDIR
4037 if (PerlDir_close(dir) < 0) {
4038 SV_CWD_RETURN_UNDEF;
4044 SvCUR_set(sv, pathlen);
4048 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4049 SV_CWD_RETURN_UNDEF;
4052 if (PerlLIO_stat(".", &statbuf) < 0) {
4053 SV_CWD_RETURN_UNDEF;
4056 cdev = statbuf.st_dev;
4057 cino = statbuf.st_ino;
4059 if (cdev != orig_cdev || cino != orig_cino) {
4060 Perl_croak(aTHX_ "Unstable directory path, "
4061 "current directory changed unexpectedly");
4073 =for apidoc scan_version
4075 Returns a pointer to the next character after the parsed
4076 version string, as well as upgrading the passed in SV to
4079 Function must be called with an already existing SV like
4082 s = scan_version(s,SV *sv, bool qv);
4084 Performs some preprocessing to the string to ensure that
4085 it has the correct characteristics of a version. Flags the
4086 object if it contains an underscore (which denotes this
4087 is a alpha version). The boolean qv denotes that the version
4088 should be interpreted as if it had multiple decimals, even if
4095 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4103 AV * const av = newAV();
4104 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4105 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4107 #ifndef NODEFAULT_SHAREKEYS
4108 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4111 while (isSPACE(*s)) /* leading whitespace is OK */
4115 s++; /* get past 'v' */
4116 qv = 1; /* force quoted version processing */
4119 start = last = pos = s;
4121 /* pre-scan the input string to check for decimals/underbars */
4122 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4127 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4131 else if ( *pos == '_' )
4134 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4136 width = pos - last - 1; /* natural width of sub-version */
4141 if ( alpha && !saw_period )
4142 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4144 if ( saw_period > 1 )
4145 qv = 1; /* force quoted version processing */
4150 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4152 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4153 if ( !qv && width < 3 )
4154 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4156 while (isDIGIT(*pos))
4158 if (!isALPHA(*pos)) {
4164 /* this is atoi() that delimits on underscores */
4165 const char *end = pos;
4169 /* the following if() will only be true after the decimal
4170 * point of a version originally created with a bare
4171 * floating point number, i.e. not quoted in any way
4173 if ( !qv && s > start && saw_period == 1 ) {
4177 rev += (*s - '0') * mult;
4179 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4180 Perl_croak(aTHX_ "Integer overflow in version");
4187 while (--end >= s) {
4189 rev += (*end - '0') * mult;
4191 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4192 Perl_croak(aTHX_ "Integer overflow in version");
4197 /* Append revision */
4198 av_push(av, newSViv(rev));
4201 else if ( *pos == '_' && isDIGIT(pos[1]) )
4203 else if ( isDIGIT(*pos) )
4210 while ( isDIGIT(*pos) )
4215 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4223 if ( qv ) { /* quoted versions always get at least three terms*/
4224 I32 len = av_len(av);
4225 /* This for loop appears to trigger a compiler bug on OS X, as it
4226 loops infinitely. Yes, len is negative. No, it makes no sense.
4227 Compiler in question is:
4228 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4229 for ( len = 2 - len; len > 0; len-- )
4230 av_push((AV *)sv, newSViv(0));
4234 av_push(av, newSViv(0));
4237 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4238 av_push(av, newSViv(0));
4240 /* fix RT#19517 - special case 'undef' as string */
4241 if ( *s == 'u' && strEQ(s,"undef") ) {
4245 /* And finally, store the AV in the hash */
4246 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4251 =for apidoc new_version
4253 Returns a new version object based on the passed in SV:
4255 SV *sv = new_version(SV *ver);
4257 Does not alter the passed in ver SV. See "upg_version" if you
4258 want to upgrade the SV.
4264 Perl_new_version(pTHX_ SV *ver)
4267 SV * const rv = newSV(0);
4268 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4271 AV * const av = newAV();
4273 /* This will get reblessed later if a derived class*/
4274 SV * const hv = newSVrv(rv, "version");
4275 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4276 #ifndef NODEFAULT_SHAREKEYS
4277 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4283 /* Begin copying all of the elements */
4284 if ( hv_exists((HV *)ver, "qv", 2) )
4285 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4287 if ( hv_exists((HV *)ver, "alpha", 5) )
4288 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4290 if ( hv_exists((HV*)ver, "width", 5 ) )
4292 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4293 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4296 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4297 /* This will get reblessed later if a derived class*/
4298 for ( key = 0; key <= av_len(sav); key++ )
4300 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4301 av_push(av, newSViv(rev));
4304 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4309 const MAGIC* const mg = SvVSTRING_mg(ver);
4310 if ( mg ) { /* already a v-string */
4311 const STRLEN len = mg->mg_len;
4312 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4313 sv_setpvn(rv,version,len);
4318 sv_setsv(rv,ver); /* make a duplicate */
4323 return upg_version(rv);
4327 =for apidoc upg_version
4329 In-place upgrade of the supplied SV to a version object.
4331 SV *sv = upg_version(SV *sv);
4333 Returns a pointer to the upgraded SV.
4339 Perl_upg_version(pTHX_ SV *ver)
4341 const char *version, *s;
4347 if ( SvNOK(ver) ) /* may get too much accuracy */
4350 #ifdef USE_LOCALE_NUMERIC
4351 char *loc = setlocale(LC_NUMERIC, "C");
4353 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4354 #ifdef USE_LOCALE_NUMERIC
4355 setlocale(LC_NUMERIC, loc);
4357 while (tbuf[len-1] == '0' && len > 0) len--;
4358 version = savepvn(tbuf, len);
4361 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4362 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4366 else /* must be a string or something like a string */
4368 version = savepv(SvPV_nolen(ver));
4371 s = scan_version(version, ver, qv);
4373 if(ckWARN(WARN_MISC))
4374 Perl_warner(aTHX_ packWARN(WARN_MISC),
4375 "Version string '%s' contains invalid data; "
4376 "ignoring: '%s'", version, s);
4384 Validates that the SV contains a valid version object.
4386 bool vverify(SV *vobj);
4388 Note that it only confirms the bare minimum structure (so as not to get
4389 confused by derived classes which may contain additional hash entries):
4393 =item * The SV contains a [reference to a] hash
4395 =item * The hash contains a "version" key
4397 =item * The "version" key has [a reference to] an AV as its value
4405 Perl_vverify(pTHX_ SV *vs)
4411 /* see if the appropriate elements exist */
4412 if ( SvTYPE(vs) == SVt_PVHV
4413 && hv_exists((HV*)vs, "version", 7)
4414 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4415 && SvTYPE(sv) == SVt_PVAV )
4424 Accepts a version object and returns the normalized floating
4425 point representation. Call like:
4429 NOTE: you can pass either the object directly or the SV
4430 contained within the RV.
4436 Perl_vnumify(pTHX_ SV *vs)
4441 SV * const sv = newSV(0);
4447 Perl_croak(aTHX_ "Invalid version object");
4449 /* see if various flags exist */
4450 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4452 if ( hv_exists((HV*)vs, "width", 5 ) )
4453 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4458 /* attempt to retrieve the version array */
4459 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4471 digit = SvIV(*av_fetch(av, 0, 0));
4472 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4473 for ( i = 1 ; i < len ; i++ )
4475 digit = SvIV(*av_fetch(av, i, 0));
4477 const int denom = (width == 2 ? 10 : 100);
4478 const div_t term = div((int)PERL_ABS(digit),denom);
4479 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4482 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4488 digit = SvIV(*av_fetch(av, len, 0));
4489 if ( alpha && width == 3 ) /* alpha version */
4491 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4495 sv_catpvs(sv, "000");
4503 Accepts a version object and returns the normalized string
4504 representation. Call like:
4508 NOTE: you can pass either the object directly or the SV
4509 contained within the RV.
4515 Perl_vnormal(pTHX_ SV *vs)
4519 SV * const sv = newSV(0);
4525 Perl_croak(aTHX_ "Invalid version object");
4527 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4529 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4537 digit = SvIV(*av_fetch(av, 0, 0));
4538 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4539 for ( i = 1 ; i < len ; i++ ) {
4540 digit = SvIV(*av_fetch(av, i, 0));
4541 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4546 /* handle last digit specially */
4547 digit = SvIV(*av_fetch(av, len, 0));
4549 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4551 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4554 if ( len <= 2 ) { /* short version, must be at least three */
4555 for ( len = 2 - len; len != 0; len-- )
4562 =for apidoc vstringify
4564 In order to maintain maximum compatibility with earlier versions
4565 of Perl, this function will return either the floating point
4566 notation or the multiple dotted notation, depending on whether
4567 the original version contained 1 or more dots, respectively
4573 Perl_vstringify(pTHX_ SV *vs)
4579 Perl_croak(aTHX_ "Invalid version object");
4581 if ( hv_exists((HV *)vs, "qv", 2) )
4590 Version object aware cmp. Both operands must already have been
4591 converted into version objects.
4597 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4600 bool lalpha = FALSE;
4601 bool ralpha = FALSE;
4610 if ( !vverify(lhv) )
4611 Perl_croak(aTHX_ "Invalid version object");
4613 if ( !vverify(rhv) )
4614 Perl_croak(aTHX_ "Invalid version object");
4616 /* get the left hand term */
4617 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4618 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4621 /* and the right hand term */
4622 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4623 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4631 while ( i <= m && retval == 0 )
4633 left = SvIV(*av_fetch(lav,i,0));
4634 right = SvIV(*av_fetch(rav,i,0));
4642 /* tiebreaker for alpha with identical terms */
4643 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4645 if ( lalpha && !ralpha )
4649 else if ( ralpha && !lalpha)
4655 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4659 while ( i <= r && retval == 0 )
4661 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4662 retval = -1; /* not a match after all */
4668 while ( i <= l && retval == 0 )
4670 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4671 retval = +1; /* not a match after all */
4679 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4680 # define EMULATE_SOCKETPAIR_UDP
4683 #ifdef EMULATE_SOCKETPAIR_UDP
4685 S_socketpair_udp (int fd[2]) {
4687 /* Fake a datagram socketpair using UDP to localhost. */
4688 int sockets[2] = {-1, -1};
4689 struct sockaddr_in addresses[2];
4691 Sock_size_t size = sizeof(struct sockaddr_in);
4692 unsigned short port;
4695 memset(&addresses, 0, sizeof(addresses));
4698 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4699 if (sockets[i] == -1)
4700 goto tidy_up_and_fail;
4702 addresses[i].sin_family = AF_INET;
4703 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4704 addresses[i].sin_port = 0; /* kernel choses port. */
4705 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4706 sizeof(struct sockaddr_in)) == -1)
4707 goto tidy_up_and_fail;
4710 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4711 for each connect the other socket to it. */
4714 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4716 goto tidy_up_and_fail;
4717 if (size != sizeof(struct sockaddr_in))
4718 goto abort_tidy_up_and_fail;
4719 /* !1 is 0, !0 is 1 */
4720 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4721 sizeof(struct sockaddr_in)) == -1)
4722 goto tidy_up_and_fail;
4725 /* Now we have 2 sockets connected to each other. I don't trust some other
4726 process not to have already sent a packet to us (by random) so send
4727 a packet from each to the other. */
4730 /* I'm going to send my own port number. As a short.
4731 (Who knows if someone somewhere has sin_port as a bitfield and needs
4732 this routine. (I'm assuming crays have socketpair)) */
4733 port = addresses[i].sin_port;
4734 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4735 if (got != sizeof(port)) {
4737 goto tidy_up_and_fail;
4738 goto abort_tidy_up_and_fail;
4742 /* Packets sent. I don't trust them to have arrived though.
4743 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4744 connect to localhost will use a second kernel thread. In 2.6 the
4745 first thread running the connect() returns before the second completes,
4746 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4747 returns 0. Poor programs have tripped up. One poor program's authors'
4748 had a 50-1 reverse stock split. Not sure how connected these were.)
4749 So I don't trust someone not to have an unpredictable UDP stack.
4753 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4754 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4758 FD_SET((unsigned int)sockets[0], &rset);
4759 FD_SET((unsigned int)sockets[1], &rset);
4761 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4762 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4763 || !FD_ISSET(sockets[1], &rset)) {
4764 /* I hope this is portable and appropriate. */
4766 goto tidy_up_and_fail;
4767 goto abort_tidy_up_and_fail;
4771 /* And the paranoia department even now doesn't trust it to have arrive
4772 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4774 struct sockaddr_in readfrom;
4775 unsigned short buffer[2];
4780 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4781 sizeof(buffer), MSG_DONTWAIT,
4782 (struct sockaddr *) &readfrom, &size);
4784 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4786 (struct sockaddr *) &readfrom, &size);
4790 goto tidy_up_and_fail;
4791 if (got != sizeof(port)
4792 || size != sizeof(struct sockaddr_in)
4793 /* Check other socket sent us its port. */
4794 || buffer[0] != (unsigned short) addresses[!i].sin_port
4795 /* Check kernel says we got the datagram from that socket */
4796 || readfrom.sin_family != addresses[!i].sin_family
4797 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4798 || readfrom.sin_port != addresses[!i].sin_port)
4799 goto abort_tidy_up_and_fail;
4802 /* My caller (my_socketpair) has validated that this is non-NULL */
4805 /* I hereby declare this connection open. May God bless all who cross
4809 abort_tidy_up_and_fail:
4810 errno = ECONNABORTED;
4813 const int save_errno = errno;
4814 if (sockets[0] != -1)
4815 PerlLIO_close(sockets[0]);
4816 if (sockets[1] != -1)
4817 PerlLIO_close(sockets[1]);
4822 #endif /* EMULATE_SOCKETPAIR_UDP */
4824 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4826 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4827 /* Stevens says that family must be AF_LOCAL, protocol 0.
4828 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4833 struct sockaddr_in listen_addr;
4834 struct sockaddr_in connect_addr;
4839 || family != AF_UNIX
4842 errno = EAFNOSUPPORT;
4850 #ifdef EMULATE_SOCKETPAIR_UDP
4851 if (type == SOCK_DGRAM)
4852 return S_socketpair_udp(fd);
4855 listener = PerlSock_socket(AF_INET, type, 0);
4858 memset(&listen_addr, 0, sizeof(listen_addr));
4859 listen_addr.sin_family = AF_INET;
4860 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4861 listen_addr.sin_port = 0; /* kernel choses port. */
4862 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4863 sizeof(listen_addr)) == -1)
4864 goto tidy_up_and_fail;
4865 if (PerlSock_listen(listener, 1) == -1)
4866 goto tidy_up_and_fail;
4868 connector = PerlSock_socket(AF_INET, type, 0);
4869 if (connector == -1)
4870 goto tidy_up_and_fail;
4871 /* We want to find out the port number to connect to. */
4872 size = sizeof(connect_addr);
4873 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4875 goto tidy_up_and_fail;
4876 if (size != sizeof(connect_addr))
4877 goto abort_tidy_up_and_fail;
4878 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4879 sizeof(connect_addr)) == -1)
4880 goto tidy_up_and_fail;
4882 size = sizeof(listen_addr);
4883 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4886 goto tidy_up_and_fail;
4887 if (size != sizeof(listen_addr))
4888 goto abort_tidy_up_and_fail;
4889 PerlLIO_close(listener);
4890 /* Now check we are talking to ourself by matching port and host on the
4892 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4894 goto tidy_up_and_fail;
4895 if (size != sizeof(connect_addr)
4896 || listen_addr.sin_family != connect_addr.sin_family
4897 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4898 || listen_addr.sin_port != connect_addr.sin_port) {
4899 goto abort_tidy_up_and_fail;
4905 abort_tidy_up_and_fail:
4907 errno = ECONNABORTED; /* This would be the standard thing to do. */
4909 # ifdef ECONNREFUSED
4910 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4912 errno = ETIMEDOUT; /* Desperation time. */
4917 const int save_errno = errno;
4919 PerlLIO_close(listener);
4920 if (connector != -1)
4921 PerlLIO_close(connector);
4923 PerlLIO_close(acceptor);
4929 /* In any case have a stub so that there's code corresponding
4930 * to the my_socketpair in global.sym. */
4932 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4933 #ifdef HAS_SOCKETPAIR
4934 return socketpair(family, type, protocol, fd);
4943 =for apidoc sv_nosharing
4945 Dummy routine which "shares" an SV when there is no sharing module present.
4946 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4947 Exists to avoid test for a NULL function pointer and because it could
4948 potentially warn under some level of strict-ness.
4954 Perl_sv_nosharing(pTHX_ SV *sv)
4956 PERL_UNUSED_CONTEXT;
4957 PERL_UNUSED_ARG(sv);
4961 Perl_parse_unicode_opts(pTHX_ const char **popt)
4963 const char *p = *popt;
4968 opt = (U32) atoi(p);
4971 if (*p && *p != '\n' && *p != '\r')
4972 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4977 case PERL_UNICODE_STDIN:
4978 opt |= PERL_UNICODE_STDIN_FLAG; break;
4979 case PERL_UNICODE_STDOUT:
4980 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4981 case PERL_UNICODE_STDERR:
4982 opt |= PERL_UNICODE_STDERR_FLAG; break;
4983 case PERL_UNICODE_STD:
4984 opt |= PERL_UNICODE_STD_FLAG; break;
4985 case PERL_UNICODE_IN:
4986 opt |= PERL_UNICODE_IN_FLAG; break;
4987 case PERL_UNICODE_OUT:
4988 opt |= PERL_UNICODE_OUT_FLAG; break;
4989 case PERL_UNICODE_INOUT:
4990 opt |= PERL_UNICODE_INOUT_FLAG; break;
4991 case PERL_UNICODE_LOCALE:
4992 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4993 case PERL_UNICODE_ARGV:
4994 opt |= PERL_UNICODE_ARGV_FLAG; break;
4995 case PERL_UNICODE_UTF8CACHEASSERT:
4996 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4998 if (*p != '\n' && *p != '\r')
5000 "Unknown Unicode option letter '%c'", *p);
5006 opt = PERL_UNICODE_DEFAULT_FLAGS;
5008 if (opt & ~PERL_UNICODE_ALL_FLAGS)
5009 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5010 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5022 * This is really just a quick hack which grabs various garbage
5023 * values. It really should be a real hash algorithm which
5024 * spreads the effect of every input bit onto every output bit,
5025 * if someone who knows about such things would bother to write it.
5026 * Might be a good idea to add that function to CORE as well.
5027 * No numbers below come from careful analysis or anything here,
5028 * except they are primes and SEED_C1 > 1E6 to get a full-width
5029 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5030 * probably be bigger too.
5033 # define SEED_C1 1000003
5034 #define SEED_C4 73819
5036 # define SEED_C1 25747
5037 #define SEED_C4 20639
5041 #define SEED_C5 26107
5043 #ifndef PERL_NO_DEV_RANDOM
5048 # include <starlet.h>
5049 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5050 * in 100-ns units, typically incremented ever 10 ms. */
5051 unsigned int when[2];
5053 # ifdef HAS_GETTIMEOFDAY
5054 struct timeval when;
5060 /* This test is an escape hatch, this symbol isn't set by Configure. */
5061 #ifndef PERL_NO_DEV_RANDOM
5062 #ifndef PERL_RANDOM_DEVICE
5063 /* /dev/random isn't used by default because reads from it will block
5064 * if there isn't enough entropy available. You can compile with
5065 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5066 * is enough real entropy to fill the seed. */
5067 # define PERL_RANDOM_DEVICE "/dev/urandom"
5069 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5071 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5080 _ckvmssts(sys$gettim(when));
5081 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5083 # ifdef HAS_GETTIMEOFDAY
5084 PerlProc_gettimeofday(&when,NULL);
5085 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5088 u = (U32)SEED_C1 * when;
5091 u += SEED_C3 * (U32)PerlProc_getpid();
5092 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5093 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5094 u += SEED_C5 * (U32)PTR2UV(&when);
5100 Perl_get_hash_seed(pTHX)
5103 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5109 if (s && isDIGIT(*s))
5110 myseed = (UV)Atoul(s);
5112 #ifdef USE_HASH_SEED_EXPLICIT
5116 /* Compute a random seed */
5117 (void)seedDrand01((Rand_seed_t)seed());
5118 myseed = (UV)(Drand01() * (NV)UV_MAX);
5119 #if RANDBITS < (UVSIZE * 8)
5120 /* Since there are not enough randbits to to reach all
5121 * the bits of a UV, the low bits might need extra
5122 * help. Sum in another random number that will
5123 * fill in the low bits. */
5125 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5126 #endif /* RANDBITS < (UVSIZE * 8) */
5127 if (myseed == 0) { /* Superparanoia. */
5128 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5130 Perl_croak(aTHX_ "Your random numbers are not that random");
5133 PL_rehash_seed_set = TRUE;
5140 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5142 const char * const stashpv = CopSTASHPV(c);
5143 const char * const name = HvNAME_get(hv);
5144 PERL_UNUSED_CONTEXT;
5146 if (stashpv == name)
5148 if (stashpv && name)
5149 if (strEQ(stashpv, name))
5156 #ifdef PERL_GLOBAL_STRUCT
5159 Perl_init_global_struct(pTHX)
5161 struct perl_vars *plvarsp = NULL;
5162 #ifdef PERL_GLOBAL_STRUCT
5163 # define PERL_GLOBAL_STRUCT_INIT
5164 # include "opcode.h" /* the ppaddr and check */
5165 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5166 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5167 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5168 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5169 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5173 plvarsp = PL_VarsPtr;
5174 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5180 # define PERLVAR(var,type) /**/
5181 # define PERLVARA(var,n,type) /**/
5182 # define PERLVARI(var,type,init) plvarsp->var = init;
5183 # define PERLVARIC(var,type,init) plvarsp->var = init;
5184 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5185 # include "perlvars.h"
5191 # ifdef PERL_GLOBAL_STRUCT
5192 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5193 if (!plvarsp->Gppaddr)
5195 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5196 if (!plvarsp->Gcheck)
5198 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5199 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5201 # ifdef PERL_SET_VARS
5202 PERL_SET_VARS(plvarsp);
5204 # undef PERL_GLOBAL_STRUCT_INIT
5209 #endif /* PERL_GLOBAL_STRUCT */
5211 #ifdef PERL_GLOBAL_STRUCT
5214 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5216 #ifdef PERL_GLOBAL_STRUCT
5217 # ifdef PERL_UNSET_VARS
5218 PERL_UNSET_VARS(plvarsp);
5220 free(plvarsp->Gppaddr);
5221 free(plvarsp->Gcheck);
5222 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5228 #endif /* PERL_GLOBAL_STRUCT */
5233 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5235 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5236 * variable PERL_MEM_LOG will be consulted, and if the integer value
5237 * of that is true, the logging will happen. (The default is to
5238 * always log if the PERL_MEM_LOG define was in effect.)
5242 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5243 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5245 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5248 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5249 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5250 * in which case the environment variable PERL_MEM_LOG_FD will be
5251 * consulted for the file descriptor number to use.
5253 #ifndef PERL_MEM_LOG_FD
5254 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5258 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)
5260 #ifdef PERL_MEM_LOG_STDERR
5261 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5264 # ifdef PERL_MEM_LOG_ENV
5265 s = getenv("PERL_MEM_LOG");
5266 if (s ? atoi(s) : 0)
5269 /* We can't use SVs or PerlIO for obvious reasons,
5270 * so we'll use stdio and low-level IO instead. */
5271 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5272 # ifdef PERL_MEM_LOG_TIMESTAMP
5274 # ifdef HAS_GETTIMEOFDAY
5275 gettimeofday(&tv, 0);
5277 /* If there are other OS specific ways of hires time than
5278 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5279 * probably that they would be used to fill in the struct
5286 # ifdef PERL_MEM_LOG_TIMESTAMP
5289 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5290 " %s = %"IVdf": %"UVxf"\n",
5291 # ifdef PERL_MEM_LOG_TIMESTAMP
5292 (int)tv.tv_sec, (int)tv.tv_usec,
5294 filename, linenumber, funcname, n, typesize,
5295 typename, n * typesize, PTR2UV(newalloc));
5296 # ifdef PERL_MEM_LOG_ENV_FD
5297 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5298 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5300 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5309 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)
5311 #ifdef PERL_MEM_LOG_STDERR
5312 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5315 # ifdef PERL_MEM_LOG_ENV
5316 s = PerlEnv_getenv("PERL_MEM_LOG");
5317 if (s ? atoi(s) : 0)
5320 /* We can't use SVs or PerlIO for obvious reasons,
5321 * so we'll use stdio and low-level IO instead. */
5322 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5323 # ifdef PERL_MEM_LOG_TIMESTAMP
5325 gettimeofday(&tv, 0);
5331 # ifdef PERL_MEM_LOG_TIMESTAMP
5334 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5335 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5336 # ifdef PERL_MEM_LOG_TIMESTAMP
5337 (int)tv.tv_sec, (int)tv.tv_usec,
5339 filename, linenumber, funcname, n, typesize,
5340 typename, n * typesize, PTR2UV(oldalloc),
5342 # ifdef PERL_MEM_LOG_ENV_FD
5343 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5344 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5346 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5355 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5357 #ifdef PERL_MEM_LOG_STDERR
5358 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5361 # ifdef PERL_MEM_LOG_ENV
5362 s = PerlEnv_getenv("PERL_MEM_LOG");
5363 if (s ? atoi(s) : 0)
5366 /* We can't use SVs or PerlIO for obvious reasons,
5367 * so we'll use stdio and low-level IO instead. */
5368 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5369 # ifdef PERL_MEM_LOG_TIMESTAMP
5371 gettimeofday(&tv, 0);
5377 # ifdef PERL_MEM_LOG_TIMESTAMP
5380 "free: %s:%d:%s: %"UVxf"\n",
5381 # ifdef PERL_MEM_LOG_TIMESTAMP
5382 (int)tv.tv_sec, (int)tv.tv_usec,
5384 filename, linenumber, funcname,
5386 # ifdef PERL_MEM_LOG_ENV_FD
5387 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5388 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5390 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5398 #endif /* PERL_MEM_LOG */
5401 =for apidoc my_sprintf
5403 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5404 the length of the string written to the buffer. Only rare pre-ANSI systems
5405 need the wrapper function - usually this is a direct call to C<sprintf>.
5409 #ifndef SPRINTF_RETURNS_STRLEN
5411 Perl_my_sprintf(char *buffer, const char* pat, ...)
5414 va_start(args, pat);
5415 vsprintf(buffer, pat, args);
5417 return strlen(buffer);
5422 =for apidoc my_snprintf
5424 The C library C<snprintf> functionality, if available and
5425 standards-compliant (uses C<vsnprintf>, actually). However, if the
5426 C<vsnprintf> is not available, will unfortunately use the unsafe
5427 C<vsprintf> which can overrun the buffer (there is an overrun check,
5428 but that may be too late). Consider using C<sv_vcatpvf> instead, or
5429 getting C<vsnprintf>.
5434 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5439 va_start(ap, format);
5440 #ifdef HAS_VSNPRINTF
5441 retval = vsnprintf(buffer, len, format, ap);
5443 retval = vsprintf(buffer, format, ap);
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_snprintf buffer overflow");
5453 =for apidoc my_vsnprintf
5455 The C library C<vsnprintf> if available and standards-compliant.
5456 However, if if the C<vsnprintf> is not available, will unfortunately
5457 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5458 overrun check, but that may be too late). Consider using
5459 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5464 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5470 Perl_va_copy(ap, apc);
5471 # ifdef HAS_VSNPRINTF
5472 retval = vsnprintf(buffer, len, format, apc);
5474 retval = vsprintf(buffer, format, apc);
5477 # ifdef HAS_VSNPRINTF
5478 retval = vsnprintf(buffer, len, format, ap);
5480 retval = vsprintf(buffer, format, ap);
5482 #endif /* #ifdef NEED_VA_COPY */
5483 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5484 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5485 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5490 Perl_my_clearenv(pTHX)
5493 #if ! defined(PERL_MICRO)
5494 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5496 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5497 # if defined(USE_ENVIRON_ARRAY)
5498 # if defined(USE_ITHREADS)
5499 /* only the parent thread can clobber the process environment */
5500 if (PL_curinterp == aTHX)
5501 # endif /* USE_ITHREADS */
5503 # if ! defined(PERL_USE_SAFE_PUTENV)
5504 if ( !PL_use_safe_putenv) {
5506 if (environ == PL_origenviron)
5507 environ = (char**)safesysmalloc(sizeof(char*));
5509 for (i = 0; environ[i]; i++)
5510 (void)safesysfree(environ[i]);
5513 # else /* PERL_USE_SAFE_PUTENV */
5514 # if defined(HAS_CLEARENV)
5516 # elif defined(HAS_UNSETENV)
5517 int bsiz = 80; /* Most envvar names will be shorter than this. */
5518 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5519 char *buf = (char*)safesysmalloc(bufsiz);
5520 while (*environ != NULL) {
5521 char *e = strchr(*environ, '=');
5522 int l = e ? e - *environ : (int)strlen(*environ);
5524 (void)safesysfree(buf);
5525 bsiz = l + 1; /* + 1 for the \0. */
5526 buf = (char*)safesysmalloc(bufsiz);
5528 my_strlcpy(buf, *environ, l + 1);
5529 (void)unsetenv(buf);
5531 (void)safesysfree(buf);
5532 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5533 /* Just null environ and accept the leakage. */
5535 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5536 # endif /* ! PERL_USE_SAFE_PUTENV */
5538 # endif /* USE_ENVIRON_ARRAY */
5539 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5540 #endif /* PERL_MICRO */
5543 #ifdef PERL_IMPLICIT_CONTEXT
5545 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5546 the global PL_my_cxt_index is incremented, and that value is assigned to
5547 that module's static my_cxt_index (who's address is passed as an arg).
5548 Then, for each interpreter this function is called for, it makes sure a
5549 void* slot is available to hang the static data off, by allocating or
5550 extending the interpreter's PL_my_cxt_list array */
5552 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5554 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5559 /* this module hasn't been allocated an index yet */
5560 MUTEX_LOCK(&PL_my_ctx_mutex);
5561 *index = PL_my_cxt_index++;
5562 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5565 /* make sure the array is big enough */
5566 if (PL_my_cxt_size <= *index) {
5567 if (PL_my_cxt_size) {
5568 while (PL_my_cxt_size <= *index)
5569 PL_my_cxt_size *= 2;
5570 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5573 PL_my_cxt_size = 16;
5574 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5577 /* newSV() allocates one more than needed */
5578 p = (void*)SvPVX(newSV(size-1));
5579 PL_my_cxt_list[*index] = p;
5580 Zero(p, size, char);
5584 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5587 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5592 for (index = 0; index < PL_my_cxt_index; index++) {
5593 const char *key = PL_my_cxt_keys[index];
5594 /* try direct pointer compare first - there are chances to success,
5595 * and it's much faster.
5597 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5604 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5610 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5612 /* this module hasn't been allocated an index yet */
5613 MUTEX_LOCK(&PL_my_ctx_mutex);
5614 index = PL_my_cxt_index++;
5615 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5618 /* make sure the array is big enough */
5619 if (PL_my_cxt_size <= index) {
5620 int old_size = PL_my_cxt_size;
5622 if (PL_my_cxt_size) {
5623 while (PL_my_cxt_size <= index)
5624 PL_my_cxt_size *= 2;
5625 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5626 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5629 PL_my_cxt_size = 16;
5630 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5631 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5633 for (i = old_size; i < PL_my_cxt_size; i++) {
5634 PL_my_cxt_keys[i] = 0;
5635 PL_my_cxt_list[i] = 0;
5638 PL_my_cxt_keys[index] = my_cxt_key;
5639 /* newSV() allocates one more than needed */
5640 p = (void*)SvPVX(newSV(size-1));
5641 PL_my_cxt_list[index] = p;
5642 Zero(p, size, char);
5645 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5646 #endif /* PERL_IMPLICIT_CONTEXT */
5650 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5652 Size_t used, length, copy;
5655 length = strlen(src);
5656 if (size > 0 && used < size - 1) {
5657 copy = (length >= size - used) ? size - used - 1 : length;
5658 memcpy(dst + used, src, copy);
5659 dst[used + copy] = '\0';
5661 return used + length;
5667 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5669 Size_t length, copy;
5671 length = strlen(src);
5673 copy = (length >= size) ? size - 1 : length;
5674 memcpy(dst, src, copy);
5681 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5682 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5683 long _ftol( double ); /* Defined by VC6 C libs. */
5684 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5688 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5691 SV * const dbsv = GvSVn(PL_DBsub);
5692 /* We do not care about using sv to call CV;
5693 * it's for informational purposes only.
5697 if (!PERLDB_SUB_NN) {
5698 GV * const gv = CvGV(cv);
5700 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5701 || strEQ(GvNAME(gv), "END")
5702 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5703 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5704 /* Use GV from the stack as a fallback. */
5705 /* GV is potentially non-unique, or contain different CV. */
5706 SV * const tmp = newRV((SV*)cv);
5707 sv_setsv(dbsv, tmp);
5711 gv_efullname3(dbsv, gv, NULL);
5715 const int type = SvTYPE(dbsv);
5716 if (type < SVt_PVIV && type != SVt_IV)
5717 sv_upgrade(dbsv, SVt_PVIV);
5718 (void)SvIOK_on(dbsv);
5719 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5725 * c-indentation-style: bsd
5727 * indent-tabs-mode: t
5730 * ex: set ts=8 sts=4 sw=4 noet: