/* util.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "Very useful, no doubt, that was to Saruman; yet it seems that he was * not content." --Gandalf */ /* This file contains assorted utility routines. * Which is a polite way of saying any stuff that people couldn't think of * a better place for. Amongst other things, it includes the warning and * dieing stuff, plus wrappers for malloc code. */ #include "EXTERN.h" #define PERL_IN_UTIL_C #include "perl.h" #ifndef PERL_MICRO #include #ifndef SIG_ERR # define SIG_ERR ((Sighandler_t) -1) #endif #endif #ifdef __Lynx__ /* Missing protos on LynxOS */ int putenv(char *); #endif #ifdef I_SYS_WAIT # include #endif #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include # endif #endif #define FLUSH #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) # define FD_CLOEXEC 1 /* NeXT needs this */ #endif /* NOTE: Do not call the next three routines directly. Use the macros * in handy.h, so that we can easily redefine everything to do tracking of * allocated hunks back to the original New to track down any memory leaks. * XXX This advice seems to be widely ignored :-( --AD August 1996. */ /* paranoid version of system's malloc() */ Malloc_t Perl_safesysmalloc(MEM_SIZE size) 113590711 { dTHX; 113590711 Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(Perl_error_log, "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING 113590711 if ((long)size < 0) ###### Perl_croak_nocontext("panic: malloc"); #endif 113590711 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 113590711 PERL_ALLOC_CHECK(ptr); 113590711 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 113590711 if (ptr != Nullch) 113590711 return ptr; ###### else if (PL_nomemok) ###### return Nullch; else { /* Can't use PerlIO to write as it allocates memory */ PerlLIO_write(PerlIO_fileno(Perl_error_log), ###### PL_no_mem, strlen(PL_no_mem)); ###### my_exit(1); 113590711 return Nullch; } /*NOTREACHED*/ } /* paranoid version of system's realloc() */ Malloc_t Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) 10328774 { dTHX; 10328774 Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ #ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(Perl_error_log, "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ 10328774 if (!size) { ###### safesysfree(where); ###### return NULL; } 10328774 if (!where) 58 return safesysmalloc(size); #ifdef DEBUGGING 10328716 if ((long)size < 0) ###### Perl_croak_nocontext("panic: realloc"); #endif 10328716 ptr = (Malloc_t)PerlMem_realloc(where,size); 10328716 PERL_ALLOC_CHECK(ptr); 10328716 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); 10328716 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 10328716 if (ptr != Nullch) 10328716 return ptr; ###### else if (PL_nomemok) ###### return Nullch; else { /* Can't use PerlIO to write as it allocates memory */ PerlLIO_write(PerlIO_fileno(Perl_error_log), ###### PL_no_mem, strlen(PL_no_mem)); ###### my_exit(1); 10328774 return Nullch; } /*NOTREACHED*/ } /* safe version of system's free() */ Free_t Perl_safesysfree(Malloc_t where) 114722347 { dVAR; #ifdef PERL_IMPLICIT_SYS dTHX; #endif 114722347 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); 114722347 if (where) { 109660816 PerlMem_free(where); } } /* safe version of system's calloc() */ Malloc_t Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) ###### { dTHX; ###### Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size * count > 0xffff) { PerlIO_printf(Perl_error_log, "Allocation too large: %lx\n", size * count) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING ###### if ((long)size < 0 || (long)count < 0) ###### Perl_croak_nocontext("panic: calloc"); #endif ###### size *= count; ###### ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ ###### PERL_ALLOC_CHECK(ptr); ###### 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)); ###### if (ptr != Nullch) { ###### memset((void*)ptr, 0, size); ###### return ptr; } ###### else if (PL_nomemok) ###### return Nullch; else { /* Can't use PerlIO to write as it allocates memory */ PerlLIO_write(PerlIO_fileno(Perl_error_log), ###### PL_no_mem, strlen(PL_no_mem)); ###### my_exit(1); ###### return Nullch; } /*NOTREACHED*/ } /* These must be defined when not using Perl's malloc for binary * compatibility */ #ifndef MYMALLOC Malloc_t Perl_malloc (MEM_SIZE nbytes) ###### { dTHXs; ###### return (Malloc_t)PerlMem_malloc(nbytes); } Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) ###### { dTHXs; ###### return (Malloc_t)PerlMem_calloc(elements, size); } Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) ###### { dTHXs; ###### return (Malloc_t)PerlMem_realloc(where, nbytes); } Free_t Perl_mfree (Malloc_t where) ###### { dTHXs; ###### PerlMem_free(where); } #endif /* copy a string up to some (non-backslashed) delimiter, if any */ char * Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) 26893 { 26893 register I32 tolen; 158241 for (tolen = 0; from < fromend; from++, tolen++) { 158189 if (*from == '\\') { ###### if (from[1] == delim) ###### from++; else { ###### if (to < toend) ###### *to++ = *from; ###### tolen++; ###### from++; } } 158189 else if (*from == delim) 26841 break; 131348 if (to < toend) 131348 *to++ = *from; } 26893 if (to < toend) 26893 *to = '\0'; 26893 *retlen = tolen; 26893 return (char *)from; } /* return ptr to little string in big string, NULL if not found */ /* This routine was donated by Corey Satten. */ char * Perl_instr(pTHX_ register const char *big, register const char *little) 2307 { 2307 register I32 first; 2307 if (!little) ###### return (char*)big; 2307 first = *little++; 2307 if (!first) ###### return (char*)big; 37078 while (*big) { 35841 register const char *s, *x; 35841 if (*big++ != first) 33317 continue; 5048 for (x=big,s=little; *s; /**/ ) { 7730 if (!*x) ###### return Nullch; 7730 if (*s++ != *x++) { 1454 s--; break; } } 2524 if (!*s) 1070 return (char*)(big-1); } 1237 return Nullch; } /* same as instr but allow embedded nulls */ char * Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) 148758 { 148758 register const I32 first = *little; 148758 register const char *littleend = lend; 148758 if (!first && little >= littleend) ###### return (char*)big; 148758 if (bigend - big < littleend - little) ###### return Nullch; 148758 bigend -= littleend - little++; 3423820142 while (big <= bigend) { 3423776005 register const char *s, *x; 3423776005 if (*big++ != first) 3335145925 continue; 177260160 for (x=big,s=little; s < littleend; /**/ ) { 112026090 if (*s++ != *x++) { 88525459 s--; break; } } 88630080 if (s >= littleend) 104621 return (char*)(big-1); } 44137 return Nullch; } /* reverse of the above--find last substring */ char * Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) 64624 { 64624 register const char *bigbeg; 64624 register const I32 first = *little; 64624 register const char *littleend = lend; 64624 if (!first && little >= littleend) 2 return (char*)bigend; 64622 bigbeg = big; 64622 big = bigend - (littleend - little++); 356953 while (big >= bigbeg) { 356923 register const char *s, *x; 356923 if (*big-- != first) 291118 continue; 131610 for (x=big+2,s=little; s < littleend; /**/ ) { 28115 if (*s++ != *x++) { 1213 s--; break; } } 65805 if (s >= littleend) 64592 return (char*)(big+1); } 30 return Nullch; } #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ /* As a space optimization, we do not compile tables for strings of length 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are special-cased in fbm_instr(). If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ /* =head1 Miscellaneous Functions =for apidoc fbm_compile Analyses the string in order to make fast searches on it using fbm_instr() -- the Boyer-Moore algorithm. =cut */ void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 232514 { 232514 const register U8 *s; 232514 register U8 *table; 232514 register U32 i; 232514 STRLEN len; 232514 I32 rarest = 0; 232514 U32 frequency = 256; 232514 if (flags & FBMcf_TAIL) { 60846 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 60846 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ 60846 if (mg && mg->mg_len >= 0) 9 mg->mg_len++; } 232514 s = (U8*)SvPV_force_mutable(sv, len); 232514 SvUPGRADE(sv, SVt_PVBM); 232514 if (len == 0) /* TAIL might be on a zero-length string. */ ###### return; 232514 if (len > 2) { 93318 const unsigned char *sb; 93318 const U8 mlen = (len>255) ? 255 : (U8)len; 93318 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); 93318 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); 93318 s = table - 1 - FBM_TABLE_OFFSET; /* last char */ 93318 memset((void*)table, mlen, 256); 93318 table[-1] = (U8)flags; 93318 i = 0; 93318 sb = s - mlen + 1; /* first char (maybe) */ 990920 while (s >= sb) { 897602 if (table[*s] == mlen) 679390 table[*s] = (U8)i; 897602 s--, i++; } } 232514 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ 232514 SvVALID_on(sv); 232514 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ 1998142 for (i = 0; i < len; i++) { 1765628 if (PL_freq[s[i]] < frequency) { 360880 rarest = i; 360880 frequency = PL_freq[s[i]]; } } 232514 BmRARE(sv) = s[rarest]; 232514 BmPREVIOUS(sv) = (U16)rarest; 232514 BmUSEFUL(sv) = 100; /* Initial value */ 232514 if (flags & FBMcf_TAIL) 60846 SvTAIL_on(sv); DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", 232514 BmRARE(sv),BmPREVIOUS(sv))); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ /* If SvTAIL is actually due to \Z or \z, this gives false positives if multiline */ /* =for apidoc fbm_instr Returns the location of the SV in the string delimited by C and C. It returns C if the string can't be found. The C does not have to be fbm_compiled, but the search will not be as fast then. =cut */ char * Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) 5428343 { 5428343 register unsigned char *s; 5428343 STRLEN l; register const unsigned char *little 5428343 = (const unsigned char *)SvPV_const(littlestr,l); 5428343 register STRLEN littlelen = l; 5428343 register const I32 multiline = flags & FBMrf_MULTILINE; 5428343 if ((STRLEN)(bigend - big) < littlelen) { 157944 if ( SvTAIL(littlestr) && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && memEQ((char *)big, (char *)little, littlelen - 1)))) 69667 return (char*)big; 88277 return Nullch; } 5270399 if (littlelen <= 2) { /* Special-cased */ 3963925 if (littlelen == 1) { 3299503 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ /* Know that bigend != big. */ 674826 if (bigend[-1] == '\n') 526766 return (char *)(bigend - 1); 148060 return (char *) bigend; } 2624677 s = big; 32933610 while (s < bigend) { 32406701 if (*s == *little) 2097768 return (char *)s; 30308933 s++; } 526909 if (SvTAIL(littlestr)) 218 return (char *) bigend; 526691 return Nullch; } 664422 if (!littlelen) 2 return (char*)big; /* Cannot be SvTAIL! */ /* littlelen is 2 */ 664420 if (SvTAIL(littlestr) && !multiline) { 66865 if (bigend[-1] == '\n' && bigend[-2] == *little) 1847 return (char*)bigend - 2; 65018 if (bigend[-1] == *little) 29301 return (char*)bigend - 1; 35717 return Nullch; } { /* This should be better than FBM if c1 == c2, and almost as good otherwise: maybe better since we do less indirection. And we save a lot of memory by caching no table. */ 597555 const unsigned char c1 = little[0]; 597555 const unsigned char c2 = little[1]; 597555 s = big + 1; 597555 bigend--; 597555 if (c1 != c2) { 991773616 while (s <= bigend) { 991660653 if (s[0] == c2) { 4586650 if (s[-1] == c1) 256257 return (char*)s - 1; 4330393 s += 2; 4330393 continue; } next_chars: 994820892 if (s[0] == c1) { 7877332 if (s == bigend) 6698 goto check_1char_anchor; 7870634 if (s[1] == c2) 123745 return (char*)s; else { 7746889 s++; 7746889 goto next_chars; } } else 986943560 s += 2; } 97892 goto check_1char_anchor; } /* Now c1 == c2 */ 8309541 while (s <= bigend) { 8240953 if (s[0] == c1) { 82407 if (s[-1] == c1) 20259 return (char*)s - 1; 62148 if (s == bigend) 343 goto check_1char_anchor; 61805 if (s[1] == c1) 8702 return (char*)s; 53103 s += 3; } else 8158546 s += 2; } } check_1char_anchor: /* One char and anchor! */ 188592 if (SvTAIL(littlestr) && (*bigend == *little)) 31 return (char *)bigend; /* bigend is already decremented. */ 188561 return Nullch; } 1306474 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 18470 s = bigend - littlelen; 18470 if (s >= big && bigend[-1] == '\n' && *s == *little /* Automatically of length > 2 */ && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) { 175 return (char*)s; /* how sweet it is */ } 18295 if (s[1] == *little && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) { 6352 return (char*)s + 1; /* how sweet it is */ } 11943 return Nullch; } 1288004 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { 147021 char *b = ninstr((char*)big,(char*)bigend, 147021 (char*)little, (char*)little + littlelen); 147021 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ /* Chop \n from littlestr: */ ###### s = bigend - littlelen + 1; ###### if (*s == *little && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) { ###### return (char*)s; } ###### return Nullch; } 147021 return b; } { /* Do actual FBM. */ 1140983 register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; 1140983 const register unsigned char *oldlittle; 1140983 if (littlelen > (STRLEN)(bigend - big)) ###### return Nullch; 1140983 --littlelen; /* Last char found by table lookup */ 1140983 s = big + littlelen; 1140983 little += littlelen; /* last char */ 1140983 oldlittle = little; 1140983 if (s < bigend) { 92550937 register I32 tmp; top2: 92550937 if ((tmp = table[*s])) { 89713210 if ((s += tmp) < bigend) 89092353 goto top2; 2837727 goto check_end; } else { /* less expensive than calling strncmp() */ 2837727 register unsigned char * const olds = s; 2837727 tmp = littlelen; 5209300 while (tmp--) { 4695531 if (*--s == *--little) 2371573 continue; 2323958 s = olds + 1; /* here we pay the price for failure */ 2323958 little = oldlittle; 2323958 if (s < bigend) /* fake up continue to outer loop */ 2317601 goto top2; 513769 goto check_end; } 513769 return (char *)s; } } check_end: 627214 if ( s == bigend && (table[-1] & FBMcf_TAIL) && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) 120 return (char*)bigend - littlelen; 627094 return Nullch; } } /* start_shift, end_shift are positive quantities which give offsets of ends of some substring of bigstr. If "last" we want the last occurrence. old_posp is the way of communication between consequent calls if the next call needs to find the . The initial *old_posp should be -1. Note that we take into account SvTAIL, so one can get extra optimizations if _ALL flag is set. */ /* If SvTAIL is actually due to \Z or \z, this gives false positives if PL_multiline. In fact if !PL_multiline the authoritative answer is not supported yet. */ char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) 27 { 27 const register unsigned char *big; 27 register I32 pos; 27 register I32 previous; 27 register I32 first; 27 const register unsigned char *little; 27 register I32 stop_pos; 27 const register unsigned char *littleend; 27 I32 found = 0; 27 if (*old_posp == -1 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { cant_find: 3 if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { ###### little = (const unsigned char *)(SvPVX_const(littlestr)); ###### littleend = little + SvCUR(littlestr); ###### first = *little++; ###### goto check_tail; } 3 return Nullch; } 25 little = (const unsigned char *)(SvPVX_const(littlestr)); 25 littleend = little + SvCUR(littlestr); 25 first = *little++; /* The value of pos we can start at: */ 25 previous = BmPREVIOUS(littlestr); 25 big = (const unsigned char *)(SvPVX_const(bigstr)); /* The value of pos we can stop at: */ 25 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); 25 if (previous + start_shift > stop_pos) { /* stop_pos does not include SvTAIL in the count, so this check is incorrect (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 */ #if 0 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ goto check_tail; #endif 1 return Nullch; } 40 while (pos < previous + start_shift) { 17 if (!(pos += PL_screamnext[pos])) 1 goto cant_find; } 23 big -= previous; 23 do { 23 const register unsigned char *s, *x; 23 if (pos >= stop_pos) break; 22 if (big[pos] != first) ###### continue; 44 for (x=big+pos+1,s=little; s < littleend; /**/ ) { 16 if (*s++ != *x++) { ###### s--; break; } } 22 if (s == littleend) { 22 *old_posp = pos; 22 if (!last) return (char *)(big+pos); ###### found = 1; } ###### } while ( pos += PL_screamnext[pos] ); 1 if (last && found) ###### return (char *)(big+(*old_posp)); check_tail: 1 if (!SvTAIL(littlestr) || (end_shift > 0)) ###### return Nullch; /* Ignore the trailing "\n". This code is not microoptimized */ 1 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); 1 stop_pos = littleend - little; /* Actual littlestr len */ 1 if (stop_pos == 0) ###### return (char*)big; 1 big -= stop_pos; 1 if (*big == first && ((stop_pos == 1) || memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) 1 return (char*)big; ###### return Nullch; } I32 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) 18427 { 18427 register const U8 *a = (const U8 *)s1; 18427 register const U8 *b = (const U8 *)s2; 48929 while (len--) { 43366 if (*a != *b && *a != PL_fold[*b]) 12864 return 1; 30502 a++,b++; } 5563 return 0; } I32 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) 170 { dVAR; 170 register const U8 *a = (const U8 *)s1; 170 register const U8 *b = (const U8 *)s2; 367 while (len--) { 362 if (*a != *b && *a != PL_fold_locale[*b]) 165 return 1; 197 a++,b++; } 5 return 0; } /* copy a string to a safe spot */ /* =head1 Memory Management =for apidoc savepv Perl's version of C. Returns a pointer to a newly allocated string which is a duplicate of C. The size of the string is determined by C. The memory allocated for the new string can be freed with the C function. =cut */ char * Perl_savepv(pTHX_ const char *pv) 172190 { 172190 if (!pv) ###### return Nullch; else { 172190 char *newaddr; 172190 const STRLEN pvlen = strlen(pv)+1; 172190 New(902,newaddr,pvlen,char); 172190 return memcpy(newaddr,pv,pvlen); } } /* same thing but with a known length */ /* =for apidoc savepvn Perl's version of what C would be if it existed. Returns a pointer to a newly allocated string which is a duplicate of the first C bytes from C. The memory allocated for the new string can be freed with the C function. =cut */ char * Perl_savepvn(pTHX_ const char *pv, register I32 len) 7387794 { 7387794 register char *newaddr; 7387794 New(903,newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ 7387794 if (pv) { /* might not be null terminated */ 7387794 newaddr[len] = '\0'; 7387794 return (char *) CopyD(pv,newaddr,len,char); } else { ###### return (char *) ZeroD(newaddr,len+1,char); } } /* =for apidoc savesharedpv A version of C which allocates the duplicate string in memory which is shared between threads. =cut */ char * Perl_savesharedpv(pTHX_ const char *pv) ###### { ###### register char *newaddr; ###### STRLEN pvlen; ###### if (!pv) ###### return Nullch; ###### pvlen = strlen(pv)+1; ###### newaddr = (char*)PerlMemShared_malloc(pvlen); ###### if (!newaddr) { PerlLIO_write(PerlIO_fileno(Perl_error_log), ###### PL_no_mem, strlen(PL_no_mem)); ###### my_exit(1); } ###### return memcpy(newaddr,pv,pvlen); } /* =for apidoc savesvpv A version of C/C which gets the string to duplicate from the passed in SV using C =cut */ char * Perl_savesvpv(pTHX_ SV *sv) 1351 { 1351 STRLEN len; 1351 const char *pv = SvPV_const(sv, len); 1351 register char *newaddr; 1351 ++len; 1351 New(903,newaddr,len,char); 1351 return (char *) CopyD(pv,newaddr,len,char); } /* the SV for Perl_form() and mess() is not kept in an arena */ STATIC SV * S_mess_alloc(pTHX) 16625 { 16625 SV *sv; 16625 XPVMG *any; 16625 if (!PL_dirty) 16618 return sv_2mortal(newSVpvn("",0)); 7 if (PL_mess_sv) 4 return PL_mess_sv; /* Create as PVMG now, to avoid any upgrading later */ 3 New(905, sv, 1, SV); 3 Newz(905, any, 1, XPVMG); 3 SvFLAGS(sv) = SVt_PVMG; 3 SvANY(sv) = (void*)any; 3 SvPV_set(sv, 0); 3 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 3 PL_mess_sv = sv; 3 return sv; } #if defined(PERL_IMPLICIT_CONTEXT) char * Perl_form_nocontext(const char* pat, ...) { dTHX; char *retval; va_list args; va_start(args, pat); retval = vform(pat, &args); va_end(args); return retval; } #endif /* PERL_IMPLICIT_CONTEXT */ /* =head1 Miscellaneous Functions =for apidoc form Takes a sprintf-style format pattern and conventional (non-SV) arguments and returns the formatted string. (char *) Perl_form(pTHX_ const char* pat, ...) can be used any place a string (char *) is required: char * s = Perl_form("%d.%d",major,minor); Uses a single private buffer so if you want to format several strings you must explicitly copy the earlier strings away (and free the copies when you are done). =cut */ char * Perl_form(pTHX_ const char* pat, ...) 7598 { 7598 char *retval; 7598 va_list args; 7598 va_start(args, pat); 7598 retval = vform(pat, &args); 7598 va_end(args); 7598 return retval; } char * Perl_vform(pTHX_ const char *pat, va_list *args) 7598 { 7598 SV *sv = mess_alloc(); 7598 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 7598 return SvPVX(sv); } #if defined(PERL_IMPLICIT_CONTEXT) SV * Perl_mess_nocontext(const char *pat, ...) { dTHX; SV *retval; va_list args; va_start(args, pat); retval = vmess(pat, &args); va_end(args); return retval; } #endif /* PERL_IMPLICIT_CONTEXT */ SV * Perl_mess(pTHX_ const char *pat, ...) 106 { 106 SV *retval; 106 va_list args; 106 va_start(args, pat); 106 retval = vmess(pat, &args); 106 va_end(args); 106 return retval; } STATIC COP* S_closest_cop(pTHX_ COP *cop, const OP *o) 25885 { /* Look for PL_op starting from o. cop is the last COP we've seen. */ 25885 if (!o || o == PL_op) return cop; 18239 if (o->op_flags & OPf_KIDS) { 11107 OP *kid; 19606 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 18095 COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it * the get the file and line number. */ 18095 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) 29 cop = (COP *)kid; /* Keep searching, and return when we've found something. */ 18095 new_cop = closest_cop(cop, kid); 18095 if (new_cop) return new_cop; } } /* Nothing found. */ 8643 return Null(COP *); } SV * Perl_vmess(pTHX_ const char *pat, va_list *args) 9027 { 9027 SV *sv = mess_alloc(); 9027 static const char dgd[] = " during global destruction.\n"; 9027 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 9027 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { /* * Try and find the file and line for PL_op. This will usually be * PL_curcop, but it might be a cop that has been optimised away. We * can try to find such a cop by searching through the optree starting * from the sibling of PL_curcop. */ 7790 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); 7790 if (!cop) cop = PL_curcop; 7790 if (CopLINE(cop)) 7788 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, OutCopFILE(cop), (IV)CopLINE(cop)); 7790 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { 639 const bool line_mode = (RsSIMPLE(PL_rs) && 639 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); 639 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } 7790 sv_catpv(sv, PL_dirty ? dgd : ".\n"); } 9027 return sv; } void Perl_write_to_stderr(pTHX_ const char* message, int msglen) 1618 { dVAR; 1618 IO *io; 1618 MAGIC *mg; 1618 if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { 5 dSP; 5 ENTER; 5 SAVETMPS; 5 save_re_context(); 5 SAVESPTR(PL_stderrgv); 5 PL_stderrgv = Nullgv; 5 PUSHSTACKi(PERLSI_MAGIC); 5 PUSHMARK(SP); 5 EXTEND(SP,2); 5 PUSHs(SvTIED_obj((SV*)io, mg)); 5 PUSHs(sv_2mortal(newSVpvn(message, msglen))); 5 PUTBACK; 5 call_method("PRINT", G_SCALAR); 4 POPSTACK; 4 FREETMPS; 4 LEAVE; } else { #ifdef USE_SFIO /* SFIO can really mess with your errno */ const int e = errno; #endif 1613 PerlIO * const serr = Perl_error_log; 1613 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); 1613 (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; #endif } } /* Common code used by vcroak, vdie and vwarner */ STATIC void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) 1124 { 1124 HV *stash; 1124 GV *gv; 1124 CV *cv; /* sv_2cv might call Perl_croak() */ 1124 SV *olddiehook = PL_diehook; 1124 assert(PL_diehook); 1124 ENTER; 1124 SAVESPTR(PL_diehook); 1124 PL_diehook = Nullsv; 1124 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1124 LEAVE; 1124 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1120 dSP; 1120 SV *msg; 1120 ENTER; 1120 save_re_context(); 1120 if (message) { 1115 msg = newSVpvn(message, msglen); 1115 SvFLAGS(msg) |= utf8; 1115 SvREADONLY_on(msg); 1115 SAVEFREESV(msg); } else { 5 msg = ERRSV; } 1120 PUSHSTACKi(PERLSI_DIEHOOK); 1120 PUSHMARK(SP); 1120 XPUSHs(msg); 1120 PUTBACK; 1120 call_sv((SV*)cv, G_DISCARD); 1115 POPSTACK; 1115 LEAVE; } } STATIC const char * S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, I32* utf8) 4492 { dVAR; 4492 const char *message; 4492 if (pat) { 4482 SV *msv = vmess(pat, args); 4482 if (PL_errors && SvCUR(PL_errors)) { 44 sv_catsv(PL_errors, msv); 44 message = SvPV_const(PL_errors, *msglen); 44 SvCUR_set(PL_errors, 0); } else 4438 message = SvPV_const(msv,*msglen); 4482 *utf8 = SvUTF8(msv); } else { 10 message = Nullch; } DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die/croak: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); 4492 if (PL_diehook) { 1123 S_vdie_common(aTHX_ message, *msglen, *utf8); } 4487 return message; } OP * Perl_vdie(pTHX_ const char* pat, va_list *args) 1697 { 1697 const char *message; 1697 const int was_in_eval = PL_in_eval; 1697 STRLEN msglen; 1697 I32 utf8 = 0; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: curstack = %p, mainstack = %p\n", thr, PL_curstack, PL_mainstack)); 1697 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); 1692 PL_restartop = die_where(message, msglen); 1606 SvFLAGS(ERRSV) |= utf8; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", thr, PL_restartop, was_in_eval, PL_top_env)); 1606 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) 1606 JMPENV_JUMP(3); ###### return PL_restartop; } #if defined(PERL_IMPLICIT_CONTEXT) OP * Perl_die_nocontext(const char* pat, ...) { dTHX; OP *o; va_list args; va_start(args, pat); o = vdie(pat, &args); va_end(args); return o; } #endif /* PERL_IMPLICIT_CONTEXT */ OP * Perl_die(pTHX_ const char* pat, ...) 1687 { 1687 OP *o; 1687 va_list args; 1687 va_start(args, pat); 1687 o = vdie(pat, &args); ###### va_end(args); ###### return o; } void Perl_vcroak(pTHX_ const char* pat, va_list *args) 2795 { 2795 const char *message; 2795 STRLEN msglen; 2795 I32 utf8 = 0; 2795 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); 2795 if (PL_in_eval) { 2713 PL_restartop = die_where(message, msglen); 2708 SvFLAGS(ERRSV) |= utf8; 2708 JMPENV_JUMP(3); } 82 else if (!message) ###### message = SvPVx_const(ERRSV, msglen); 82 write_to_stderr(message, msglen); 81 my_failure_exit(); } #if defined(PERL_IMPLICIT_CONTEXT) void Perl_croak_nocontext(const char *pat, ...) { dTHX; va_list args; va_start(args, pat); vcroak(pat, &args); /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ /* =head1 Warning and Dieing =for apidoc croak This is the XSUB-writer's interface to Perl's C function. Normally call this function the same way you call the C C function. Calling C returns control directly to Perl, sidestepping the normal C order of execution. See C. If you want to throw an exception object, assign the object to C<$@> and then pass C to croak(): errsv = get_sv("@", TRUE); sv_setsv(errsv, exception_object); croak(Nullch); =cut */ void Perl_croak(pTHX_ const char *pat, ...) 2795 { 2795 va_list args; 2795 va_start(args, pat); 2795 vcroak(pat, &args); /* NOTREACHED */ va_end(args); } void Perl_vwarn(pTHX_ const char* pat, va_list *args) 4353 { dVAR; 4353 STRLEN msglen; 4353 SV * const msv = vmess(pat, args); 4353 const I32 utf8 = SvUTF8(msv); 4353 const char * const message = SvPV_const(msv, msglen); 4353 if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ 2909 SV * const oldwarnhook = PL_warnhook; 2909 CV * cv; 2909 HV * stash; 2909 GV * gv; 2909 ENTER; 2909 SAVESPTR(PL_warnhook); 2909 PL_warnhook = Nullsv; 2909 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 2909 LEAVE; 2909 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 2909 dSP; 2909 SV *msg; 2909 ENTER; 2909 save_re_context(); 2909 msg = newSVpvn(message, msglen); 2909 SvFLAGS(msg) |= utf8; 2909 SvREADONLY_on(msg); 2909 SAVEFREESV(msg); 2909 PUSHSTACKi(PERLSI_WARNHOOK); 2909 PUSHMARK(SP); 2909 XPUSHs(msg); 2909 PUTBACK; 2909 call_sv((SV*)cv, G_DISCARD); 2877 POPSTACK; 2877 LEAVE; 2877 return; } } 1444 write_to_stderr(message, msglen); } #if defined(PERL_IMPLICIT_CONTEXT) void Perl_warn_nocontext(const char *pat, ...) { dTHX; va_list args; va_start(args, pat); vwarn(pat, &args); va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ /* =for apidoc warn This is the XSUB-writer's interface to Perl's C function. Call this function the same way you call the C C function. See C. =cut */ void Perl_warn(pTHX_ const char *pat, ...) 317 { 317 va_list args; 317 va_start(args, pat); 317 vwarn(pat, &args); va_end(args); } #if defined(PERL_IMPLICIT_CONTEXT) void Perl_warner_nocontext(U32 err, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); vwarner(err, pat, &args); va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ void Perl_warner(pTHX_ U32 err, const char* pat,...) 4068 { 4068 va_list args; 4068 va_start(args, pat); 4068 vwarner(err, pat, &args); va_end(args); } void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) 4068 { dVAR; 4068 if (ckDEAD(err)) { 32 SV * const msv = vmess(pat, args); 32 STRLEN msglen; 32 const char *message = SvPV_const(msv, msglen); 32 const I32 utf8 = SvUTF8(msv); 32 if (PL_diehook) { 1 assert(message); 1 S_vdie_common(aTHX_ message, msglen, utf8); } 32 if (PL_in_eval) { 6 PL_restartop = die_where(message, msglen); 6 SvFLAGS(ERRSV) |= utf8; 6 JMPENV_JUMP(3); } 26 write_to_stderr(message, msglen); 26 my_failure_exit(); } else { 4036 Perl_vwarn(aTHX_ pat, args); } } /* implements the ckWARN? macros */ bool Perl_ckwarn(pTHX_ U32 w) 16022512 { 16022512 return ( isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && ( PL_curcop->cop_warnings == pWARN_ALL || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) || (unpackWARN2(w) && isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) || (unpackWARN3(w) && isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) || (unpackWARN4(w) && isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) ) ) || ( isLEXWARN_off && PL_dowarn & G_WARN_ON ) ; } /* implements the ckWARN?_d macro */ bool Perl_ckwarn_d(pTHX_ U32 w) 4972019 { 4972019 return isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || ( PL_curcop->cop_warnings != pWARN_NONE && ( isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) || (unpackWARN2(w) && isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) || (unpackWARN3(w) && isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) || (unpackWARN4(w) && isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) ) ) ; } /* since we've already done strlen() for both nam and val * we can use that info to make things faster than * sprintf(s, "%s=%s", nam, val) */ #define my_setenv_format(s, nam, nlen, val, vlen) \ Copy(nam, s, nlen, char); \ *(s+nlen) = '='; \ Copy(val, s+(nlen+1), vlen, char); \ *(s+(nlen+1+vlen)) = '\0' #ifdef USE_ENVIRON_ARRAY /* VMS' my_setenv() is in vms.c */ #if !defined(WIN32) && !defined(NETWARE) void Perl_my_setenv(pTHX_ const char *nam, const char *val) 223970 { dVAR; #ifdef USE_ITHREADS /* only parent thread can modify process environment */ if (PL_curinterp == aTHX) #endif { #ifndef PERL_USE_SAFE_PUTENV 223970 if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ 223922 register I32 i=setenv_getix(nam); /* where does it go? */ 223922 int nlen, vlen; 223922 if (environ == PL_origenviron) { /* need we copy environment? */ 4502 I32 j; 4502 I32 max; 4502 char **tmpenv; 4502 for (max = i; environ[max]; max++) ; 4502 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); 219272 for (j=0; j= 0; i++) ; return i ? 0 : -1; } #endif /* this is a drop-in replacement for bcopy() */ #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) char * Perl_my_bcopy(register const char *from,register char *to,register I32 len) { char *retval = to; if (from - to >= 0) { while (len--) *to++ = *from++; } else { to += len; from += len; while (len--) *(--to) = *(--from); } return retval; } #endif /* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * Perl_my_memset(register char *loc, register I32 ch, register I32 len) { char *retval = loc; while (len--) *loc++ = ch; return retval; } #endif /* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char * Perl_my_bzero(register char *loc, register I32 len) { char *retval = loc; while (len--) *loc++ = 0; return retval; } #endif /* this is a drop-in replacement for memcmp() */ #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 Perl_my_memcmp(const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; register I32 tmp; while (len--) { if ((tmp = *a++ - *b++)) return tmp; } return 0; } #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ #ifndef HAS_VPRINTF #ifdef USE_CHAR_VSPRINTF char * #else int #endif vsprintf(char *dest, const char *pat, char *args) { FILE fakebuf; fakebuf._ptr = dest; fakebuf._cnt = 32767; #ifndef _IOSTRG #define _IOSTRG 0 #endif fakebuf._flag = _IOWRT|_IOSTRG; _doprnt(pat, args, &fakebuf); /* what a kludge */ (void)putc('\0', &fakebuf); #ifdef USE_CHAR_VSPRINTF return(dest); #else return 0; /* perl doesn't use return value */ #endif } #endif /* HAS_VPRINTF */ #ifdef MYSWAP #if BYTEORDER != 0x4321 short Perl_my_swap(pTHX_ short s) { #if (BYTEORDER & 1) == 0 short result; result = ((s & 255) << 8) + ((s >> 8) & 255); return result; #else return s; #endif } long Perl_my_htonl(pTHX_ long l) { union { long result; char c[sizeof(long)]; } u; #if BYTEORDER == 0x1234 u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; u.c[3] = l & 255; return u.result; #else #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) Perl_croak(aTHX_ "Unknown BYTEORDER\n"); #else register I32 o; register I32 s; for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { u.c[o & 0xf] = (l >> s) & 255; } return u.result; #endif #endif } long Perl_my_ntohl(pTHX_ long l) { union { long l; char c[sizeof(long)]; } u; #if BYTEORDER == 0x1234 u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; u.c[3] = l & 255; return u.l; #else #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) Perl_croak(aTHX_ "Unknown BYTEORDER\n"); #else register I32 o; register I32 s; u.l = l; l = 0; for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { l |= (u.c[o & 0xf] & 255) << s; } return l; #endif #endif } #endif /* BYTEORDER != 0x4321 */ #endif /* MYSWAP */ /* * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. * If these functions are defined, * the BYTEORDER is neither 0x1234 nor 0x4321. * However, this is not assumed. * -DWS */ #define HTOLE(name,type) \ type \ name (register type n) \ { \ union { \ type value; \ char c[sizeof(type)]; \ } u; \ register I32 i; \ register I32 s = 0; \ for (i = 0; i < sizeof(u.c); i++, s += 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ return u.value; \ } #define LETOH(name,type) \ type \ name (register type n) \ { \ union { \ type value; \ char c[sizeof(type)]; \ } u; \ register I32 i; \ register I32 s = 0; \ u.value = n; \ n = 0; \ for (i = 0; i < sizeof(u.c); i++, s += 8) { \ n |= ((type)(u.c[i] & 0xFF)) << s; \ } \ return n; \ } /* * Big-endian byte order functions. */ #define HTOBE(name,type) \ type \ name (register type n) \ { \ union { \ type value; \ char c[sizeof(type)]; \ } u; \ register I32 i; \ register I32 s = 8*(sizeof(u.c)-1); \ for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ return u.value; \ } #define BETOH(name,type) \ type \ name (register type n) \ { \ union { \ type value; \ char c[sizeof(type)]; \ } u; \ register I32 i; \ register I32 s = 8*(sizeof(u.c)-1); \ u.value = n; \ n = 0; \ for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ n |= ((type)(u.c[i] & 0xFF)) << s; \ } \ return n; \ } /* * If we just can't do it... */ #define NOT_AVAIL(name,type) \ type \ name (register type n) \ { \ Perl_croak_nocontext(#name "() not available"); \ return n; /* not reached */ \ } #if defined(HAS_HTOVS) && !defined(htovs) HTOLE(htovs,short) #endif #if defined(HAS_HTOVL) && !defined(htovl) HTOLE(htovl,long) #endif #if defined(HAS_VTOHS) && !defined(vtohs) LETOH(vtohs,short) #endif #if defined(HAS_VTOHL) && !defined(vtohl) LETOH(vtohl,long) #endif #ifdef PERL_NEED_MY_HTOLE16 # if U16SIZE == 2 HTOLE(Perl_my_htole16,U16) # else NOT_AVAIL(Perl_my_htole16,U16) # endif #endif #ifdef PERL_NEED_MY_LETOH16 # if U16SIZE == 2 LETOH(Perl_my_letoh16,U16) # else NOT_AVAIL(Perl_my_letoh16,U16) # endif #endif #ifdef PERL_NEED_MY_HTOBE16 # if U16SIZE == 2 HTOBE(Perl_my_htobe16,U16) # else NOT_AVAIL(Perl_my_htobe16,U16) # endif #endif #ifdef PERL_NEED_MY_BETOH16 # if U16SIZE == 2 BETOH(Perl_my_betoh16,U16) # else NOT_AVAIL(Perl_my_betoh16,U16) # endif #endif #ifdef PERL_NEED_MY_HTOLE32 # if U32SIZE == 4 HTOLE(Perl_my_htole32,U32) # else NOT_AVAIL(Perl_my_htole32,U32) # endif #endif #ifdef PERL_NEED_MY_LETOH32 # if U32SIZE == 4 LETOH(Perl_my_letoh32,U32) # else NOT_AVAIL(Perl_my_letoh32,U32) # endif #endif #ifdef PERL_NEED_MY_HTOBE32 # if U32SIZE == 4 HTOBE(Perl_my_htobe32,U32) # else NOT_AVAIL(Perl_my_htobe32,U32) # endif #endif #ifdef PERL_NEED_MY_BETOH32 # if U32SIZE == 4 BETOH(Perl_my_betoh32,U32) # else NOT_AVAIL(Perl_my_betoh32,U32) # endif #endif #ifdef PERL_NEED_MY_HTOLE64 # if U64SIZE == 8 HTOLE(Perl_my_htole64,U64) # else NOT_AVAIL(Perl_my_htole64,U64) # endif #endif #ifdef PERL_NEED_MY_LETOH64 # if U64SIZE == 8 LETOH(Perl_my_letoh64,U64) # else NOT_AVAIL(Perl_my_letoh64,U64) # endif #endif #ifdef PERL_NEED_MY_HTOBE64 # if U64SIZE == 8 HTOBE(Perl_my_htobe64,U64) # else NOT_AVAIL(Perl_my_htobe64,U64) # endif #endif #ifdef PERL_NEED_MY_BETOH64 # if U64SIZE == 8 BETOH(Perl_my_betoh64,U64) # else NOT_AVAIL(Perl_my_betoh64,U64) # endif #endif #ifdef PERL_NEED_MY_HTOLES HTOLE(Perl_my_htoles,short) #endif #ifdef PERL_NEED_MY_LETOHS LETOH(Perl_my_letohs,short) #endif #ifdef PERL_NEED_MY_HTOBES HTOBE(Perl_my_htobes,short) #endif #ifdef PERL_NEED_MY_BETOHS BETOH(Perl_my_betohs,short) #endif #ifdef PERL_NEED_MY_HTOLEI HTOLE(Perl_my_htolei,int) #endif #ifdef PERL_NEED_MY_LETOHI LETOH(Perl_my_letohi,int) #endif #ifdef PERL_NEED_MY_HTOBEI HTOBE(Perl_my_htobei,int) #endif #ifdef PERL_NEED_MY_BETOHI BETOH(Perl_my_betohi,int) #endif #ifdef PERL_NEED_MY_HTOLEL HTOLE(Perl_my_htolel,long) #endif #ifdef PERL_NEED_MY_LETOHL LETOH(Perl_my_letohl,long) #endif #ifdef PERL_NEED_MY_HTOBEL HTOBE(Perl_my_htobel,long) #endif #ifdef PERL_NEED_MY_BETOHL BETOH(Perl_my_betohl,long) #endif void Perl_my_swabn(void *ptr, int n) 5153 { 5153 register char *s = (char *)ptr; 5153 register char *e = s + (n-1); 5153 register char tc; 23097 for (n /= 2; n > 0; s++, e--, n--) { 17944 tc = *s; 17944 *s = *e; 17944 *e = tc; } } PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) ###### { #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) ###### int p[2]; ###### register I32 This, that; ###### register Pid_t pid; ###### SV *sv; ###### I32 did_pipes = 0; ###### int pp[2]; ###### PERL_FLUSHALL_FOR_CHILD; ###### This = (*mode == 'w'); ###### that = !This; ###### if (PL_tainting) { ###### taint_env(); ###### taint_proper("Insecure %s%s", "EXEC"); } ###### if (PerlProc_pipe(p) < 0) ###### return Nullfp; /* Try for another pipe pair for error return */ ###### if (PerlProc_pipe(pp) >= 0) ###### did_pipes = 1; ###### while ((pid = PerlProc_fork()) < 0) { ###### if (errno != EAGAIN) { ###### PerlLIO_close(p[This]); ###### PerlLIO_close(p[that]); ###### if (did_pipes) { ###### PerlLIO_close(pp[0]); ###### PerlLIO_close(pp[1]); } ###### return Nullfp; } ###### sleep(5); } ###### if (pid == 0) { /* Child */ #undef THIS #undef THAT #define THIS that #define THAT This /* Close parent's end of error status pipe (if any) */ ###### if (did_pipes) { ###### PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) /* Close error pipe automatically if exec works */ ###### fcntl(pp[1], F_SETFD, FD_CLOEXEC); #endif } /* Now dup our end of _the_ pipe to right position */ ###### if (p[THIS] != (*mode == 'r')) { ###### PerlLIO_dup2(p[THIS], *mode == 'r'); ###### PerlLIO_close(p[THIS]); ###### if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ ###### PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ } else ###### PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ #if !defined(HAS_FCNTL) || !defined(F_SETFD) /* No automatic close - do it by hand */ # ifndef NOFILE # define NOFILE 20 # endif { int fd; for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { if (fd != pp[1]) PerlLIO_close(fd); } } #endif ###### do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); ###### PerlProc__exit(1); #undef THIS #undef THAT } /* Parent */ ###### do_execfree(); /* free any memory malloced by child on fork */ ###### if (did_pipes) ###### PerlLIO_close(pp[1]); /* Keep the lower of the two fd numbers */ ###### if (p[that] < p[This]) { ###### PerlLIO_dup2(p[This], p[that]); ###### PerlLIO_close(p[This]); ###### p[This] = p[that]; } else ###### PerlLIO_close(p[that]); /* close child's end of pipe */ LOCK_FDPID_MUTEX; ###### sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; ###### SvUPGRADE(sv,SVt_IV); ###### SvIV_set(sv, pid); ###### PL_forkprocess = pid; /* If we managed to get status pipe check for exec fail */ ###### if (did_pipes && pid > 0) { ###### int errkid; ###### int n = 0, n1; ###### while (n < sizeof(int)) { ###### n1 = PerlLIO_read(pp[0], (void*)(((char*)&errkid)+n), (sizeof(int)) - n); ###### if (n1 <= 0) ###### break; ###### n += n1; } ###### PerlLIO_close(pp[0]); ###### did_pipes = 0; ###### if (n) { /* Error */ ###### int pid2, status; ###### PerlLIO_close(p[This]); ###### if (n != sizeof(int)) ###### Perl_croak(aTHX_ "panic: kid popen errno read"); ###### do { ###### pid2 = wait4pid(pid, &status, 0); ###### } while (pid2 == -1 && errno == EINTR); ###### errno = errkid; /* Propagate errno from kid */ ###### return Nullfp; } } ###### if (did_pipes) ###### PerlLIO_close(pp[0]); ###### return PerlIO_fdopen(p[This], mode); #else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; #endif } /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) 4333 { 4333 int p[2]; 4333 register I32 This, that; 4333 register Pid_t pid; 4333 SV *sv; 4333 I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); 4333 I32 did_pipes = 0; 4333 int pp[2]; 4333 PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { return my_syspopen(aTHX_ cmd,mode); } #endif 4333 This = (*mode == 'w'); 4333 that = !This; 4333 if (doexec && PL_tainting) { 18 taint_env(); 10 taint_proper("Insecure %s%s", "EXEC"); } 4325 if (PerlProc_pipe(p) < 0) ###### return Nullfp; 4325 if (doexec && PerlProc_pipe(pp) >= 0) 4302 did_pipes = 1; 4325 while ((pid = PerlProc_fork()) < 0) { ###### if (errno != EAGAIN) { ###### PerlLIO_close(p[This]); ###### PerlLIO_close(p[that]); ###### if (did_pipes) { ###### PerlLIO_close(pp[0]); ###### PerlLIO_close(pp[1]); } ###### if (!doexec) ###### Perl_croak(aTHX_ "Can't fork"); ###### return Nullfp; } ###### sleep(5); } 8645 if (pid == 0) { 4320 GV* tmpgv; #undef THIS #undef THAT #define THIS that #define THAT This 4320 if (did_pipes) { 4297 PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) 4297 fcntl(pp[1], F_SETFD, FD_CLOEXEC); #endif } 4320 if (p[THIS] != (*mode == 'r')) { 4320 PerlLIO_dup2(p[THIS], *mode == 'r'); 4320 PerlLIO_close(p[THIS]); 4320 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 4320 PerlLIO_close(p[THAT]); } else ###### PerlLIO_close(p[THAT]); #ifndef OS2 4320 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) #ifndef NOFILE #define NOFILE 20 #endif { int fd; for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) if (fd != pp[1]) PerlLIO_close(fd); } #endif /* may or may not use the shell */ 4297 do_exec3(cmd, pp[1], did_pipes); ###### PerlProc__exit(1); } #endif /* defined OS2 */ 23 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { 23 SvREADONLY_off(GvSV(tmpgv)); 23 sv_setiv(GvSV(tmpgv), PerlProc_getpid()); 23 SvREADONLY_on(GvSV(tmpgv)); } #ifdef THREADS_HAVE_PIDS PL_ppid = (IV)getppid(); #endif 23 PL_forkprocess = 0; 23 hv_clear(PL_pidstatus); /* we have no children */ 23 return Nullfp; #undef THIS #undef THAT } 4325 do_execfree(); /* free any memory malloced by child on vfork */ 4325 if (did_pipes) 4302 PerlLIO_close(pp[1]); 4325 if (p[that] < p[This]) { 33 PerlLIO_dup2(p[This], p[that]); 33 PerlLIO_close(p[This]); 33 p[This] = p[that]; } else 4292 PerlLIO_close(p[that]); LOCK_FDPID_MUTEX; 4325 sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; 4325 SvUPGRADE(sv,SVt_IV); 4325 SvIV_set(sv, pid); 4325 PL_forkprocess = pid; 4325 if (did_pipes && pid > 0) { 4302 int errkid; 4302 int n = 0, n1; 4304 while (n < sizeof(int)) { 4302 n1 = PerlLIO_read(pp[0], (void*)(((char*)&errkid)+n), (sizeof(int)) - n); 4302 if (n1 <= 0) 4300 break; 2 n += n1; } 4302 PerlLIO_close(pp[0]); 4302 did_pipes = 0; 4302 if (n) { /* Error */ 2 int pid2, status; 2 PerlLIO_close(p[This]); 2 if (n != sizeof(int)) ###### Perl_croak(aTHX_ "panic: kid popen errno read"); 2 do { 2 pid2 = wait4pid(pid, &status, 0); 2 } while (pid2 == -1 && errno == EINTR); 2 errno = errkid; /* Propagate errno from kid */ 2 return Nullfp; } } 4323 if (did_pipes) ###### PerlLIO_close(pp[0]); 4323 return PerlIO_fdopen(p[This], mode); } #else #if defined(atarist) || defined(EPOC) FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. used 0 for 2nd parameter to PerlIO_importFILE; apparently not used */ return PerlIO_importFILE(popen(cmd, mode), 0); } #else #if defined(DJGPP) FILE *djgpp_popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. used 0 for 2nd parameter to PerlIO_importFILE; apparently not used */ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); } #endif #endif #endif /* !DOSISH */ /* this is called in parent before the fork() */ void Perl_atfork_lock(void) ###### { dVAR; #if defined(USE_ITHREADS) /* locks must be held in locking order (if any) */ # ifdef MYMALLOC MUTEX_LOCK(&PL_malloc_mutex); # endif OP_REFCNT_LOCK; #endif } /* this is called in both parent and child after the fork() */ void Perl_atfork_unlock(void) ###### { dVAR; #if defined(USE_ITHREADS) /* locks must be released in same order as in atfork_lock() */ # ifdef MYMALLOC MUTEX_UNLOCK(&PL_malloc_mutex); # endif OP_REFCNT_UNLOCK; #endif } Pid_t Perl_my_fork(void) 4506 { #if defined(HAS_FORK) 4506 Pid_t pid; #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) atfork_lock(); pid = fork(); atfork_unlock(); #else /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() * handlers elsewhere in the code */ 4506 pid = fork(); #endif 9005 return pid; #else /* this "canna happen" since nothing should be calling here if !HAS_FORK */ Perl_croak_nocontext("fork() not available"); return 0; #endif /* HAS_FORK */ } #ifdef DUMP_FDS void Perl_dump_fds(pTHX_ char *s) { int fd; Stat_t tmpstatbuf; PerlIO_printf(Perl_debug_log,"%s", s); for (fd = 0; fd < 32; fd++) { if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) PerlIO_printf(Perl_debug_log," %d",fd); } PerlIO_printf(Perl_debug_log,"\n"); return; } #endif /* DUMP_FDS */ #ifndef HAS_DUP2 int dup2(int oldfd, int newfd) { #if defined(HAS_FCNTL) && defined(F_DUPFD) if (oldfd == newfd) return oldfd; PerlLIO_close(newfd); return fcntl(oldfd, F_DUPFD, newfd); #else #define DUP2_MAX_FDS 256 int fdtmp[DUP2_MAX_FDS]; I32 fdx = 0; int fd; if (oldfd == newfd) return oldfd; PerlLIO_close(newfd); /* good enough for low fd's... */ while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { if (fdx >= DUP2_MAX_FDS) { PerlLIO_close(fd); fd = -1; break; } fdtmp[fdx++] = fd; } while (fdx > 0) PerlLIO_close(fdtmp[--fdx]); return fd; #endif } #endif #ifndef PERL_MICRO #ifdef HAS_SIGACTION #ifdef MACOS_TRADITIONAL /* We don't want restart behavior on MacOS */ #undef SA_RESTART #endif Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 1483 { dVAR; 1483 struct sigaction act, oact; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return SIG_ERR; #endif 1483 act.sa_handler = handler; 1483 sigemptyset(&act.sa_mask); 1483 act.sa_flags = 0; #ifdef SA_RESTART 1483 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) ###### act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 1483 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) ###### act.sa_flags |= SA_NOCLDWAIT; #endif 1483 if (sigaction(signo, &act, &oact) == -1) 1 return SIG_ERR; else 1482 return oact.sa_handler; } Sighandler_t Perl_rsignal_state(pTHX_ int signo) 4511 { 4511 struct sigaction oact; 4511 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) ###### return SIG_ERR; else 4511 return oact.sa_handler; } int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 17621 { dVAR; 17621 struct sigaction act; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return -1; #endif 17621 act.sa_handler = handler; 17621 sigemptyset(&act.sa_mask); 17621 act.sa_flags = 0; #ifdef SA_RESTART 17621 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) ###### act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 17621 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) ###### act.sa_flags |= SA_NOCLDWAIT; #endif 17621 return sigaction(signo, &act, save); } int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 13166 { dVAR; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return -1; #endif 13166 return sigaction(signo, save, (struct sigaction *)NULL); } #else /* !HAS_SIGACTION */ Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return SIG_ERR; #endif return PerlProc_signal(signo, handler); } static Signal_t sig_trap(int signo) { dVAR; PL_sig_trapped++; } Sighandler_t Perl_rsignal_state(pTHX_ int signo) { dVAR; Sighandler_t oldsig; #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return SIG_ERR; #endif PL_sig_trapped = 0; oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); if (PL_sig_trapped) PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return -1; #endif *save = PerlProc_signal(signo, handler); return (*save == SIG_ERR) ? -1 : 0; } int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return -1; #endif return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; } #endif /* !HAS_SIGACTION */ #endif /* !PERL_MICRO */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) 4322 { 4322 Sigsave_t hstat, istat, qstat; 4322 int status; 4322 SV **svp; 4322 Pid_t pid; 4322 Pid_t pid2; 4322 bool close_failed; 4322 int saved_errno = 0; #ifdef WIN32 int saved_win32_errno; #endif LOCK_FDPID_MUTEX; 4322 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); UNLOCK_FDPID_MUTEX; 4322 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 4322 SvREFCNT_dec(*svp); 4322 *svp = &PL_sv_undef; #ifdef OS2 if (pid == -1) { /* Opened by popen. */ return my_syspclose(ptr); } #endif 4322 if ((close_failed = (PerlIO_close(ptr) == EOF))) { 1 saved_errno = errno; #ifdef WIN32 saved_win32_errno = GetLastError(); #endif } #ifdef UTS if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif #ifndef PERL_MICRO 4322 rsignal_save(SIGHUP, SIG_IGN, &hstat); 4322 rsignal_save(SIGINT, SIG_IGN, &istat); 4322 rsignal_save(SIGQUIT, SIG_IGN, &qstat); #endif 4323 do { 4323 pid2 = wait4pid(pid, &status, 0); 4323 } while (pid2 == -1 && errno == EINTR); #ifndef PERL_MICRO 4322 rsignal_restore(SIGHUP, &hstat); 4322 rsignal_restore(SIGINT, &istat); 4322 rsignal_restore(SIGQUIT, &qstat); #endif 4322 if (close_failed) { 1 SETERRNO(saved_errno, 0); 1 return -1; } 4321 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); } #endif /* !DOSISH */ #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 4477 { 4477 I32 result = 0; 4477 if (!pid) ###### return -1; #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) { char spid[TYPE_CHARS(IV)]; if (pid > 0) { SV** svp; sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); if (svp && *svp != &PL_sv_undef) { *statusp = SvIVX(*svp); (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } } else { HE *entry; hv_iterinit(PL_pidstatus); if ((entry = hv_iternext(PL_pidstatus))) { SV *sv = hv_iterval(PL_pidstatus,entry); pid = atoi(hv_iterkey(entry,(I32*)statusp)); *statusp = SvIVX(sv); sprintf(spid, "%"IVdf, (IV)pid); (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } } } #endif #ifdef HAS_WAITPID # ifdef HAS_WAITPID_RUNTIME if (!HAS_WAITPID_RUNTIME) goto hard_way; # endif 4477 result = PerlProc_waitpid(pid,statusp,flags); 4477 goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); goto finish; #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) hard_way: #endif { if (flags) Perl_croak(aTHX_ "Can't do waitpid with flags"); else { while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) pidgone(result,*statusp); if (result < 0) *statusp = -1; } } #endif #if defined(HAS_WAITPID) || defined(HAS_WAIT4) finish: #endif 4477 if (result < 0 && errno == EINTR) { 2 PERL_ASYNC_CHECK(); } 4476 return result; } #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ void Perl_pidgone(pTHX_ Pid_t pid, int status) ###### { ###### register SV *sv; ###### char spid[TYPE_CHARS(IV)]; ###### sprintf(spid, "%"IVdf, (IV)pid); ###### sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); ###### SvUPGRADE(sv,SVt_IV); ###### SvIV_set(sv, status); return; } #if defined(atarist) || defined(OS2) || defined(EPOC) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 in os2ish.h. */ my_syspclose(PerlIO *ptr) #else I32 Perl_my_pclose(pTHX_ PerlIO *ptr) #endif { /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); I32 result = pclose(f); PerlIO_releaseFILE(ptr,f); return result; } #endif #if defined(DJGPP) int djgpp_pclose(); I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); I32 result = djgpp_pclose(f); result = (result << 8) & 0xff00; PerlIO_releaseFILE(ptr,f); return result; } #endif void Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) 107308 { 107308 register I32 todo; 107308 register const char *frombase = from; 107308 if (len == 1) { 65827 register const char c = *from; 25672967 while (count-- > 0) 25607140 *to++ = c; 41481 return; } 1876480 while (count-- > 0) { 27579296 for (todo = len; todo > 0; todo--) { 25744297 *to++ = *from++; } 1834999 from = frombase; } } #ifndef HAS_RENAME I32 Perl_same_dirent(pTHX_ const char *a, const char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); Stat_t tmpstatbuf1; Stat_t tmpstatbuf2; SV *tmpsv = sv_newmortal(); if (fa) fa++; else fa = a; if (fb) fb++; else fb = b; if (strNE(a,b)) return FALSE; if (fa == a) sv_setpvn(tmpsv, ".", 1); else sv_setpvn(tmpsv, a, fa - a); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) sv_setpvn(tmpsv, ".", 1); else sv_setpvn(tmpsv, b, fb - b); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; } #endif /* !HAS_RENAME */ char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags) 2466 { 2466 const char *xfound = Nullch; 2466 char *xfailed = Nullch; 2466 char tmpbuf[MAXPATHLEN]; 2466 register char *s; 2466 I32 len = 0; 2466 int retval; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL # define MAX_EXT_LEN 4 #endif #ifdef OS2 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL # define MAX_EXT_LEN 4 #endif #ifdef VMS # define SEARCH_EXTS ".pl", ".com", NULL # define MAX_EXT_LEN 4 #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS const char *exts[] = { SEARCH_EXTS }; const char **ext = search_ext ? search_ext : exts; int extidx = 0, i = 0; const char *curext = Nullch; #else 2466 PERL_UNUSED_ARG(search_ext); # define MAX_EXT_LEN 0 #endif /* * If dosearch is true and if scriptname does not contain path * delimiters, search the PATH for scriptname. * * If SEARCH_EXTS is also defined, will look for each * scriptname{SEARCH_EXTS} whenever scriptname is not found * while searching the PATH. * * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search * proceeds as follows: * If DOSISH or VMSISH: * + look for ./scriptname{,.foo,.bar} * + search the PATH for scriptname{,.foo,.bar} * * If !DOSISH: * + look *only* in the PATH for scriptname{,.foo,.bar} (note * this will not look in '.' if it's not in the PATH) */ 2466 tmpbuf[0] = '\0'; #ifdef VMS # ifdef ALWAYS_DEFTYPES len = strlen(scriptname); if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { int hasdir, idx = 0, deftypes = 1; bool seen_dot = 1; hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof tmpbuf) continue; /* don't search dir with too-long name */ strcat(tmpbuf, scriptname); #else /* !VMS */ #ifdef DOSISH if (strEQ(scriptname, "-")) dosearch = 0; if (dosearch) { /* Look in '.' first. */ const char *cur = scriptname; #ifdef SEARCH_EXTS if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ while (ext[i]) if (strEQ(ext[i++],curext)) { extidx = -1; /* already has an ext */ break; } do { #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); if (PerlLIO_stat(cur,&PL_statbuf) >= 0 && !S_ISDIR(PL_statbuf.st_mode)) { dosearch = 0; scriptname = cur; #ifdef SEARCH_EXTS break; #endif } #ifdef SEARCH_EXTS if (cur == scriptname) { len = strlen(scriptname); if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) break; /* FIXME? Convert to memcpy */ cur = strcpy(tmpbuf, scriptname); } } while (extidx >= 0 && ext[extidx] /* try an extension? */ && strcpy(tmpbuf+len, ext[extidx++])); #endif } #endif #ifdef MACOS_TRADITIONAL if (dosearch && !strchr(scriptname, ':') && (s = PerlEnv_getenv("Commands"))) #else 2466 if (dosearch && !strchr(scriptname, '/') #ifdef DOSISH && !strchr(scriptname, '\\') #endif && (s = PerlEnv_getenv("PATH"))) #endif { ###### bool seen_dot = 0; ###### PL_bufend = s + strlen(s); ###### while (s < PL_bufend) { #ifdef MACOS_TRADITIONAL s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, ',', &len); #else #if defined(atarist) || defined(DOSISH) for (len = 0; *s # ifdef atarist && *s != ',' # endif && *s != ';'; len++, s++) { if (len < sizeof tmpbuf) tmpbuf[len] = *s; } if (len < sizeof tmpbuf) tmpbuf[len] = '\0'; #else /* ! (atarist || DOSISH) */ ###### s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, ':', &len); #endif /* ! (atarist || DOSISH) */ #endif /* MACOS_TRADITIONAL */ ###### if (s < PL_bufend) ###### s++; ###### if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) ###### continue; /* don't search dir with too-long name */ #ifdef MACOS_TRADITIONAL if (len && tmpbuf[len - 1] != ':') tmpbuf[len++] = ':'; #else ###### if (len # if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' # endif ) ###### tmpbuf[len++] = '/'; ###### if (len == 2 && tmpbuf[0] == '.') ###### seen_dot = 1; #endif /* FIXME? Convert to memcpy by storing previous strlen(scriptname) */ ###### (void)strcpy(tmpbuf + len, scriptname); #endif /* !VMS */ #ifdef SEARCH_EXTS len = strlen(tmpbuf); if (extidx > 0) /* reset after previous loop */ extidx = 0; do { #endif ###### DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); ###### retval = PerlLIO_stat(tmpbuf,&PL_statbuf); ###### if (S_ISDIR(PL_statbuf.st_mode)) { ###### retval = -1; } #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ && extidx>=0 && ext[extidx] /* try an extension? */ && strcpy(tmpbuf+len, ext[extidx++]) ); #endif ###### if (retval < 0) ###### continue; ###### if (S_ISREG(PL_statbuf.st_mode) && cando(S_IRUSR,TRUE,&PL_statbuf) #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) && cando(S_IXUSR,TRUE,&PL_statbuf) #endif ) { ###### xfound = tmpbuf; /* bingo! */ ###### break; } ###### if (!xfailed) ###### xfailed = savepv(tmpbuf); } #ifndef DOSISH ###### if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))) #endif ###### seen_dot = 1; /* Disable message. */ ###### if (!xfound) { ###### if (flags & 1) { /* do or die? */ ###### Perl_croak(aTHX_ "Can't %s %s%s%s", (xfailed ? "execute" : "find"), (xfailed ? xfailed : scriptname), (xfailed ? "" : " on PATH"), (xfailed || seen_dot) ? "" : ", '.' not in PATH"); } ###### scriptname = Nullch; } ###### Safefree(xfailed); ###### scriptname = xfound; } 2466 return (scriptname ? savepv(scriptname) : Nullch); } #ifndef PERL_GET_CONTEXT_DEFINED void * Perl_get_context(void) ###### { dVAR; #if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) Perl_croak_nocontext("panic: pthread_getspecific"); return (void*)t; # else # ifdef I_MACH_CTHREADS return (void*)cthread_data(cthread_self()); # else return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); # endif # endif #else ###### return (void*)NULL; #endif } void Perl_set_context(void *t) ###### { dVAR; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else if (pthread_setspecific(PL_thr_key, t)) Perl_croak_nocontext("panic: pthread_setspecific"); # endif #else ###### PERL_UNUSED_ARG(t); #endif } #endif /* !PERL_GET_CONTEXT_DEFINED */ #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) struct perl_vars * Perl_GetVars(pTHX) { return &PL_Vars; } #endif char ** Perl_get_op_names(pTHX) 28 { 28 return (char **)PL_op_name; } char ** Perl_get_op_descs(pTHX) 2 { 2 return (char **)PL_op_desc; } const char * Perl_get_no_modify(pTHX) ###### { ###### return PL_no_modify; } U32 * Perl_get_opargs(pTHX) ###### { ###### return (U32 *)PL_opargs; } PPADDR_t* Perl_get_ppaddr(pTHX) ###### { dVAR; ###### return (PPADDR_t*)PL_ppaddr; } #ifndef HAS_GETENV_LEN char * Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) ###### { ###### char * const env_trans = PerlEnv_getenv(env_elem); ###### if (env_trans) ###### *len = strlen(env_trans); ###### return env_trans; } #endif MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) ###### { ###### const MGVTBL* result = Null(MGVTBL*); ###### switch(vtbl_id) { case want_vtbl_sv: ###### result = &PL_vtbl_sv; ###### break; case want_vtbl_env: ###### result = &PL_vtbl_env; ###### break; case want_vtbl_envelem: ###### result = &PL_vtbl_envelem; ###### break; case want_vtbl_sig: ###### result = &PL_vtbl_sig; ###### break; case want_vtbl_sigelem: ###### result = &PL_vtbl_sigelem; ###### break; case want_vtbl_pack: ###### result = &PL_vtbl_pack; ###### break; case want_vtbl_packelem: ###### result = &PL_vtbl_packelem; ###### break; case want_vtbl_dbline: ###### result = &PL_vtbl_dbline; ###### break; case want_vtbl_isa: ###### result = &PL_vtbl_isa; ###### break; case want_vtbl_isaelem: ###### result = &PL_vtbl_isaelem; ###### break; case want_vtbl_arylen: ###### result = &PL_vtbl_arylen; ###### break; case want_vtbl_glob: ###### result = &PL_vtbl_glob; ###### break; case want_vtbl_mglob: ###### result = &PL_vtbl_mglob; ###### break; case want_vtbl_nkeys: ###### result = &PL_vtbl_nkeys; ###### break; case want_vtbl_taint: ###### result = &PL_vtbl_taint; ###### break; case want_vtbl_substr: ###### result = &PL_vtbl_substr; ###### break; case want_vtbl_vec: ###### result = &PL_vtbl_vec; ###### break; case want_vtbl_pos: ###### result = &PL_vtbl_pos; ###### break; case want_vtbl_bm: ###### result = &PL_vtbl_bm; ###### break; case want_vtbl_fm: ###### result = &PL_vtbl_fm; ###### break; case want_vtbl_uvar: ###### result = &PL_vtbl_uvar; ###### break; case want_vtbl_defelem: ###### result = &PL_vtbl_defelem; ###### break; case want_vtbl_regexp: ###### result = &PL_vtbl_regexp; ###### break; case want_vtbl_regdata: ###### result = &PL_vtbl_regdata; ###### break; case want_vtbl_regdatum: ###### result = &PL_vtbl_regdatum; ###### break; #ifdef USE_LOCALE_COLLATE case want_vtbl_collxfrm: ###### result = &PL_vtbl_collxfrm; ###### break; #endif case want_vtbl_amagic: ###### result = &PL_vtbl_amagic; ###### break; case want_vtbl_amagicelem: ###### result = &PL_vtbl_amagicelem; ###### break; case want_vtbl_backref: ###### result = &PL_vtbl_backref; ###### break; case want_vtbl_utf8: ###### result = &PL_vtbl_utf8; break; } ###### return (MGVTBL*)result; } I32 Perl_my_fflush_all(pTHX) 4549 { #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) 4549 return PerlIO_flush(NULL); #else # if defined(HAS__FWALK) extern int fflush(FILE *); /* undocumented, unprototyped, but very useful BSDism */ extern void _fwalk(int (*)(FILE *)); _fwalk(&fflush); return 0; # else # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) long open_max = -1; # ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; # else # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); # else # ifdef FOPEN_MAX open_max = FOPEN_MAX; # else # ifdef OPEN_MAX open_max = OPEN_MAX; # else # ifdef _NFILE open_max = _NFILE; # endif # endif # endif # endif # endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) if (STDIO_STREAM_ARRAY[i]._file >= 0 && STDIO_STREAM_ARRAY[i]._file < open_max && STDIO_STREAM_ARRAY[i]._flag) PerlIO_flush(&STDIO_STREAM_ARRAY[i]); return 0; } # endif SETERRNO(EBADF,RMS_IFI); return EOF; # endif #endif } void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) 86 { 86 const char *func = op == OP_READLINE ? "readline" : /* "" not nice */ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 86 PL_op_desc[op]; 86 const char *pars = OP_IS_FILETEST(op) ? "" : "()"; 86 const char *type = OP_IS_SOCKET(op) || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) 86 ? "socket" : "filehandle"; 86 const char *name = NULL; 86 if (gv && isGV(gv)) { 81 name = GvENAME(gv); } 86 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { 12 if (ckWARN(WARN_IO)) { 12 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; 12 if (name && *name) 12 Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", name, direction); else ###### Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput", direction); } } else { 74 const char *vile; 74 I32 warn_type; 74 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { 55 vile = "closed"; 55 warn_type = WARN_CLOSED; } else { 19 vile = "unopened"; 19 warn_type = WARN_UNOPENED; } 74 if (ckWARN(warn_type)) { 72 if (name && *name) { 66 Perl_warner(aTHX_ packWARN(warn_type), "%s%s on %s %s %s", func, pars, vile, type, name); 65 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 16 Perl_warner( aTHX_ packWARN(warn_type), "\t(Are you trying to call %s%s on dirhandle %s?)\n", func, pars, name ); } else { 6 Perl_warner(aTHX_ packWARN(warn_type), "%s%s on %s %s", func, pars, vile, type); 6 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) ###### Perl_warner( aTHX_ packWARN(warn_type), "\t(Are you trying to call %s%s on dirhandle?)\n", func, pars ); } } } } #ifdef EBCDIC /* in ASCII order, not that it matters */ static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; int Perl_ebcdic_control(pTHX_ int ch) { if (ch > 'a') { const char *ctlp; if (islower(ch)) ch = toupper(ch); if ((ctlp = strchr(controllablechars, ch)) == 0) { Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); } if (ctlp == controllablechars) return('\177'); /* DEL */ else return((unsigned char)(ctlp - controllablechars - 1)); } else { /* Want uncontrol */ if (ch == '\177' || ch == -1) return('?'); else if (ch == '\157') return('\177'); else if (ch == '\174') return('\000'); else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ return('\036'); else if (ch == '\155') return('\037'); else if (0 < ch && ch < (sizeof(controllablechars) - 1)) return(controllablechars[ch+1]); else Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); } } #endif /* To workaround core dumps from the uninitialised tm_zone we get the * system to give us a reasonable struct to copy. This fix means that * strftime uses the tm_zone and tm_gmtoff values returned by * localtime(time()). That should give the desired result most of the * time. But probably not always! * * This does not address tzname aspects of NETaa14816. * */ #ifdef HAS_GNULIBC # ifndef STRUCT_TM_HASZONE # define STRUCT_TM_HASZONE # endif #endif #ifdef STRUCT_TM_HASZONE /* Backward compat */ # ifndef HAS_TM_TM_ZONE # define HAS_TM_TM_ZONE # endif #endif void Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ ###### { #ifdef HAS_TM_TM_ZONE ###### Time_t now; ###### const struct tm* my_tm; ###### (void)time(&now); ###### my_tm = localtime(&now); ###### if (my_tm) ###### Copy(my_tm, ptm, 1, struct tm); #else PERL_UNUSED_ARG(ptm); #endif } /* * mini_mktime - normalise struct tm values without the localtime() * semantics (and overhead) of mktime(). */ void Perl_mini_mktime(pTHX_ struct tm *ptm) ###### { ###### int yearday; ###### int secs; ###### int month, mday, year, jday; ###### int odd_cent, odd_year; #define DAYS_PER_YEAR 365 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) #define SECS_PER_HOUR (60*60) #define SECS_PER_DAY (24*SECS_PER_HOUR) /* parentheses deliberately absent on these two, otherwise they don't work */ #define MONTH_TO_DAYS 153/5 #define DAYS_TO_MONTH 5/153 /* offset to bias by March (month 4) 1st between month/mday & year finding */ #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ /* * Year/day algorithm notes: * * With a suitable offset for numeric value of the month, one can find * an offset into the year by considering months to have 30.6 (153/5) days, * using integer arithmetic (i.e., with truncation). To avoid too much * messing about with leap days, we consider January and February to be * the 13th and 14th month of the previous year. After that transformation, * we need the month index we use to be high by 1 from 'normal human' usage, * so the month index values we use run from 4 through 15. * * Given that, and the rules for the Gregorian calendar (leap years are those * divisible by 4 unless also divisible by 100, when they must be divisible * by 400 instead), we can simply calculate the number of days since some * arbitrary 'beginning of time' by futzing with the (adjusted) year number, * the days we derive from our month index, and adding in the day of the * month. The value used here is not adjusted for the actual origin which * it normally would use (1 January A.D. 1), since we're not exposing it. * We're only building the value so we can turn around and get the * normalised values for the year, month, day-of-month, and day-of-year. * * For going backward, we need to bias the value we're using so that we find * the right year value. (Basically, we don't want the contribution of * March 1st to the number to apply while deriving the year). Having done * that, we 'count up' the contribution to the year number by accounting for * full quadracenturies (400-year periods) with their extra leap days, plus * the contribution from full centuries (to avoid counting in the lost leap * days), plus the contribution from full quad-years (to count in the normal * leap days), plus the leftover contribution from any non-leap years. * At this point, if we were working with an actual leap day, we'll have 0 * days left over. This is also true for March 1st, however. So, we have * to special-case that result, and (earlier) keep track of the 'odd' * century and year contributions. If we got 4 extra centuries in a qcent, * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. * Otherwise, we add back in the earlier bias we removed (the 123 from * figuring in March 1st), find the month index (integer division by 30.6), * and the remainder is the day-of-month. We then have to convert back to * 'real' months (including fixing January and February from being 14/15 in * the previous year to being in the proper year). After that, to get * tm_yday, we work with the normalised year and get a new yearday value for * January 1st, which we subtract from the yearday value we had earlier, * representing the date we've re-built. This is done from January 1 * because tm_yday is 0-origin. * * Since POSIX time routines are only guaranteed to work for times since the * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm * applies Gregorian calendar rules even to dates before the 16th century * doesn't bother me. Besides, you'd need cultural context for a given * date to know whether it was Julian or Gregorian calendar, and that's * outside the scope for this routine. Since we convert back based on the * same rules we used to build the yearday, you'll only get strange results * for input which needed normalising, or for the 'odd' century years which * were leap years in the Julian calander but not in the Gregorian one. * I can live with that. * * This algorithm also fails to handle years before A.D. 1 gracefully, but * that's still outside the scope for POSIX time manipulation, so I don't * care. */ ###### year = 1900 + ptm->tm_year; ###### month = ptm->tm_mon; ###### mday = ptm->tm_mday; /* allow given yday with no month & mday to dominate the result */ ###### if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { ###### month = 0; ###### mday = 0; ###### jday = 1 + ptm->tm_yday; } else { ###### jday = 0; } ###### if (month >= 2) ###### month+=2; else ###### month+=14, year--; ###### yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; ###### yearday += month*MONTH_TO_DAYS + mday + jday; /* * Note that we don't know when leap-seconds were or will be, * so we have to trust the user if we get something which looks * like a sensible leap-second. Wild values for seconds will * be rationalised, however. */ ###### if ((unsigned) ptm->tm_sec <= 60) { ###### secs = 0; } else { ###### secs = ptm->tm_sec; ###### ptm->tm_sec = 0; } ###### secs += 60 * ptm->tm_min; ###### secs += SECS_PER_HOUR * ptm->tm_hour; ###### if (secs < 0) { ###### if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { /* got negative remainder, but need positive time */ /* back off an extra day to compensate */ ###### yearday += (secs/SECS_PER_DAY)-1; ###### secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); } else { ###### yearday += (secs/SECS_PER_DAY); ###### secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); } } ###### else if (secs >= SECS_PER_DAY) { ###### yearday += (secs/SECS_PER_DAY); ###### secs %= SECS_PER_DAY; } ###### ptm->tm_hour = secs/SECS_PER_HOUR; ###### secs %= SECS_PER_HOUR; ###### ptm->tm_min = secs/60; ###### secs %= 60; ###### ptm->tm_sec += secs; /* done with time of day effects */ /* * The algorithm for yearday has (so far) left it high by 428. * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to * bias it by 123 while trying to figure out what year it * really represents. Even with this tweak, the reverse * translation fails for years before A.D. 0001. * It would still fail for Feb 29, but we catch that one below. */ ###### jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ ###### yearday -= YEAR_ADJUST; ###### year = (yearday / DAYS_PER_QCENT) * 400; ###### yearday %= DAYS_PER_QCENT; ###### odd_cent = yearday / DAYS_PER_CENT; ###### year += odd_cent * 100; ###### yearday %= DAYS_PER_CENT; ###### year += (yearday / DAYS_PER_QYEAR) * 4; ###### yearday %= DAYS_PER_QYEAR; ###### odd_year = yearday / DAYS_PER_YEAR; ###### year += odd_year; ###### yearday %= DAYS_PER_YEAR; ###### if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ ###### month = 1; ###### yearday = 29; } else { ###### yearday += YEAR_ADJUST; /* recover March 1st crock */ ###### month = yearday*DAYS_TO_MONTH; ###### yearday -= month*MONTH_TO_DAYS; /* recover other leap-year adjustment */ ###### if (month > 13) { ###### month-=14; ###### year++; } else { ###### month-=2; } } ###### ptm->tm_year = year - 1900; ###### if (yearday) { ###### ptm->tm_mday = yearday; ###### ptm->tm_mon = month; } else { ###### ptm->tm_mday = 31; ###### ptm->tm_mon = month - 1; } /* re-build yearday based on Jan 1 to get tm_yday */ ###### year--; ###### yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; ###### yearday += 14*MONTH_TO_DAYS + 1; ###### ptm->tm_yday = jday - yearday; /* fix tm_wday if not overridden by caller */ ###### if ((unsigned)ptm->tm_wday > 6) ###### ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; } char * 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) ###### { #ifdef HAS_STRFTIME ###### char *buf; ###### int buflen; ###### struct tm mytm; ###### int len; ###### init_tm(&mytm); /* XXX workaround - see init_tm() above */ ###### mytm.tm_sec = sec; ###### mytm.tm_min = min; ###### mytm.tm_hour = hour; ###### mytm.tm_mday = mday; ###### mytm.tm_mon = mon; ###### mytm.tm_year = year; ###### mytm.tm_wday = wday; ###### mytm.tm_yday = yday; ###### mytm.tm_isdst = isdst; ###### mini_mktime(&mytm); /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) ###### STMT_START { ###### struct tm mytm2; ###### mytm2 = mytm; ###### mktime(&mytm2); #ifdef HAS_TM_TM_GMTOFF ###### mytm.tm_gmtoff = mytm2.tm_gmtoff; #endif #ifdef HAS_TM_TM_ZONE ###### mytm.tm_zone = mytm2.tm_zone; #endif } STMT_END; #endif ###### buflen = 64; ###### New(0, buf, buflen, char); ###### len = strftime(buf, buflen, fmt, &mytm); /* ** The following is needed to handle to the situation where ** tmpbuf overflows. Basically we want to allocate a buffer ** and try repeatedly. The reason why it is so complicated ** is that getting a return value of 0 from strftime can indicate ** one of the following: ** 1. buffer overflowed, ** 2. illegal conversion specifier, or ** 3. the format string specifies nothing to be returned(not ** an error). This could be because format is an empty string ** or it specifies %p that yields an empty string in some locale. ** If there is a better way to make it portable, go ahead by ** all means. */ ###### if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) ###### return buf; else { /* Possibly buf overflowed - try again with a bigger buf */ ###### const int fmtlen = strlen(fmt); ###### const int bufsize = fmtlen + buflen; ###### New(0, buf, bufsize, char); ###### while (buf) { ###### buflen = strftime(buf, bufsize, fmt, &mytm); ###### if (buflen > 0 && buflen < bufsize) ###### break; /* heuristic to prevent out-of-memory errors */ ###### if (bufsize > 100*fmtlen) { ###### Safefree(buf); ###### buf = NULL; ###### break; } ###### Renew(buf, bufsize*2, char); } ###### return buf; } #else Perl_croak(aTHX_ "panic: no strftime"); return NULL; #endif } #define SV_CWD_RETURN_UNDEF \ sv_setsv(sv, &PL_sv_undef); \ return FALSE #define SV_CWD_ISDOT(dp) \ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* =head1 Miscellaneous Functions =for apidoc getcwd_sv Fill the sv with current working directory =cut */ /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. * rewritten again by dougm, optimized for use with xs TARG, and to prefer * getcwd(3) if available * Comments from the orignal: * This is a faster version of getcwd. It's also more dangerous * because you might chdir out of a directory that you can't chdir * back into. */ int Perl_getcwd_sv(pTHX_ register SV *sv) 12 { #ifndef PERL_MICRO #ifndef INCOMPLETE_TAINTS 12 SvTAINTED_on(sv); #endif #ifdef HAS_GETCWD { 12 char buf[MAXPATHLEN]; /* Some getcwd()s automatically allocate a buffer of the given * size from the heap if they are given a NULL buffer pointer. * The problem is that this behaviour is not portable. */ 12 if (getcwd(buf, sizeof(buf) - 1)) { 12 sv_setpvn(sv, buf, strlen(buf)); 12 return TRUE; } else { ###### sv_setsv(sv, &PL_sv_undef); ###### return FALSE; } } #else Stat_t statbuf; int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; int pathlen=0; Direntry_t *dp; SvUPGRADE(sv, SVt_PV); if (PerlLIO_lstat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; } orig_cdev = statbuf.st_dev; orig_cino = statbuf.st_ino; cdev = orig_cdev; cino = orig_cino; for (;;) { DIR *dir; odev = cdev; oino = cino; if (PerlDir_chdir("..") < 0) { SV_CWD_RETURN_UNDEF; } if (PerlLIO_stat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; } cdev = statbuf.st_dev; cino = statbuf.st_ino; if (odev == cdev && oino == cino) { break; } if (!(dir = PerlDir_open("."))) { SV_CWD_RETURN_UNDEF; } while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN const int namelen = dp->d_namlen; #else const int namelen = strlen(dp->d_name); #endif /* skip . and .. */ if (SV_CWD_ISDOT(dp)) { continue; } if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { SV_CWD_RETURN_UNDEF; } tdev = statbuf.st_dev; tino = statbuf.st_ino; if (tino == oino && tdev == odev) { break; } } if (!dp) { SV_CWD_RETURN_UNDEF; } if (pathlen + namelen + 1 >= MAXPATHLEN) { SV_CWD_RETURN_UNDEF; } SvGROW(sv, pathlen + namelen + 1); if (pathlen) { /* shift down */ Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); } /* prepend current directory to the front */ *SvPVX(sv) = '/'; Move(dp->d_name, SvPVX(sv)+1, namelen, char); pathlen += (namelen + 1); #ifdef VOID_CLOSEDIR PerlDir_close(dir); #else if (PerlDir_close(dir) < 0) { SV_CWD_RETURN_UNDEF; } #endif } if (pathlen) { SvCUR_set(sv, pathlen); *SvEND(sv) = '\0'; SvPOK_only(sv); if (PerlDir_chdir(SvPVX_const(sv)) < 0) { SV_CWD_RETURN_UNDEF; } } if (PerlLIO_stat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; } cdev = statbuf.st_dev; cino = statbuf.st_ino; if (cdev != orig_cdev || cino != orig_cino) { Perl_croak(aTHX_ "Unstable directory path, " "current directory changed unexpectedly"); } return TRUE; #endif #else return FALSE; #endif } /* =for apidoc scan_version Returns a pointer to the next character after the parsed version string, as well as upgrading the passed in SV to an RV. Function must be called with an already existing SV like sv = newSV(0); s = scan_version(s,SV *sv, bool qv); Performs some preprocessing to the string to ensure that it has the correct characteristics of a version. Flags the object if it contains an underscore (which denotes this is a alpha version). The boolean qv denotes that the version should be interpreted as if it had multiple decimals, even if it doesn't. =cut */ const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) 19757 { 19757 const char *start = s; 19757 const char *pos; 19757 const char *last; 19757 int saw_period = 0; 19757 int saw_under = 0; 19757 int width = 3; 19757 AV *av = newAV(); 19757 SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ 19757 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ #ifndef NODEFAULT_SHAREKEYS 19757 HvSHAREKEYS_on(hv); /* key-sharing on by default */ #endif 19757 if (*s == 'v') { 1498 s++; /* get past 'v' */ 1498 qv = 1; /* force quoted version processing */ } 19757 last = pos = s; /* pre-scan the input string to check for decimals/underbars */ 112244 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) { 92491 if ( *pos == '.' ) { 21540 if ( saw_under ) 2 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); 21538 saw_period++ ; 21538 last = pos; } 70951 else if ( *pos == '_' ) { 107 if ( saw_under ) 2 Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); 105 saw_under = 1; 105 width = pos - last - 1; /* natural width of sub-version */ } 92487 pos++; } 19753 if ( saw_period > 1 ) { 3701 qv = 1; /* force quoted version processing */ } 19753 pos = s; 19753 if ( qv ) 3713 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); 19753 if ( saw_under ) { 101 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); } 19753 if ( !qv && width < 3 ) 59 hv_store((HV *)hv, "width", 5, newSViv(width), 0); 39665 while (isDIGIT(*pos)) 19912 pos++; 19753 if (!isALPHA(*pos)) { 43360 I32 rev; 63113 for (;;) { 43360 rev = 0; { /* this is atoi() that delimits on underscores */ 43360 const char *end = pos; 43360 I32 mult = 1; 43360 I32 orev; /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ 43360 if ( !qv && s > start+1 && saw_period == 1 ) { 16159 mult *= 100; 59585 while ( s < end ) { 43426 orev = rev; 43426 rev += (*s - '0') * mult; 43426 mult /= 10; 43426 if ( PERL_ABS(orev) > PERL_ABS(rev) ) ###### Perl_croak(aTHX_ "Integer overflow in version"); 43426 s++; 43426 if ( *s == '_' ) 79 s++; } } else { 54607 while (--end >= s) { 27406 orev = rev; 27406 rev += (*end - '0') * mult; 27406 mult *= 10; 27406 if ( PERL_ABS(orev) > PERL_ABS(rev) ) ###### Perl_croak(aTHX_ "Integer overflow in version"); } } } /* Append revision */ 43360 av_push(av, newSViv(rev)); 43360 if ( *pos == '.' && isDIGIT(pos[1]) ) 21534 s = ++pos; 21826 else if ( *pos == '_' && isDIGIT(pos[1]) ) 42 s = ++pos; 21784 else if ( isDIGIT(*pos) ) 2033 s = pos; else { 19751 s = pos; 19751 break; } 23609 if ( qv ) { 14944 while ( isDIGIT(*pos) ) 7494 pos++; } else { 16159 int digits = 0; 59644 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { 43485 if ( *pos != '_' ) 43426 digits++; 43485 pos++; } } } } 19753 if ( qv ) { /* quoted versions always get at least three terms*/ 3713 I32 len = av_len(av); /* This for loop appears to trigger a compiler bug on OS X, as it loops infinitely. Yes, len is negative. No, it makes no sense. Compiler in question is: gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) for ( len = 2 - len; len > 0; len-- ) av_push((AV *)sv, newSViv(0)); */ 3713 len = 2 - len; 3725 while (len-- > 0) 12 av_push(av, newSViv(0)); } 19753 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ 2 av_push(av, newSViv(0)); /* And finally, store the AV in the hash */ 19753 hv_store((HV *)hv, "version", 7, (SV *)av, 0); 19753 return s; } /* =for apidoc new_version Returns a new version object based on the passed in SV: SV *sv = new_version(SV *ver); Does not alter the passed in ver SV. See "upg_version" if you want to upgrade the SV. =cut */ SV * Perl_new_version(pTHX_ SV *ver) 18638 { 18638 SV *rv = newSV(0); 18638 if ( sv_derived_from(ver,"version") ) /* can just copy directly */ { 1518 I32 key; 1518 AV * const av = newAV(); 1518 AV *sav; /* This will get reblessed later if a derived class*/ 1518 SV* const hv = newSVrv(rv, "version"); 1518 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ #ifndef NODEFAULT_SHAREKEYS 1518 HvSHAREKEYS_on(hv); /* key-sharing on by default */ #endif 1518 if ( SvROK(ver) ) 1518 ver = SvRV(ver); /* Begin copying all of the elements */ 1518 if ( hv_exists((HV *)ver, "qv", 2) ) 1518 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); 1518 if ( hv_exists((HV *)ver, "alpha", 5) ) ###### hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); 1518 if ( hv_exists((HV*)ver, "width", 5 ) ) { ###### const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); ###### hv_store((HV *)hv, "width", 5, newSViv(width), 0); } 1518 sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE); /* This will get reblessed later if a derived class*/ 6072 for ( key = 0; key <= av_len(sav); key++ ) { 4554 const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); 4554 av_push(av, newSViv(rev)); } 1518 hv_store((HV *)hv, "version", 7, (SV *)av, 0); 1518 return rv; } #ifdef SvVOK 17120 if ( SvVOK(ver) ) { /* already a v-string */ 1497 char *version; 1497 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); 1497 const STRLEN len = mg->mg_len; 1497 version = savepvn( (const char*)mg->mg_ptr, len); 1497 sv_setpvn(rv,version,len); 1497 Safefree(version); } else { #endif 15623 sv_setsv(rv,ver); /* make a duplicate */ #ifdef SvVOK } #endif 17120 upg_version(rv); 17116 return rv; } /* =for apidoc upg_version In-place upgrade of the supplied SV to a version object. SV *sv = upg_version(SV *sv); Returns a pointer to the upgraded SV. =cut */ SV * Perl_upg_version(pTHX_ SV *ver) 19753 { 19753 char *version; 19753 bool qv = 0; 19753 if ( SvNOK(ver) ) /* may get too much accuracy */ { 11006 char tbuf[64]; 11006 sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); 11006 version = savepv(tbuf); } #ifdef SvVOK 8747 else if ( SvVOK(ver) ) { /* already a v-string */ 4 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); 4 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); 4 qv = 1; } #endif else /* must be a string or something like a string */ { 8743 version = savepv(SvPV_nolen(ver)); } 19753 (void)scan_version(version, ver, qv); 19749 Safefree(version); 19749 return ver; } /* =for apidoc vnumify Accepts a version object and returns the normalized floating point representation. Call like: sv = vnumify(rv); NOTE: you can pass either the object directly or the SV contained within the RV. =cut */ SV * Perl_vnumify(pTHX_ SV *vs) 2044 { 2044 I32 i, len, digit; 2044 int width; 2044 bool alpha = FALSE; 2044 SV * const sv = newSV(0); 2044 AV *av; 2044 if ( SvROK(vs) ) 2018 vs = SvRV(vs); /* see if various flags exist */ 2044 if ( hv_exists((HV*)vs, "alpha", 5 ) ) 11 alpha = TRUE; 2044 if ( hv_exists((HV*)vs, "width", 5 ) ) 9 width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE)); else 2035 width = 3; /* attempt to retrieve the version array */ 2044 if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) { ###### sv_catpvn(sv,"0",1); ###### return sv; } 2044 len = av_len(av); 2044 if ( len == -1 ) { ###### sv_catpvn(sv,"0",1); ###### return sv; } 2044 digit = SvIV(*av_fetch(av, 0, 0)); 2044 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); 3802 for ( i = 1 ; i < len ; i++ ) { 1758 digit = SvIV(*av_fetch(av, i, 0)); 1758 if ( width < 3 ) { 9 const int denom = (int)pow(10,(3-width)); 9 const div_t term = div((int)PERL_ABS(digit),denom); 9 Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem); } else { 1749 Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); } } 2044 if ( len > 0 ) { 2031 digit = SvIV(*av_fetch(av, len, 0)); 2031 if ( alpha && width == 3 ) /* alpha version */ 2 Perl_sv_catpv(aTHX_ sv,"_"); /* Don't display additional trailing zeros */ 2031 if ( digit > 0 ) 2026 Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); } else /* len == 1 */ { 13 sv_catpvn(sv,"000",3); } 2044 return sv; } /* =for apidoc vnormal Accepts a version object and returns the normalized string representation. Call like: sv = vnormal(rv); NOTE: you can pass either the object directly or the SV contained within the RV. =cut */ SV * Perl_vnormal(pTHX_ SV *vs) 81 { 81 I32 i, len, digit; 81 bool alpha = FALSE; 81 SV *sv = newSV(0); 81 AV *av; 81 if ( SvROK(vs) ) 42 vs = SvRV(vs); 81 if ( hv_exists((HV*)vs, "alpha", 5 ) ) 2 alpha = TRUE; 81 av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE); 81 len = av_len(av); 81 if ( len == -1 ) { ###### sv_catpvn(sv,"",0); ###### return sv; } 81 digit = SvIV(*av_fetch(av, 0, 0)); 81 Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit); 133 for ( i = 1 ; i <= len-1 ; i++ ) { 52 digit = SvIV(*av_fetch(av, i, 0)); 52 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); } 81 if ( len > 0 ) { /* handle last digit specially */ 75 digit = SvIV(*av_fetch(av, len, 0)); 75 if ( alpha ) 2 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); else 73 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); } 81 if ( len <= 2 ) { /* short version, must be at least three */ 116 for ( len = 2 - len; len != 0; len-- ) 37 sv_catpvn(sv,".0",2); } 81 return sv; } /* =for apidoc vstringify In order to maintain maximum compatibility with earlier versions of Perl, this function will return either the floating point notation or the multiple dotted notation, depending on whether the original version contained 1 or more dots, respectively =cut */ SV * Perl_vstringify(pTHX_ SV *vs) 49 { 49 I32 qv = 0; 49 if ( SvROK(vs) ) 1 vs = SvRV(vs); 49 if ( hv_exists((HV *)vs, "qv", 2) ) 36 qv = 1; 49 if ( qv ) 36 return vnormal(vs); else 13 return vnumify(vs); } /* =for apidoc vcmp Version object aware cmp. Both operands must already have been converted into version objects. =cut */ int Perl_vcmp(pTHX_ SV *lhv, SV *rhv) 15640 { 15640 I32 i,l,m,r,retval; 15640 bool lalpha = FALSE; 15640 bool ralpha = FALSE; 15640 I32 left = 0; 15640 I32 right = 0; 15640 AV *lav, *rav; 15640 if ( SvROK(lhv) ) 12585 lhv = SvRV(lhv); 15640 if ( SvROK(rhv) ) 14061 rhv = SvRV(rhv); /* get the left hand term */ 15640 lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE); 15640 if ( hv_exists((HV*)lhv, "alpha", 5 ) ) 48 lalpha = TRUE; /* and the right hand term */ 15640 rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE); 15640 if ( hv_exists((HV*)rhv, "alpha", 5 ) ) 64 ralpha = TRUE; 15640 l = av_len(lav); 15640 r = av_len(rav); 15640 m = l < r ? l : r; 15640 retval = 0; 15640 i = 0; 46584 while ( i <= m && retval == 0 ) { 30944 left = SvIV(*av_fetch(lav,i,0)); 30944 right = SvIV(*av_fetch(ra