X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=923907087084e601d0e4c46fc37ba90c37d00fa9;hb=7d654f43b92f51303a8d5388d3c3bfb7ebbceb22;hp=cee1fb7e611163426433a0b5acbf6c9aaae20b95;hpb=674bf1e7e5c24b5d07b342dd865aeecace505702;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index cee1fb7..9239070 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,7 @@ /* util.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -12,46 +13,40 @@ * 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 -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include -#endif - #ifndef SIG_ERR # define SIG_ERR ((Sighandler_t) -1) #endif #endif -#ifdef I_VFORK -# include -#endif - -/* Put this after #includes because fork and vfork prototypes may - conflict. -*/ -#ifndef HAS_VFORK -# define vfork fork +#ifdef __Lynx__ +/* Missing protos on LynxOS */ +int putenv(char *); #endif #ifdef I_SYS_WAIT # include #endif -#define FLUSH - -#ifdef LEAKTEST - -long xcount[MAXXCOUNT]; -long lastxcount[MAXXCOUNT]; -long xycount[MAXXCOUNT][MAXYCOUNT]; -long lastxycount[MAXXCOUNT][MAXYCOUNT]; - +#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 @@ -62,6 +57,17 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; * XXX This advice seems to be widely ignored :-( --AD August 1996. */ +static char * +S_write_no_mem(pTHX) +{ + dVAR; + /* 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); + NORETURN_FUNCTION_END; +} + /* paranoid version of system's malloc() */ Malloc_t @@ -76,6 +82,9 @@ Perl_safesysmalloc(MEM_SIZE size) my_exit(1); } #endif /* HAS_64K_LIMIT */ +#ifdef PERL_TRACK_MEMPOOL + size += sTHX; +#endif #ifdef DEBUGGING if ((long)size < 0) Perl_croak_nocontext("panic: malloc"); @@ -83,14 +92,34 @@ Perl_safesysmalloc(MEM_SIZE size) 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) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - if (ptr != Nullch) + if (ptr != NULL) { +#ifdef PERL_TRACK_MEMPOOL + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; +#endif + +#ifdef PERL_POISON + PoisonNew(((char *)ptr), size, char); +#endif + +#ifdef PERL_TRACK_MEMPOOL + header->interpreter = aTHX; + /* Link us into the list. */ + header->prev = &PL_memory_debug_header; + header->next = PL_memory_debug_header.next; + PL_memory_debug_header.next = header; + header->next->prev = header; +# ifdef PERL_POISON + header->size = size; +# endif + ptr = (Malloc_t)((char*)ptr+sTHX); +#endif return ptr; +} else if (PL_nomemok) - return Nullch; + return NULL; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; - my_exit(1); - return Nullch; + return write_no_mem(); } /*NOTREACHED*/ } @@ -120,6 +149,28 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (!where) return safesysmalloc(size); +#ifdef PERL_TRACK_MEMPOOL + where = (Malloc_t)((char*)where-sTHX); + size += sTHX; + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; + + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: realloc from wrong pool"); + } + assert(header->next->prev == header); + assert(header->prev->next == header); +# ifdef PERL_POISON + if (header->size > size) { + const MEM_SIZE freed_up = header->size - size; + char *start_of_freed = ((char *)where) + size; + PoisonFree(start_of_freed, freed_up, char); + } + header->size = size; +# endif + } +#endif #ifdef DEBUGGING if ((long)size < 0) Perl_croak_nocontext("panic: realloc"); @@ -130,14 +181,30 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - if (ptr != Nullch) + if (ptr != NULL) { +#ifdef PERL_TRACK_MEMPOOL + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; + +# ifdef PERL_POISON + if (header->size < size) { + const MEM_SIZE fresh = size - header->size; + char *start_of_fresh = ((char *)ptr) + size; + PoisonNew(start_of_fresh, fresh, char); + } +# endif + + header->next->prev = header; + header->prev->next = header; + + ptr = (Malloc_t)((char*)ptr+sTHX); +#endif return ptr; + } else if (PL_nomemok) - return Nullch; + return NULL; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; - my_exit(1); - return Nullch; + return write_no_mem(); } /*NOTREACHED*/ } @@ -147,12 +214,39 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { -#ifdef PERL_IMPLICIT_SYS +#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL) dTHX; +#else + dVAR; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { - /*SUPPRESS 701*/ +#ifdef PERL_TRACK_MEMPOOL + where = (Malloc_t)((char*)where-sTHX); + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; + + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: free from wrong pool"); + } + if (!header->prev) { + Perl_croak_nocontext("panic: duplicate free"); + } + if (!(header->next) || header->next->prev != header + || header->prev->next != header) { + Perl_croak_nocontext("panic: bad free"); + } + /* Unlink us from the chain. */ + header->next->prev = header->prev; + header->prev->next = header->next; +# ifdef PERL_POISON + PoisonNew(where, header->size, char); +# endif + /* Trigger the duplicate free warning. */ + header->next = NULL; + } +#endif PerlMem_free(where); } } @@ -177,171 +271,76 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Perl_croak_nocontext("panic: calloc"); #endif size *= count; +#ifdef PERL_TRACK_MEMPOOL + size += sTHX; +#endif 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) { + if (ptr != NULL) { memset((void*)ptr, 0, size); +#ifdef PERL_TRACK_MEMPOOL + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; + + header->interpreter = aTHX; + /* Link us into the list. */ + header->prev = &PL_memory_debug_header; + header->next = PL_memory_debug_header.next; + PL_memory_debug_header.next = header; + header->next->prev = header; +# ifdef PERL_POISON + header->size = size; +# endif + ptr = (Malloc_t)((char*)ptr+sTHX); + } +#endif return ptr; } else if (PL_nomemok) - return Nullch; - else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; - my_exit(1); - return Nullch; - } - /*NOTREACHED*/ + return NULL; + return write_no_mem(); } -#ifdef LEAKTEST +/* These must be defined when not using Perl's malloc for binary + * compatibility */ -struct mem_test_strut { - union { - long type; - char c[2]; - } u; - long size; -}; - -# define ALIGN sizeof(struct mem_test_strut) - -# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size) -# define typeof_chunk(ch) \ - (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100) -# define set_typeof_chunk(ch,t) \ - (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100) -#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \ - ? MAXYCOUNT - 1 \ - : ( (size) > 40 \ - ? ((size) - 1)/8 + 5 \ - : ((size) - 1)/4)) +#ifndef MYMALLOC -Malloc_t -Perl_safexmalloc(I32 x, MEM_SIZE size) +Malloc_t Perl_malloc (MEM_SIZE nbytes) { - register char* where = (char*)safemalloc(size + ALIGN); - - xcount[x] += size; - xycount[x][SIZE_TO_Y(size)]++; - set_typeof_chunk(where, x); - sizeof_chunk(where) = size; - return (Malloc_t)(where + ALIGN); + dTHXs; + return (Malloc_t)PerlMem_malloc(nbytes); } -Malloc_t -Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) { - char *where = (char*)wh; - - if (!wh) - return safexmalloc(0,size); - - { - MEM_SIZE old = sizeof_chunk(where - ALIGN); - int t = typeof_chunk(where - ALIGN); - register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); - - xycount[t][SIZE_TO_Y(old)]--; - xycount[t][SIZE_TO_Y(size)]++; - xcount[t] += size - old; - sizeof_chunk(new) = size; - return (Malloc_t)(new + ALIGN); - } + dTHXs; + return (Malloc_t)PerlMem_calloc(elements, size); } -void -Perl_safexfree(Malloc_t wh) +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) { - I32 x; - char *where = (char*)wh; - MEM_SIZE size; - - if (!where) - return; - where -= ALIGN; - size = sizeof_chunk(where); - x = where[0] + 100 * where[1]; - xcount[x] -= size; - xycount[x][SIZE_TO_Y(size)]--; - safefree(where); + dTHXs; + return (Malloc_t)PerlMem_realloc(where, nbytes); } -Malloc_t -Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) -{ - register char * where = (char*)safexmalloc(x, size * count + ALIGN); - xcount[x] += size; - xycount[x][SIZE_TO_Y(size)]++; - memset((void*)(where + ALIGN), 0, size * count); - set_typeof_chunk(where, x); - sizeof_chunk(where) = size; - return (Malloc_t)(where + ALIGN); -} - -STATIC void -S_xstat(pTHX_ int flag) -{ - register I32 i, j, total = 0; - I32 subtot[MAXYCOUNT]; - - for (j = 0; j < MAXYCOUNT; j++) { - subtot[j] = 0; - } - - PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); - for (i = 0; i < MAXXCOUNT; i++) { - total += xcount[i]; - for (j = 0; j < MAXYCOUNT; j++) { - subtot[j] += xycount[i][j]; - } - if (flag == 0 - ? xcount[i] /* Have something */ - : (flag == 2 - ? xcount[i] != lastxcount[i] /* Changed */ - : xcount[i] > lastxcount[i])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, - flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); - lastxcount[i] = xcount[i]; - for (j = 0; j < MAXYCOUNT; j++) { - if ( flag == 0 - ? xycount[i][j] /* Have something */ - : (flag == 2 - ? xycount[i][j] != lastxycount[i][j] /* Changed */ - : xycount[i][j] > lastxycount[i][j])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%3ld ", - flag == 2 - ? xycount[i][j] - lastxycount[i][j] - : xycount[i][j]); - lastxycount[i][j] = xycount[i][j]; - } else { - PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]); - } - } - PerlIO_printf(Perl_debug_log, "\n"); - } - } - if (flag != 2) { - PerlIO_printf(Perl_debug_log, "Total %7ld ", total); - for (j = 0; j < MAXYCOUNT; j++) { - if (subtot[j]) { - PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]); - } else { - PerlIO_printf(Perl_debug_log, " . "); - } - } - PerlIO_printf(Perl_debug_log, "\n"); - } +Free_t Perl_mfree (Malloc_t where) +{ + dTHXs; + PerlMem_free(where); } -#endif /* LEAKTEST */ +#endif /* copy a string up to some (non-backslashed) delimiter, if any */ char * -Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) +Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) { register I32 tolen; + PERL_UNUSED_CONTEXT; for (tolen = 0; from < fromend; from++, tolen++) { if (*from == '\\') { if (from[1] == delim) @@ -361,7 +360,7 @@ Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from if (to < toend) *to = '\0'; *retlen = tolen; - return from; + return (char *)from; } /* return ptr to little string in big string, NULL if not found */ @@ -370,8 +369,8 @@ Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from char * Perl_instr(pTHX_ register const char *big, register const char *little) { - register const char *s, *x; register I32 first; + PERL_UNUSED_CONTEXT; if (!little) return (char*)big; @@ -379,49 +378,49 @@ Perl_instr(pTHX_ register const char *big, register const char *little) if (!first) return (char*)big; while (*big) { + register const char *s, *x; if (*big++ != first) continue; for (x=big,s=little; *s; /**/ ) { if (!*x) - return Nullch; - if (*s++ != *x++) { - s--; + return NULL; + if (*s != *x) break; + else { + s++; + x++; } } if (!*s) return (char*)(big-1); } - return Nullch; + return NULL; } /* 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) +Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) { - register const char *s, *x; - register I32 first = *little; - register const char *littleend = lend; - - if (!first && little >= littleend) - return (char*)big; - if (bigend - big < littleend - little) - return Nullch; - bigend -= littleend - little++; - while (big <= bigend) { - if (*big++ != first) - continue; - for (x=big,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; - } - } - if (s >= littleend) - return (char*)(big-1); + PERL_UNUSED_CONTEXT; + if (little >= lend) + return (char*)big; + { + char first = *little++; + const char *s, *x; + bigend -= lend - little; + OUTER: + while (big <= bigend) { + if (*big++ != first) + goto OUTER; + for (x=big,s=little; s < lend; x++,s++) { + if (*s != *x) + goto OUTER; + } + return (char*)(big-1); + } } - return Nullch; + return NULL; } /* reverse of the above--find last substring */ @@ -430,27 +429,30 @@ char * Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) { register const char *bigbeg; - register const char *s, *x; - register I32 first = *little; - register const char *littleend = lend; + register const I32 first = *little; + register const char * const littleend = lend; + PERL_UNUSED_CONTEXT; - if (!first && little >= littleend) + if (little >= littleend) return (char*)bigend; bigbeg = big; big = bigend - (littleend - little++); while (big >= bigbeg) { + register const char *s, *x; if (*big-- != first) continue; for (x=big+2,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; + if (*s != *x) break; + else { + x++; + s++; } } if (s >= littleend) return (char*)(big+1); } - return Nullch; + return NULL; } #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ @@ -462,6 +464,8 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit 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() @@ -473,29 +477,30 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - register U8 *s; - register U8 *table; + dVAR; + register const U8 *s; register U32 i; STRLEN len; I32 rarest = 0; U32 frequency = 256; - if (flags & FBMcf_TAIL) - sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ - s = (U8*)SvPV_force(sv, len); - (void)SvUPGRADE(sv, SVt_PVBM); - if (len == 0) /* TAIL might be on on a zero-length string. */ + if (flags & FBMcf_TAIL) { + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ + if (mg && mg->mg_len >= 0) + mg->mg_len++; + } + s = (U8*)SvPV_force_mutable(sv, len); + SvUPGRADE(sv, SVt_PVBM); + if (len == 0) /* TAIL might be on a zero-length string. */ return; if (len > 2) { - U8 mlen; - unsigned char *sb; + const unsigned char *sb; + const U8 mlen = (len>255) ? 255 : (U8)len; + register U8 *table; - if (len > 255) - mlen = 255; - else - mlen = (U8)len; Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); - table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET); + table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); s = table - 1 - FBM_TABLE_OFFSET; /* last char */ memset((void*)table, mlen, 256); table[-1] = (U8)flags; @@ -507,10 +512,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s--, i++; } } - sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ + sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */ SvVALID_on(sv); - s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ + s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ for (i = 0; i < len; i++) { if (PL_freq[s[i]] < frequency) { rarest = i; @@ -518,7 +523,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) } } BmRARE(sv) = s[rarest]; - BmPREVIOUS(sv) = rarest; + BmPREVIOUS(sv) = (U16)rarest; BmUSEFUL(sv) = 100; /* Initial value */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); @@ -534,7 +539,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) =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 +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. @@ -546,18 +551,19 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { register unsigned char *s; STRLEN l; - register unsigned char *little = (unsigned char *)SvPV(littlestr,l); + register const unsigned char *little + = (const unsigned char *)SvPV_const(littlestr,l); register STRLEN littlelen = l; - register I32 multiline = flags & FBMrf_MULTILINE; + register const I32 multiline = flags & FBMrf_MULTILINE; - if (bigend - big < littlelen) { + if ((STRLEN)(bigend - big) < littlelen) { if ( SvTAIL(littlestr) - && (bigend - big == littlelen - 1) + && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && memEQ((char *)big, (char *)little, littlelen - 1)))) return (char*)big; - return Nullch; + return NULL; } if (littlelen <= 2) { /* Special-cased */ @@ -577,7 +583,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } if (SvTAIL(littlestr)) return (char *) bigend; - return Nullch; + return NULL; } if (!littlelen) return (char*)big; /* Cannot be SvTAIL! */ @@ -588,14 +594,14 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit return (char*)bigend - 2; if (bigend[-1] == *little) return (char*)bigend - 1; - return Nullch; + return NULL; } { /* 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. */ - register unsigned char c1 = little[0]; - register unsigned char c2 = little[1]; + const unsigned char c1 = little[0]; + const unsigned char c2 = little[1]; s = big + 1; bigend--; @@ -641,7 +647,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit check_1char_anchor: /* One char and anchor! */ if (SvTAIL(littlestr) && (*bigend == *little)) return (char *)bigend; /* bigend is already decremented. */ - return Nullch; + return NULL; } if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; @@ -656,10 +662,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { return (char*)s + 1; /* how sweet it is */ } - return Nullch; + return NULL; } if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { - char *b = ninstr((char*)big,(char*)bigend, + char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ @@ -670,17 +676,17 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { return (char*)s; } - return Nullch; + return NULL; } return b; } { /* Do actual FBM. */ - register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; - register unsigned char *oldlittle; + register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET; + register const unsigned char *oldlittle; - if (littlelen > bigend - big) - return Nullch; + if (littlelen > (STRLEN)(bigend - big)) + return NULL; --littlelen; /* Last char found by table lookup */ s = big + littlelen; @@ -690,22 +696,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 tmp; top2: - /*SUPPRESS 560*/ if ((tmp = table[*s])) { -#ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top2; - } - s += tmp; -#else if ((s += tmp) < bigend) goto top2; -#endif goto check_end; } else { /* less expensive than calling strncmp() */ - register unsigned char *olds = s; + register unsigned char * const olds = s; tmp = littlelen; @@ -726,13 +723,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; - return Nullch; + return NULL; } } /* start_shift, end_shift are positive quantities which give offsets of ends of some substring of bigstr. - If `last' we want the last occurence. + 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. @@ -748,14 +745,14 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - register unsigned char *s, *x; - register unsigned char *big; + dVAR; + register const unsigned char *big; register I32 pos; register I32 previous; register I32 first; - register unsigned char *little; + register const unsigned char *little; register I32 stop_pos; - register unsigned char *littleend; + register const unsigned char *littleend; I32 found = 0; if (*old_posp == -1 @@ -764,20 +761,20 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift cant_find: if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { - little = (unsigned char *)(SvPVX(littlestr)); + little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; goto check_tail; } - return Nullch; + return NULL; } - little = (unsigned char *)(SvPVX(littlestr)); + little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; /* The value of pos we can start at: */ previous = BmPREVIOUS(littlestr); - big = (unsigned char *)(SvPVX(bigstr)); + big = (const unsigned char *)(SvPVX_const(bigstr)); /* The value of pos we can stop at: */ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); if (previous + start_shift > stop_pos) { @@ -789,33 +786,15 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ goto check_tail; #endif - return Nullch; + return NULL; } while (pos < previous + start_shift) { if (!(pos += PL_screamnext[pos])) goto cant_find; } -#ifdef POINTERRIGOR - do { - if (pos >= stop_pos) break; - if (big[pos-previous] != first) - continue; - for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; - } - } - if (s == littleend) { - *old_posp = pos; - if (!last) return (char *)(big+pos-previous); - found = 1; - } - } while ( pos += PL_screamnext[pos] ); - return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch; -#else /* !POINTERRIGOR */ big -= previous; do { + register const unsigned char *s, *x; if (pos >= stop_pos) break; if (big[pos] != first) continue; @@ -833,12 +812,11 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } while ( pos += PL_screamnext[pos] ); if (last && found) return (char *)(big+(*old_posp)); -#endif /* POINTERRIGOR */ check_tail: if (!SvTAIL(littlestr) || (end_shift > 0)) - return Nullch; + return NULL; /* Ignore the trailing "\n". This code is not microoptimized */ - big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr)); + big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); stop_pos = littleend - little; /* Actual littlestr len */ if (stop_pos == 0) return (char*)big; @@ -847,14 +825,16 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift && ((stop_pos == 1) || memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) return (char*)big; - return Nullch; + return NULL; } I32 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) { - register U8 *a = (U8 *)s1; - register U8 *b = (U8 *)s2; + register const U8 *a = (const U8 *)s1; + register const U8 *b = (const U8 *)s2; + PERL_UNUSED_CONTEXT; + while (len--) { if (*a != *b && *a != PL_fold[*b]) return 1; @@ -866,8 +846,11 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) I32 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) { - register U8 *a = (U8 *)s1; - register U8 *b = (U8 *)s2; + dVAR; + register const U8 *a = (const U8 *)s1; + register const U8 *b = (const U8 *)s2; + PERL_UNUSED_CONTEXT; + while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) return 1; @@ -879,21 +862,30 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) /* copy a string to a safe spot */ /* +=head1 Memory Management + =for apidoc savepv -Copy a string to a safe spot. This does not use an SV. +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 *sv) +Perl_savepv(pTHX_ const char *pv) { - register char *newaddr; - - New(902,newaddr,strlen(sv)+1,char); - (void)strcpy(newaddr,sv); - return newaddr; + PERL_UNUSED_CONTEXT; + if (!pv) + return NULL; + else { + char *newaddr; + const STRLEN pvlen = strlen(pv)+1; + Newx(newaddr,pvlen,char); + return memcpy(newaddr,pv,pvlen); + } } /* same thing but with a known length */ @@ -901,42 +893,99 @@ Perl_savepv(pTHX_ const char *sv) /* =for apidoc savepvn -Copy a string to a safe spot. The C indicates number of bytes to -copy. This does not use an SV. +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) +{ + register char *newaddr; + PERL_UNUSED_CONTEXT; + + Newx(newaddr,len+1,char); + /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ + if (pv) { + /* might not be null terminated */ + newaddr[len] = '\0'; + 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 NULL; + + pvlen = strlen(pv)+1; + newaddr = (char*)PerlMemShared_malloc(pvlen); + if (!newaddr) { + return write_no_mem(); + } + 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_savepvn(pTHX_ const char *sv, register I32 len) +Perl_savesvpv(pTHX_ SV *sv) { + STRLEN len; + const char * const pv = SvPV_const(sv, len); register char *newaddr; - New(903,newaddr,len+1,char); - Copy(sv,newaddr,len,char); /* might not be null terminated */ - newaddr[len] = '\0'; /* is now */ - return newaddr; + ++len; + Newx(newaddr,len,char); + 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) { + dVAR; SV *sv; XPVMG *any; if (!PL_dirty) - return sv_2mortal(newSVpvn("",0)); + return sv_2mortal(newSVpvs("")); if (PL_mess_sv) return PL_mess_sv; /* Create as PVMG now, to avoid any upgrading later */ - New(905, sv, 1, SV); - Newz(905, any, 1, XPVMG); + Newx(sv, 1, SV); + Newxz(any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; + SvPV_set(sv, NULL); SvREFCNT(sv) = 1 << 30; /* practically infinite */ PL_mess_sv = sv; return sv; @@ -956,6 +1005,26 @@ Perl_form_nocontext(const char* pat, ...) } #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, ...) { @@ -970,8 +1039,8 @@ Perl_form(pTHX_ const char* pat, ...) char * Perl_vform(pTHX_ const char *pat, va_list *args) { - SV *sv = mess_alloc(); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + SV * const sv = mess_alloc(); + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); return SvPVX(sv); } @@ -1000,103 +1069,225 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } +STATIC const COP* +S_closest_cop(pTHX_ const COP *cop, const OP *o) +{ + dVAR; + /* Look for PL_op starting from o. cop is the last COP we've seen. */ + + if (!o || o == PL_op) + return cop; + + if (o->op_flags & OPf_KIDS) { + const OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { + const COP *new_cop; + + /* If the OP_NEXTSTATE has been optimised away we can still use it + * the get the file and line number. */ + + if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + cop = (const COP *)kid; + + /* Keep searching, and return when we've found something. */ + + new_cop = closest_cop(cop, kid); + if (new_cop) + return new_cop; + } + } + + /* Nothing found. */ + + return NULL; +} + SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { - SV *sv = mess_alloc(); - static char dgd[] = " during global destruction.\n"; + dVAR; + SV * const sv = mess_alloc(); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - if (CopLINE(PL_curcop)) + /* + * 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. + */ + + const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + if (!cop) + cop = PL_curcop; + + if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + OutCopFILE(cop), (IV)CopLINE(cop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { - bool line_mode = (RsSIMPLE(PL_rs) && - SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); + const bool line_mode = (RsSIMPLE(PL_rs) && + SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); 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))); + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + line_mode ? "line" : "chunk", + (IV)IoLINES(GvIOp(PL_last_in_gv))); } -#ifdef USE_THREADS - if (thr->tid) - Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); -#endif - sv_catpv(sv, PL_dirty ? dgd : ".\n"); + if (PL_dirty) + sv_catpvs(sv, " during global destruction"); + sv_catpvs(sv, ".\n"); } return sv; } -OP * -Perl_vdie(pTHX_ const char* pat, va_list *args) +void +Perl_write_to_stderr(pTHX_ const char* message, int msglen) +{ + dVAR; + IO *io; + MAGIC *mg; + + if (PL_stderrgv && SvREFCNT(PL_stderrgv) + && (io = GvIO(PL_stderrgv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { + dSP; + ENTER; + SAVETMPS; + + save_re_context(); + SAVESPTR(PL_stderrgv); + PL_stderrgv = NULL; + + PUSHSTACKi(PERLSI_MAGIC); + + PUSHMARK(SP); + EXTEND(SP,2); + PUSHs(SvTIED_obj((SV*)io, mg)); + PUSHs(sv_2mortal(newSVpvn(message, msglen))); + PUTBACK; + call_method("PRINT", G_SCALAR); + + POPSTACK; + FREETMPS; + LEAVE; + } + else { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + const int e = errno; +#endif + PerlIO * const serr = Perl_error_log; + + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); + (void)PerlIO_flush(serr); +#ifdef USE_SFIO + errno = e; +#endif + } +} + +/* Common code used by vcroak, vdie, vwarn and vwarner */ + +STATIC bool +S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) { - char *message; - int was_in_eval = PL_in_eval; + dVAR; HV *stash; GV *gv; CV *cv; - SV *msv; - STRLEN msglen; + SV **const hook = warn ? &PL_warnhook : &PL_diehook; + /* sv_2cv might call Perl_croak() or Perl_warner() */ + SV * const oldhook = *hook; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); + assert(oldhook); + + ENTER; + SAVESPTR(*hook); + *hook = NULL; + cv = sv_2cv(oldhook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + save_re_context(); + if (warn) { + SAVESPTR(*hook); + *hook = NULL; + } + if (warn || message) { + msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } + + PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); + POPSTACK; + LEAVE; + return TRUE; + } + return FALSE; +} + +STATIC const char * +S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, + I32* utf8) +{ + dVAR; + const char *message; if (pat) { - msv = vmess(pat, args); + SV * const msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); + message = SvPV_const(PL_errors, *msglen); SvCUR_set(PL_errors, 0); } else - message = SvPV(msv,msglen); + message = SvPV_const(msv,*msglen); + *utf8 = SvUTF8(msv); } else { - message = Nullch; - msglen = 0; + message = NULL; } DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: message = %s\ndiehook = %p\n", + "%p: die/croak: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - if (message) { - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } - - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } + S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); } + return message; +} - PL_restartop = die_where(message, msglen); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", +OP * +Perl_vdie(pTHX_ const char* pat, va_list *args) +{ + dVAR; + const char *message; + const int was_in_eval = PL_in_eval; + STRLEN msglen; + I32 utf8 = 0; + + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p: die: curstack = %p, mainstack = %p\n", + thr, PL_curstack, PL_mainstack)); + + message = vdie_croak_common(pat, args, &msglen, &utf8); + + PL_restartop = die_where(message, msglen); + 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)); if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) JMPENV_JUMP(3); @@ -1131,80 +1322,22 @@ Perl_die(pTHX_ const char* pat, ...) void Perl_vcroak(pTHX_ const char* pat, va_list *args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; + dVAR; + const char *message; STRLEN msglen; + I32 utf8 = 0; - if (pat) { - msv = vmess(pat, args); - if (PL_errors && SvCUR(PL_errors)) { - sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); - SvCUR_set(PL_errors, 0); - } - else - message = SvPV(msv,msglen); - } - else { - message = Nullch; - msglen = 0; - } - - DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", - PTR2UV(thr), message)); - - if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - if (message) { - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } + message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } - } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } - { -#ifdef USE_SFIO - /* SFIO can really mess with your errno */ - int e = errno; -#endif - PerlIO *serr = Perl_error_log; + else if (!message) + message = SvPVx_const(ERRSV, msglen); - PerlIO_write(serr, message, msglen); - (void)PerlIO_flush(serr); -#ifdef USE_SFIO - errno = e; -#endif - } + write_to_stderr(message, msglen); my_failure_exit(); } @@ -1222,18 +1355,21 @@ Perl_croak_nocontext(const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ /* +=head1 Warning and Dieing + =for apidoc croak This is the XSUB-writer's interface to Perl's C function. -Normally use this function the same way you use the C C -function. See C. +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(): +C<$@> and then pass C to croak(): errsv = get_sv("@", TRUE); sv_setsv(errsv, exception_object); - croak(Nullch); + croak(NULL); =cut */ @@ -1251,58 +1387,18 @@ Perl_croak(pTHX_ const char *pat, ...) void Perl_vwarn(pTHX_ const char* pat, va_list *args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; + dVAR; STRLEN msglen; - - msv = vmess(pat, args); - message = SvPV(msv, msglen); + SV * const msv = vmess(pat, args); + const I32 utf8 = SvUTF8(msv); + const char * const message = SvPV_const(msv, msglen); if (PL_warnhook) { - /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_WARNHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; + if (vdie_common(message, msglen, utf8, TRUE)) return; - } } - { - PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); -#ifdef LEAKTEST - DEBUG_L(*message == '!' - ? (xstat(message[1]=='!' - ? (message[2]=='!' ? 2 : 1) - : 0) - , 0) - : 0); -#endif - (void)PerlIO_flush(serr); - } + write_to_stderr(message, msglen); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1320,9 +1416,8 @@ Perl_warn_nocontext(const char *pat, ...) /* =for apidoc warn -This is the XSUB-writer's interface to Perl's C function. Use this -function the same way you use the C C function. See -C. +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 */ @@ -1340,7 +1435,7 @@ Perl_warn(pTHX_ const char *pat, ...) void Perl_warner_nocontext(U32 err, const char *pat, ...) { - dTHX; + dTHX; va_list args; va_start(args, pat); vwarner(err, pat, &args); @@ -1360,127 +1455,125 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; - STRLEN msglen; - - msv = vmess(pat, args); - message = SvPV(msv, msglen); - + dVAR; if (ckDEAD(err)) { -#ifdef USE_THREADS - DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); -#endif /* USE_THREADS */ - if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } - } - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - JMPENV_JUMP(3); - } - { - PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); - (void)PerlIO_flush(serr); + SV * const msv = vmess(pat, args); + STRLEN msglen; + const char * const message = SvPV_const(msv, msglen); + const I32 utf8 = SvUTF8(msv); + + if (PL_diehook) { + assert(message); + S_vdie_common(aTHX_ message, msglen, utf8, FALSE); } - my_failure_exit(); - + if (PL_in_eval) { + PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; + JMPENV_JUMP(3); + } + write_to_stderr(message, msglen); + my_failure_exit(); } else { - if (PL_warnhook) { - /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_WARNHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - return; - } - } - { - PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); -#ifdef LEAKTEST - DEBUG_L(*message == '!' - ? (xstat(message[1]=='!' - ? (message[2]=='!' ? 2 : 1) - : 0) - , 0) - : 0); -#endif - (void)PerlIO_flush(serr); - } + Perl_vwarn(aTHX_ pat, args); } } +/* implements the ckWARN? macros */ + +bool +Perl_ckwarn(pTHX_ U32 w) +{ + dVAR; + 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) +{ + dVAR; + 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' and EPOC's my_setenv() is in vms.c and epoc.c */ + /* VMS' my_setenv() is in vms.c */ #if !defined(WIN32) && !defined(NETWARE) void -Perl_my_setenv(pTHX_ char *nam, char *val) +Perl_my_setenv(pTHX_ const char *nam, const char *val) { + dVAR; +#ifdef USE_ITHREADS + /* only parent thread can modify process environment */ + if (PL_curinterp == aTHX) +#endif + { #ifndef PERL_USE_SAFE_PUTENV + if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ register I32 i=setenv_getix(nam); /* where does it go? */ + int nlen, vlen; if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; I32 max; char **tmpenv; - /*SUPPRESS 530*/ for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j= 0) { while (len--) @@ -1590,7 +1723,7 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len) void * Perl_my_memset(register char *loc, register I32 ch, register I32 len) { - char *retval = loc; + char * const retval = loc; while (len--) *loc++ = ch; @@ -1603,7 +1736,7 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len) char * Perl_my_bzero(register char *loc, register I32 len) { - char *retval = loc; + char * const retval = loc; while (len--) *loc++ = 0; @@ -1616,12 +1749,12 @@ Perl_my_bzero(register char *loc, register I32 len) I32 Perl_my_memcmp(const char *s1, const char *s2, register I32 len) { - register U8 *a = (U8 *)s1; - register U8 *b = (U8 *)s2; + register const U8 *a = (const U8 *)s1; + register const U8 *b = (const U8 *)s2; register I32 tmp; while (len--) { - if (tmp = *a++ - *b++) + if ((tmp = *a++ - *b++)) return tmp; } return 0; @@ -1742,7 +1875,45 @@ Perl_my_ntohl(pTHX_ long l) * -DWS */ -#define HTOV(name,type) \ +#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) \ { \ @@ -1751,14 +1922,14 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ + 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 VTOH(name,type) \ +#define BETOH(name,type) \ type \ name (register type n) \ { \ @@ -1767,32 +1938,186 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ + register I32 s = 8*(sizeof(u.c)-1); \ u.value = n; \ n = 0; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ - n += (u.c[i] & 0xFF) << s; \ + 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) -HTOV(htovs,short) +HTOLE(htovs,short) #endif #if defined(HAS_HTOVL) && !defined(htovl) -HTOV(htovl,long) +HTOLE(htovl,long) #endif #if defined(HAS_VTOHS) && !defined(vtohs) -VTOH(vtohs,short) +LETOH(vtohs,short) #endif #if defined(HAS_VTOHL) && !defined(vtohl) -VTOH(vtohl,long) +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) +{ + register char *s = (char *)ptr; + register char *e = s + (n-1); + register char tc; + + for (n /= 2; n > 0; s++, e--, n--) { + tc = *s; + *s = *e; + *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) + dVAR; int p[2]; register I32 This, that; register Pid_t pid; @@ -1808,18 +2133,19 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe(p) < 0) - return Nullfp; + return NULL; /* Try for another pipe pair for error return */ if (PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = vfork()) < 0) { + 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; + return NULL; } sleep(5); } @@ -1829,8 +2155,6 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #undef THAT #define THIS that #define THAT This - /* Close parent's end of _the_ pipe */ - PerlLIO_close(p[THAT]); /* Close parent's end of error status pipe (if any) */ if (did_pipes) { PerlLIO_close(pp[0]); @@ -1843,7 +2167,11 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) 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 @@ -1853,20 +2181,18 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) int fd; for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { - if (fd != pp[1]) + if (fd != pp[1]) PerlLIO_close(fd); } } #endif - do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); + do_aexec5(NULL, 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 vfork */ - /* Close child's end of pipe */ - PerlLIO_close(p[that]); + 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 */ @@ -1875,11 +2201,14 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) 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; - (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = pid; + 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) { @@ -1898,13 +2227,14 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) 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; + return NULL; } } if (did_pipes) @@ -1919,13 +2249,14 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* 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) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { + dVAR; int p[2]; register I32 This, that; register Pid_t pid; SV *sv; - I32 doexec = strNE(cmd,"-"); + const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); I32 did_pipes = 0; int pp[2]; @@ -1942,19 +2273,20 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe(p) < 0) - return Nullfp; + return NULL; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = (doexec?vfork():fork())) < 0) { + 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; + return NULL; } sleep(5); } @@ -1965,7 +2297,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THAT #define THIS that #define THAT This - PerlLIO_close(p[THAT]); if (did_pipes) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) @@ -1975,21 +2306,23 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) 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]); } + else + PerlLIO_close(p[THAT]); #ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) - int fd; - #ifndef NOFILE #define NOFILE 20 #endif { - int fd; + int fd; for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) if (fd != pp[1]) - PerlLIO_close(fd); + PerlLIO_close(fd); } #endif /* may or may not use the shell */ @@ -1997,17 +2330,23 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlProc__exit(1); } #endif /* defined OS2 */ - /*SUPPRESS 560*/ - if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) { + SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), PerlProc_getpid()); + SvREADONLY_on(GvSV(tmpgv)); + } +#ifdef THREADS_HAVE_PIDS + PL_ppid = (IV)getppid(); +#endif PL_forkprocess = 0; +#ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* we have no children */ - return Nullfp; +#endif + return NULL; #undef THIS #undef THAT } do_execfree(); /* free any memory malloced by child on vfork */ - PerlLIO_close(p[that]); if (did_pipes) PerlLIO_close(pp[1]); if (p[that] < p[This]) { @@ -2015,11 +2354,14 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } + else + PerlLIO_close(p[that]); + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; - (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = pid; + SvUPGRADE(sv,SVt_IV); + SvIV_set(sv, pid); PL_forkprocess = pid; if (did_pipes && pid > 0) { int errkid; @@ -2037,13 +2379,14 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) 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; + return NULL; } } if (did_pipes) @@ -2051,7 +2394,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return PerlIO_fdopen(p[This], mode); } #else -#if defined(atarist) || defined(DJGPP) +#if defined(atarist) || defined(EPOC) FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) @@ -2063,16 +2406,80 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) */ 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) +{ +#if defined(HAS_FORK) + 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 */ + pid = fork(); +#endif + 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; - struct stat tmpstatbuf; + Stat_t tmpstatbuf; PerlIO_printf(Perl_debug_log,"%s", s); for (fd = 0; fd < 32; fd++) { @@ -2080,6 +2487,7 @@ Perl_dump_fds(pTHX_ char *s) PerlIO_printf(Perl_debug_log," %d",fd); } PerlIO_printf(Perl_debug_log,"\n"); + return; } #endif /* DUMP_FDS */ @@ -2120,55 +2528,73 @@ dup2(int oldfd, int newfd) #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) { + dVAR; struct sigaction act, oact; - act.sa_handler = handler; - sigemptyset(&act.sa_mask); +#ifdef USE_ITHREADS + /* only "parent" interpreter can diddle signals */ + if (PL_curinterp != aTHX) + return (Sighandler_t) SIG_ERR; +#endif + + act.sa_handler = (void(*)(int))handler; + sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS) - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ -#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif -#ifdef SA_NOCLDWAIT - if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) +#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ + if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif if (sigaction(signo, &act, &oact) == -1) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } Sighandler_t Perl_rsignal_state(pTHX_ int signo) { struct sigaction oact; + PERL_UNUSED_CONTEXT; if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { + dVAR; struct sigaction act; - act.sa_handler = handler; +#ifdef USE_ITHREADS + /* only "parent" interpreter can diddle signals */ + if (PL_curinterp != aTHX) + return -1; +#endif + + act.sa_handler = (void(*)(int))handler; sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS) - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ -#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif -#ifdef SA_NOCLDWAIT - if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) +#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ + if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif return sigaction(signo, &act, save); @@ -2177,6 +2603,13 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { + dVAR; +#ifdef USE_ITHREADS + /* only "parent" interpreter can diddle signals */ + if (PL_curinterp != aTHX) + return -1; +#endif + return sigaction(signo, save, (struct sigaction *)NULL); } @@ -2185,42 +2618,63 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 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 (Sighandler_t) SIG_ERR; +#endif + return PerlProc_signal(signo, handler); } -static int sig_trapped; - -static -Signal_t +static Signal_t sig_trap(int signo) { - sig_trapped++; + dVAR; + PL_sig_trapped++; } Sighandler_t Perl_rsignal_state(pTHX_ int signo) { + dVAR; Sighandler_t oldsig; - sig_trapped = 0; +#if defined(USE_ITHREADS) && !defined(WIN32) + /* only "parent" interpreter can diddle signals */ + if (PL_curinterp != aTHX) + return (Sighandler_t) SIG_ERR; +#endif + + PL_sig_trapped = 0; oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); - if (sig_trapped) - PerlProc_kill(PerlProc_getpid(), signo); + 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; + return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; } int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { - return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; +#if defined(USE_ITHREADS) && !defined(WIN32) + /* only "parent" interpreter can diddle signals */ + if (PL_curinterp != aTHX) + return -1; +#endif + return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; } #endif /* !HAS_SIGACTION */ @@ -2231,6 +2685,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { + dVAR; Sigsave_t hstat, istat, qstat; int status; SV **svp; @@ -2238,9 +2693,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid2; bool close_failed; int saved_errno = 0; -#ifdef VMS - int saved_vaxc_errno; -#endif #ifdef WIN32 int saved_win32_errno; #endif @@ -2258,9 +2710,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #endif if ((close_failed = (PerlIO_close(ptr) == EOF))) { saved_errno = errno; -#ifdef VMS - saved_vaxc_errno = vaxc$errno; -#endif #ifdef WIN32 saved_win32_errno = GetLastError(); #endif @@ -2269,9 +2718,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif #ifndef PERL_MICRO - rsignal_save(SIGHUP, SIG_IGN, &hstat); - rsignal_save(SIGINT, SIG_IGN, &istat); - rsignal_save(SIGQUIT, SIG_IGN, &qstat); + rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat); + rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat); + rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat); #endif do { pid2 = wait4pid(pid, &status, 0); @@ -2282,7 +2731,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) rsignal_restore(SIGQUIT, &qstat); #endif if (close_failed) { - SETERRNO(saved_errno, saved_vaxc_errno); + SETERRNO(saved_errno, 0); return -1; } return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); @@ -2293,36 +2742,46 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { + dVAR; + I32 result = 0; if (!pid) return -1; -#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) +#ifdef PERL_USES_PL_PIDSTATUS { - SV *sv; - SV** svp; - char spid[TYPE_CHARS(int)]; - - if (pid > 0) { - 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; + if (pid > 0) { + /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the + pid, rather than a string form. */ + SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); + if (svp && *svp != &PL_sv_undef) { + *statusp = SvIVX(*svp); + (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), + G_DISCARD); + return pid; + } } - } - else { - HE *entry; - - hv_iterinit(PL_pidstatus); - if ((entry = hv_iternext(PL_pidstatus))) { - pid = atoi(hv_iterkey(entry,(I32*)statusp)); - sv = hv_iterval(PL_pidstatus,entry); - *statusp = SvIVX(sv); - sprintf(spid, "%"IVdf, (IV)pid); - (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 * const sv = hv_iterval(PL_pidstatus,entry); + I32 len; + const char * const spid = hv_iterkey(entry,&len); + + assert (len == sizeof(Pid_t)); + memcpy((char *)&pid, spid, len); + *statusp = SvIVX(sv); + /* The hash iterator is currently on this entry, so simply + calling hv_delete would trigger the lazy delete, which on + aggregate does more work, beacuse next call to hv_iterinit() + would spot the flag, and have to call the delete routine, + while in the meantime any new entries can't re-use that + memory. */ + hv_iterinit(PL_pidstatus); + (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); + return pid; + } } - } } #endif #ifdef HAS_WAITPID @@ -2330,15 +2789,18 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if (!HAS_WAITPID_RUNTIME) goto hard_way; # endif - return PerlProc_waitpid(pid,statusp,flags); + result = PerlProc_waitpid(pid,statusp,flags); + goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) - return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + result = wait4((pid==-1)?0:pid,statusp,flags,NULL); + goto finish; #endif -#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) +#ifdef PERL_USES_PL_PIDSTATUS +#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) hard_way: +#endif { - I32 result; if (flags) Perl_croak(aTHX_ "Can't do waitpid with flags"); else { @@ -2347,27 +2809,32 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if (result < 0) *statusp = -1; } - return result; } #endif +#if defined(HAS_WAITPID) || defined(HAS_WAIT4) + finish: +#endif + if (result < 0 && errno == EINTR) { + PERL_ASYNC_CHECK(); + } + return result; } #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ +#ifdef PERL_USES_PL_PIDSTATUS void -/*SUPPRESS 590*/ Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; - char spid[TYPE_CHARS(int)]; - sprintf(spid, "%"IVdf, (IV)pid); - sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); - (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = status; + sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); + SvUPGRADE(sv,SVt_IV); + SvIV_set(sv, status); return; } +#endif -#if defined(atarist) || defined(OS2) || defined(DJGPP) +#if defined(atarist) || defined(OS2) || defined(EPOC) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -2379,11 +2846,22 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #endif { /* Needs work for PerlIO ! */ - FILE *f = PerlIO_findFILE(ptr); - I32 result = pclose(f); + FILE * const f = PerlIO_findFILE(ptr); + const 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 * const f = PerlIO_findFILE(ptr); + I32 result = djgpp_pclose(f); result = (result << 8) & 0xff00; -#endif PerlIO_releaseFILE(ptr,f); return result; } @@ -2393,7 +2871,8 @@ void Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) { register I32 todo; - register const char *frombase = from; + register const char * const frombase = from; + PERL_UNUSED_CONTEXT; if (len == 1) { register const char c = *from; @@ -2411,13 +2890,13 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi #ifndef HAS_RENAME I32 -Perl_same_dirent(pTHX_ char *a, char *b) +Perl_same_dirent(pTHX_ const char *a, const char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); - struct stat tmpstatbuf1; - struct stat tmpstatbuf2; - SV *tmpsv = sv_newmortal(); + Stat_t tmpstatbuf1; + Stat_t tmpstatbuf2; + SV * const tmpsv = sv_newmortal(); if (fa) fa++; @@ -2430,16 +2909,16 @@ Perl_same_dirent(pTHX_ char *a, char *b) if (strNE(a,b)) return FALSE; if (fa == a) - sv_setpv(tmpsv, "."); + sv_setpvn(tmpsv, ".", 1); else sv_setpvn(tmpsv, a, fa - a); - if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) + if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - sv_setpv(tmpsv, "."); + sv_setpvn(tmpsv, ".", 1); else sv_setpvn(tmpsv, b, fb - b); - if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) + if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; @@ -2447,13 +2926,15 @@ Perl_same_dirent(pTHX_ char *a, char *b) #endif /* !HAS_RENAME */ char* -Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) +Perl_find_script(pTHX_ const char *scriptname, bool dosearch, + const char *const *const search_ext, I32 flags) { - char *xfound = Nullch; - char *xfailed = Nullch; + dVAR; + const char *xfound = NULL; + char *xfailed = NULL; char tmpbuf[MAXPATHLEN]; register char *s; - I32 len; + I32 len = 0; int retval; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL @@ -2469,11 +2950,12 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS - char *exts[] = { SEARCH_EXTS }; - char **ext = search_ext ? search_ext : exts; + static const char *const exts[] = { SEARCH_EXTS }; + const char *const *const ext = search_ext ? search_ext : exts; int extidx = 0, i = 0; - char *curext = Nullch; + const char *curext = NULL; #else + PERL_UNUSED_ARG(search_ext); # define MAX_EXT_LEN 0 #endif @@ -2501,16 +2983,16 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f # ifdef ALWAYS_DEFTYPES len = strlen(scriptname); if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { - int hasdir, idx = 0, deftypes = 1; + int idx = 0, deftypes = 1; bool seen_dot = 1; - hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof(tmpbuf)) break; + /* FIXME? Convert to memcpy */ cur = strcpy(tmpbuf, scriptname); } } while (extidx >= 0 && ext[extidx] /* try an extension? */ @@ -2576,7 +3059,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f #endif { bool seen_dot = 0; - + PL_bufend = s + strlen(s); while (s < PL_bufend) { #ifdef MACOS_TRADITIONAL @@ -2610,15 +3093,17 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f tmpbuf[len++] = ':'; #else if (len -#if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' -#endif +# 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 */ @@ -2648,7 +3133,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f #endif ) { - xfound = tmpbuf; /* bingo! */ + xfound = tmpbuf; /* bingo! */ break; } if (!xfailed) @@ -2662,19 +3147,18 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ - Perl_croak(aTHX_ "Can't %s %s%s%s", + 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; + scriptname = NULL; } - if (xfailed) - Safefree(xfailed); + Safefree(xfailed); scriptname = xfound; } - return (scriptname ? savepv(scriptname) : Nullch); + return (scriptname ? savepv(scriptname) : NULL); } #ifndef PERL_GET_CONTEXT_DEFINED @@ -2682,7 +3166,8 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) + dVAR; +#if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) @@ -2703,292 +3188,22 @@ Perl_get_context(void) void Perl_set_context(void *t) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) + 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 */ -#ifdef USE_THREADS - -#ifdef FAKE_THREADS -/* Very simplistic scheduler for now */ -void -schedule(void) -{ - thr = thr->i.next_run; -} - -void -Perl_cond_init(pTHX_ perl_cond *cp) -{ - *cp = 0; -} - -void -Perl_cond_signal(pTHX_ perl_cond *cp) -{ - perl_os_thread t; - perl_cond cond = *cp; - - if (!cond) - return; - t = cond->thread; - /* Insert t in the runnable queue just ahead of us */ - t->i.next_run = thr->i.next_run; - thr->i.next_run->i.prev_run = t; - t->i.prev_run = thr; - thr->i.next_run = t; - thr->i.wait_queue = 0; - /* Remove from the wait queue */ - *cp = cond->next; - Safefree(cond); -} - -void -Perl_cond_broadcast(pTHX_ perl_cond *cp) -{ - perl_os_thread t; - perl_cond cond, cond_next; - - for (cond = *cp; cond; cond = cond_next) { - t = cond->thread; - /* Insert t in the runnable queue just ahead of us */ - t->i.next_run = thr->i.next_run; - thr->i.next_run->i.prev_run = t; - t->i.prev_run = thr; - thr->i.next_run = t; - thr->i.wait_queue = 0; - /* Remove from the wait queue */ - cond_next = cond->next; - Safefree(cond); - } - *cp = 0; -} - -void -Perl_cond_wait(pTHX_ perl_cond *cp) -{ - perl_cond cond; - - if (thr->i.next_run == thr) - Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); - - New(666, cond, 1, struct perl_wait_queue); - cond->thread = thr; - cond->next = *cp; - *cp = cond; - thr->i.wait_queue = cond; - /* Remove ourselves from runnable queue */ - thr->i.next_run->i.prev_run = thr->i.prev_run; - thr->i.prev_run->i.next_run = thr->i.next_run; -} -#endif /* FAKE_THREADS */ - -MAGIC * -Perl_condpair_magic(pTHX_ SV *sv) -{ - MAGIC *mg; - - (void)SvUPGRADE(sv, SVt_PVMG); - mg = mg_find(sv, PERL_MAGIC_mutex); - if (!mg) { - condpair_t *cp; - - New(53, cp, 1, condpair_t); - MUTEX_INIT(&cp->mutex); - COND_INIT(&cp->owner_cond); - COND_INIT(&cp->cond); - cp->owner = 0; - LOCK_CRED_MUTEX; /* XXX need separate mutex? */ - mg = mg_find(sv, PERL_MAGIC_mutex); - if (mg) { - /* someone else beat us to initialising it */ - UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ - MUTEX_DESTROY(&cp->mutex); - COND_DESTROY(&cp->owner_cond); - COND_DESTROY(&cp->cond); - Safefree(cp); - } - else { - sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0); - mg = SvMAGIC(sv); - mg->mg_ptr = (char *)cp; - mg->mg_len = sizeof(cp); - UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ - DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, - "%p: condpair_magic %p\n", thr, sv));) - } - } - return mg; -} - -SV * -Perl_sv_lock(pTHX_ SV *osv) -{ - MAGIC *mg; - SV *sv = osv; - - LOCK_SV_LOCK_MUTEX; - if (SvROK(sv)) { - sv = SvRV(sv); - } - - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } - UNLOCK_SV_LOCK_MUTEX; - return sv; -} - -/* - * Make a new perl thread structure using t as a prototype. Some of the - * fields for the new thread are copied from the prototype thread, t, - * so t should not be running in perl at the time this function is - * called. The use by ext/Thread/Thread.xs in core perl (where t is the - * thread calling new_struct_thread) clearly satisfies this constraint. - */ -struct perl_thread * -Perl_new_struct_thread(pTHX_ struct perl_thread *t) -{ -#if !defined(PERL_IMPLICIT_CONTEXT) - struct perl_thread *thr; -#endif - SV *sv; - SV **svp; - I32 i; - - sv = newSVpvn("", 0); - SvGROW(sv, sizeof(struct perl_thread) + 1); - SvCUR_set(sv, sizeof(struct perl_thread)); - thr = (Thread) SvPVX(sv); -#ifdef DEBUGGING - memset(thr, 0xab, sizeof(struct perl_thread)); - PL_markstack = 0; - PL_scopestack = 0; - PL_savestack = 0; - PL_retstack = 0; - PL_dirty = 0; - PL_localizing = 0; - Zero(&PL_hv_fetch_ent_mh, 1, HE); - PL_efloatbuf = (char*)NULL; - PL_efloatsize = 0; -#else - Zero(thr, 1, struct perl_thread); -#endif - - thr->oursv = sv; - init_stacks(); - - PL_curcop = &PL_compiling; - thr->interp = t->interp; - thr->cvcache = newHV(); - thr->threadsv = newAV(); - thr->specific = newAV(); - thr->errsv = newSVpvn("", 0); - thr->flags = THRf_R_JOINABLE; - thr->thr_done = 0; - MUTEX_INIT(&thr->mutex); - - JMPENV_BOOTSTRAP; - - PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */ - PL_restartop = 0; - - PL_statname = NEWSV(66,0); - PL_errors = newSVpvn("", 0); - PL_maxscream = -1; - PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); - PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); - PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); - PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); - PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); - PL_regindent = 0; - PL_reginterp_cnt = 0; - PL_lastscream = Nullsv; - PL_screamfirst = 0; - PL_screamnext = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - PL_reg_poscache = Nullch; - - /* parent thread's data needs to be locked while we make copy */ - MUTEX_LOCK(&t->mutex); - -#ifdef PERL_FLEXIBLE_EXCEPTIONS - PL_protect = t->Tprotect; -#endif - - PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ - PL_defstash = t->Tdefstash; /* XXX maybe these should */ - PL_curstash = t->Tcurstash; /* always be set to main? */ - - PL_tainted = t->Ttainted; - PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ - PL_nrs = newSVsv(t->Tnrs); - PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; - PL_last_in_gv = Nullgv; - PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; - PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); - PL_chopset = t->Tchopset; - PL_bodytarget = newSVsv(t->Tbodytarget); - PL_toptarget = newSVsv(t->Ttoptarget); - if (t->Tformtarget == t->Ttoptarget) - PL_formtarget = PL_toptarget; - else - PL_formtarget = PL_bodytarget; - - /* Initialise all per-thread SVs that the template thread used */ - svp = AvARRAY(t->threadsv); - for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { - if (*svp && *svp != &PL_sv_undef) { - SV *sv = newSVsv(*svp); - av_store(thr->threadsv, i, sv); - sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", - (IV)i, t, thr)); - } - } - thr->threadsvp = AvARRAY(thr->threadsv); - - MUTEX_LOCK(&PL_threads_mutex); - PL_nthreads++; - thr->tid = ++PL_threadnum; - thr->next = t->next; - thr->prev = t; - t->next = thr; - thr->next->prev = thr; - MUTEX_UNLOCK(&PL_threads_mutex); - - /* done copying parent's state */ - MUTEX_UNLOCK(&t->mutex); - -#ifdef HAVE_THREAD_INTERN - Perl_init_thread_intern(thr); -#endif /* HAVE_THREAD_INTERN */ - return thr; -} -#endif /* USE_THREADS */ - -#ifdef PERL_GLOBAL_STRUCT +#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) struct perl_vars * Perl_GetVars(pTHX) { @@ -2999,38 +3214,45 @@ Perl_GetVars(pTHX) char ** Perl_get_op_names(pTHX) { - return PL_op_name; + PERL_UNUSED_CONTEXT; + return (char **)PL_op_name; } char ** Perl_get_op_descs(pTHX) { - return PL_op_desc; + PERL_UNUSED_CONTEXT; + return (char **)PL_op_desc; } -char * +const char * Perl_get_no_modify(pTHX) { - return (char*)PL_no_modify; + PERL_UNUSED_CONTEXT; + return PL_no_modify; } U32 * Perl_get_opargs(pTHX) { - return PL_opargs; + PERL_UNUSED_CONTEXT; + return (U32 *)PL_opargs; } PPADDR_t* Perl_get_ppaddr(pTHX) { - return (PPADDR_t*)PL_ppaddr; + dVAR; + PERL_UNUSED_CONTEXT; + return (PPADDR_t*)PL_ppaddr; } #ifndef HAS_GETENV_LEN char * Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { - char *env_trans = PerlEnv_getenv(env_elem); + char * const env_trans = PerlEnv_getenv(env_elem); + PERL_UNUSED_CONTEXT; if (env_trans) *len = strlen(env_trans); return env_trans; @@ -3041,7 +3263,8 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - MGVTBL* result = Null(MGVTBL*); + const MGVTBL* result; + PERL_UNUSED_CONTEXT; switch(vtbl_id) { case want_vtbl_sv: @@ -3077,9 +3300,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id) 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; @@ -3107,11 +3327,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_uvar: result = &PL_vtbl_uvar; break; -#ifdef USE_THREADS - case want_vtbl_mutex: - result = &PL_vtbl_mutex; - break; -#endif case want_vtbl_defelem: result = &PL_vtbl_defelem; break; @@ -3138,17 +3353,24 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_backref: result = &PL_vtbl_backref; break; + case want_vtbl_utf8: + result = &PL_vtbl_utf8; + break; + default: + result = NULL; + break; } - return result; + return (MGVTBL*)result; } I32 Perl_my_fflush_all(pTHX) { -#if defined(FFLUSH_NULL) +#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) 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); @@ -3185,65 +3407,72 @@ Perl_my_fflush_all(pTHX) return 0; } # endif - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); return EOF; # endif #endif } void -Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) +Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - char *vile; - I32 warn_type; - char *func = + const char * const func = op == OP_READLINE ? "readline" : /* "" not nice */ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]; - char *pars = OP_IS_FILETEST(op) ? "" : "()"; - char *type = OP_IS_SOCKET(op) || - (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? - "socket" : "filehandle"; - char *name = NULL; + const char * const pars = OP_IS_FILETEST(op) ? "" : "()"; + const char * const type = OP_IS_SOCKET(op) + || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) + ? "socket" : "filehandle"; + const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL; - if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { - vile = "closed"; - warn_type = WARN_CLOSED; + if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { + if (ckWARN(WARN_IO)) { + const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; + if (name && *name) + 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 { - vile = "unopened"; - warn_type = WARN_UNOPENED; - } + const char *vile; + I32 warn_type; - if (gv && isGV(gv)) { - SV *sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPVX(sv); - } + if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { + vile = "closed"; + warn_type = WARN_CLOSED; + } + else { + vile = "unopened"; + warn_type = WARN_UNOPENED; + } - if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { - if (name && *name) - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput", - name, - (op == OP_phoney_INPUT_ONLY ? "in" : "out")); - else - Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput", - (op == OP_phoney_INPUT_ONLY ? "in" : "out")); - } else if (name && *name) { - Perl_warner(aTHX_ warn_type, - "%s%s on %s %s %s", func, pars, vile, type, name); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - Perl_warner(aTHX_ warn_type, + if (ckWARN(warn_type)) { + if (name && *name) { + Perl_warner(aTHX_ packWARN(warn_type), + "%s%s on %s %s %s", func, pars, vile, type, name); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner( + aTHX_ packWARN(warn_type), "\t(Are you trying to call %s%s on dirhandle %s?)\n", - func, pars, name); - } - else { - Perl_warner(aTHX_ warn_type, - "%s%s on %s %s", func, pars, vile, type); - if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - Perl_warner(aTHX_ warn_type, + func, pars, name + ); + } + else { + Perl_warner(aTHX_ packWARN(warn_type), + "%s%s on %s %s", func, pars, vile, type); + 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); + func, pars + ); + } + } } } @@ -3254,66 +3483,73 @@ static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; int Perl_ebcdic_control(pTHX_ int ch) { - if (ch > 'a') { - 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 - -/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) - * fields for which we don't have Configure support yet: - * char *tm_zone; -- abbreviation of timezone name - * long tm_gmtoff; -- offset from GMT in seconds - * To workaround core dumps from the uninitialised tm_zone we get the + 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 is a temporary workaround to be removed once Configure - * support is added and NETaa14816 is considered in full. - * It does not address tzname aspects of NETaa14816. + * 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 STRUCT_TM_HASZONE +#ifdef HAS_TM_TM_ZONE Time_t now; + const struct tm* my_tm; (void)time(&now); - Copy(localtime(&now), ptm, 1, struct tm); + my_tm = localtime(&now); + if (my_tm) + Copy(my_tm, ptm, 1, struct tm); +#else + PERL_UNUSED_ARG(ptm); #endif } @@ -3328,6 +3564,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) int secs; int month, mday, year, jday; int odd_cent, odd_year; + PERL_UNUSED_CONTEXT; #define DAYS_PER_YEAR 365 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) @@ -3515,7 +3752,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) } char * -Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) +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; @@ -3534,8 +3771,22 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, 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); + Newx(buf, buflen, char); len = strftime(buf, buflen, fmt, &mytm); /* ** The following is needed to handle to the situation where @@ -3555,10 +3806,10 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, return buf; else { /* Possibly buf overflowed - try again with a bigger buf */ - int fmtlen = strlen(fmt); - int bufsize = fmtlen + buflen; + const int fmtlen = strlen(fmt); + const int bufsize = fmtlen + buflen; - New(0, buf, bufsize, char); + Newx(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -3569,13 +3820,13 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, buf = NULL; break; } - bufsize *= 2; - Renew(buf, bufsize, char); + Renew(buf, bufsize*2, char); } return buf; } #else Perl_croak(aTHX_ "panic: no strftime"); + return NULL; #endif } @@ -3586,10 +3837,12 @@ 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'))) + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* -=for apidoc sv_getcwd +=head1 Miscellaneous Functions + +=for apidoc getcwd_sv Fill the sv with current working directory @@ -3605,40 +3858,42 @@ Fill the sv with current working directory * back into. */ int -Perl_sv_getcwd(pTHX_ register SV *sv) +Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO + dVAR; +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif #ifdef HAS_GETCWD { char buf[MAXPATHLEN]; - /* Some getcwd()s automatically allocate a buffer of the given + /* 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. */ - if (getcwd(buf, sizeof(buf) - 1)) { - STRLEN len = strlen(buf); - sv_setpvn(sv, buf, len); - return TRUE; - } - else { - sv_setsv(sv, &PL_sv_undef); - return FALSE; - } + if (getcwd(buf, sizeof(buf) - 1)) { + sv_setpv(sv, buf); + return TRUE; + } + else { + sv_setsv(sv, &PL_sv_undef); + return FALSE; + } } #else - struct stat statbuf; + Stat_t statbuf; int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; - int namelen, pathlen=0; - DIR *dir; + int pathlen=0; Direntry_t *dp; - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); if (PerlLIO_lstat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; + SV_CWD_RETURN_UNDEF; } orig_cdev = statbuf.st_dev; @@ -3647,102 +3902,1422 @@ Perl_sv_getcwd(pTHX_ register SV *sv) cino = orig_cino; for (;;) { - odev = cdev; - oino = cino; + DIR *dir; + odev = cdev; + oino = cino; - if (PerlDir_chdir("..") < 0) { - SV_CWD_RETURN_UNDEF; - } - if (PerlLIO_stat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; - } + 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; + cdev = statbuf.st_dev; + cino = statbuf.st_ino; - if (odev == cdev && oino == cino) { - break; - } - if (!(dir = PerlDir_open("."))) { - SV_CWD_RETURN_UNDEF; - } + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } - while ((dp = PerlDir_read(dir)) != NULL) { + while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN - namelen = dp->d_namlen; + const int namelen = dp->d_namlen; #else - namelen = strlen(dp->d_name); + const int namelen = strlen(dp->d_name); #endif - /* skip . and .. */ - if (SV_CWD_ISDOT(dp)) { - continue; - } + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } - if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; - } + 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; - } - } + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } - if (!dp) { - SV_CWD_RETURN_UNDEF; - } + if (!dp) { + SV_CWD_RETURN_UNDEF; + } - if (pathlen + namelen + 1 >= MAXPATHLEN) { - SV_CWD_RETURN_UNDEF; + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; } - SvGROW(sv, pathlen + namelen + 1); + SvGROW(sv, pathlen + namelen + 1); - if (pathlen) { - /* shift down */ - Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); - } + 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); + /* 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); + PerlDir_close(dir); #else - if (PerlDir_close(dir) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } #endif } if (pathlen) { - SvCUR_set(sv, pathlen); - *SvEND(sv) = '\0'; - SvPOK_only(sv); + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); - if (PerlDir_chdir(SvPVX(sv)) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlDir_chdir(SvPVX_const(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } } if (PerlLIO_stat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; + 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"); + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); } -#endif 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) +{ + const char *start; + const char *pos; + const char *last; + int saw_period = 0; + int alpha = 0; + int width = 3; + AV * const av = newAV(); + SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ + +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + + while (isSPACE(*s)) /* leading whitespace is OK */ + s++; + + if (*s == 'v') { + s++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } + + start = last = pos = s; + + /* pre-scan the input string to check for decimals/underbars */ + while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) + { + if ( *pos == '.' ) + { + if ( alpha ) + Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); + saw_period++ ; + last = pos; + } + else if ( *pos == '_' ) + { + if ( alpha ) + Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); + alpha = 1; + width = pos - last - 1; /* natural width of sub-version */ + } + pos++; + } + + if ( alpha && !saw_period ) + Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); + + if ( saw_period > 1 ) + qv = 1; /* force quoted version processing */ + + pos = s; + + if ( qv ) + hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + if ( alpha ) + hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); + if ( !qv && width < 3 ) + hv_store((HV *)hv, "width", 5, newSViv(width), 0); + + while (isDIGIT(*pos)) + pos++; + if (!isALPHA(*pos)) { + I32 rev; + + for (;;) { + rev = 0; + { + /* this is atoi() that delimits on underscores */ + const char *end = pos; + I32 mult = 1; + 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 + */ + if ( !qv && s > start && saw_period == 1 ) { + mult *= 100; + while ( s < end ) { + orev = rev; + rev += (*s - '0') * mult; + mult /= 10; + if ( PERL_ABS(orev) > PERL_ABS(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + s++; + if ( *s == '_' ) + s++; + } + } + else { + while (--end >= s) { + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if ( PERL_ABS(orev) > PERL_ABS(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + } + } + } + + /* Append revision */ + av_push(av, newSViv(rev)); + if ( *pos == '.' && isDIGIT(pos[1]) ) + s = ++pos; + else if ( *pos == '_' && isDIGIT(pos[1]) ) + s = ++pos; + else if ( isDIGIT(*pos) ) + s = pos; + else { + s = pos; + break; + } + if ( qv ) { + while ( isDIGIT(*pos) ) + pos++; + } + else { + int digits = 0; + while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { + if ( *pos != '_' ) + digits++; + pos++; + } + } + } + } + if ( qv ) { /* quoted versions always get at least three terms*/ + 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)); + */ + len = 2 - len; + while (len-- > 0) + av_push(av, newSViv(0)); + } + + if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + av_push(av, newSViv(0)); + + /* And finally, store the AV in the hash */ + hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + 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) +{ + dVAR; + SV * const rv = newSV(0); + if ( sv_derived_from(ver,"version") ) /* can just copy directly */ + { + I32 key; + AV * const av = newAV(); + AV *sav; + /* This will get reblessed later if a derived class*/ + SV * const hv = newSVrv(rv, "version"); + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + + if ( SvROK(ver) ) + ver = SvRV(ver); + + /* Begin copying all of the elements */ + if ( hv_exists((HV *)ver, "qv", 2) ) + hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + + if ( hv_exists((HV *)ver, "alpha", 5) ) + hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + + if ( hv_exists((HV*)ver, "width", 5 ) ) + { + const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); + hv_store((HV *)hv, "width", 5, newSViv(width), 0); + } + + sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); + /* This will get reblessed later if a derived class*/ + for ( key = 0; key <= av_len(sav); key++ ) + { + const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); + av_push(av, newSViv(rev)); + } + + hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + return rv; + } +#ifdef SvVOK + { + const MAGIC* const mg = SvVOK(ver); + if ( mg ) { /* already a v-string */ + const STRLEN len = mg->mg_len; + char * const version = savepvn( (const char*)mg->mg_ptr, len); + sv_setpvn(rv,version,len); + Safefree(version); + } + else { +#endif + sv_setsv(rv,ver); /* make a duplicate */ +#ifdef SvVOK + } + } +#endif + return upg_version(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) +{ + const char *version, *s; + bool qv = 0; +#ifdef SvVOK + const MAGIC *mg; +#endif + + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepvn(tbuf, len); + } +#ifdef SvVOK + else if ( (mg = SvVOK(ver)) ) { /* already a v-string */ + version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); + qv = 1; + } +#endif + else /* must be a string or something like a string */ + { + version = savepv(SvPV_nolen(ver)); + } + s = scan_version(version, ver, qv); + if ( *s != '\0' ) + if(ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); + Safefree(version); + return ver; +} + +/* +=for apidoc vverify + +Validates that the SV contains a valid version object. + + bool vverify(SV *vobj); + +Note that it only confirms the bare minimum structure (so as not to get +confused by derived classes which may contain additional hash entries): + +=over 4 + +=item * The SV contains a [reference to a] hash + +=item * The hash contains a "version" key + +=item * The "version" key has [a reference to] an AV as its value + +=back + +=cut +*/ + +bool +Perl_vverify(pTHX_ SV *vs) +{ + SV *sv; + if ( SvROK(vs) ) + vs = SvRV(vs); + + /* see if the appropriate elements exist */ + if ( SvTYPE(vs) == SVt_PVHV + && hv_exists((HV*)vs, "version", 7) + && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) + && SvTYPE(sv) == SVt_PVAV ) + return TRUE; + else + return FALSE; +} + +/* +=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) +{ + I32 i, len, digit; + int width; + bool alpha = FALSE; + SV * const sv = newSV(0); + AV *av; + if ( SvROK(vs) ) + vs = SvRV(vs); + + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + + /* see if various flags exist */ + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + if ( hv_exists((HV*)vs, "width", 5 ) ) + width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); + else + width = 3; + + + /* attempt to retrieve the version array */ + if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { + sv_catpvs(sv,"0"); + return sv; + } + + len = av_len(av); + if ( len == -1 ) + { + sv_catpvs(sv,"0"); + return sv; + } + + digit = SvIV(*av_fetch(av, 0, 0)); + Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); + for ( i = 1 ; i < len ; i++ ) + { + digit = SvIV(*av_fetch(av, i, 0)); + if ( width < 3 ) { + const int denom = (width == 2 ? 10 : 100); + const div_t term = div((int)PERL_ABS(digit),denom); + Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); + } + else { + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); + } + } + + if ( len > 0 ) + { + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha && width == 3 ) /* alpha version */ + sv_catpvs(sv,"_"); + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); + } + else /* len == 0 */ + { + sv_catpvs(sv, "000"); + } + 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) +{ + I32 i, len, digit; + bool alpha = FALSE; + SV * const sv = newSV(0); + AV *av; + if ( SvROK(vs) ) + vs = SvRV(vs); + + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); + + len = av_len(av); + if ( len == -1 ) + { + sv_catpvs(sv,""); + return sv; + } + digit = SvIV(*av_fetch(av, 0, 0)); + Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + for ( i = 1 ; i < len ; i++ ) { + digit = SvIV(*av_fetch(av, i, 0)); + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); + } + + if ( len > 0 ) + { + /* handle last digit specially */ + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha ) + Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); + else + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); + } + + if ( len <= 2 ) { /* short version, must be at least three */ + for ( len = 2 - len; len != 0; len-- ) + sv_catpvs(sv,".0"); + } + 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) +{ + if ( SvROK(vs) ) + vs = SvRV(vs); + + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( hv_exists((HV *)vs, "qv", 2) ) + return vnormal(vs); + else + 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) +{ + I32 i,l,m,r,retval; + bool lalpha = FALSE; + bool ralpha = FALSE; + I32 left = 0; + I32 right = 0; + AV *lav, *rav; + if ( SvROK(lhv) ) + lhv = SvRV(lhv); + if ( SvROK(rhv) ) + rhv = SvRV(rhv); + + if ( !vverify(lhv) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( !vverify(rhv) ) + Perl_croak(aTHX_ "Invalid version object"); + + /* get the left hand term */ + lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); + if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lalpha = TRUE; + + /* and the right hand term */ + rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); + if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + ralpha = TRUE; + + l = av_len(lav); + r = av_len(rav); + m = l < r ? l : r; + retval = 0; + i = 0; + while ( i <= m && retval == 0 ) + { + left = SvIV(*av_fetch(lav,i,0)); + right = SvIV(*av_fetch(rav,i,0)); + if ( left < right ) + retval = -1; + if ( left > right ) + retval = +1; + i++; + } + + /* tiebreaker for alpha with identical terms */ + if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) ) + { + if ( lalpha && !ralpha ) + { + retval = -1; + } + else if ( ralpha && !lalpha) + { + retval = +1; + } + } + + if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ + { + if ( l < r ) + { + while ( i <= r && retval == 0 ) + { + if ( SvIV(*av_fetch(rav,i,0)) != 0 ) + retval = -1; /* not a match after all */ + i++; + } + } + else + { + while ( i <= l && retval == 0 ) + { + if ( SvIV(*av_fetch(lav,i,0)) != 0 ) + retval = +1; /* not a match after all */ + i++; + } + } + } + return retval; +} + +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) +# define EMULATE_SOCKETPAIR_UDP +#endif + +#ifdef EMULATE_SOCKETPAIR_UDP +static int +S_socketpair_udp (int fd[2]) { + dTHX; + /* Fake a datagram socketpair using UDP to localhost. */ + int sockets[2] = {-1, -1}; + struct sockaddr_in addresses[2]; + int i; + Sock_size_t size = sizeof(struct sockaddr_in); + unsigned short port; + int got; + + memset(&addresses, 0, sizeof(addresses)); + i = 1; + do { + sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); + if (sockets[i] == -1) + goto tidy_up_and_fail; + + addresses[i].sin_family = AF_INET; + addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); + addresses[i].sin_port = 0; /* kernel choses port. */ + if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], + sizeof(struct sockaddr_in)) == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now have 2 UDP sockets. Find out which port each is connected to, and + for each connect the other socket to it. */ + i = 1; + do { + if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(struct sockaddr_in)) + goto abort_tidy_up_and_fail; + /* !1 is 0, !0 is 1 */ + if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], + sizeof(struct sockaddr_in)) == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now we have 2 sockets connected to each other. I don't trust some other + process not to have already sent a packet to us (by random) so send + a packet from each to the other. */ + i = 1; + do { + /* I'm going to send my own port number. As a short. + (Who knows if someone somewhere has sin_port as a bitfield and needs + this routine. (I'm assuming crays have socketpair)) */ + port = addresses[i].sin_port; + got = PerlLIO_write(sockets[i], &port, sizeof(port)); + if (got != sizeof(port)) { + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } while (i--); + + /* Packets sent. I don't trust them to have arrived though. + (As I understand it Solaris TCP stack is multithreaded. Non-blocking + connect to localhost will use a second kernel thread. In 2.6 the + first thread running the connect() returns before the second completes, + so EINPROGRESS> In 2.7 the improved stack is faster and connect() + returns 0. Poor programs have tripped up. One poor program's authors' + had a 50-1 reverse stock split. Not sure how connected these were.) + So I don't trust someone not to have an unpredictable UDP stack. + */ + + { + struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ + int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; + fd_set rset; + + FD_ZERO(&rset); + FD_SET((unsigned int)sockets[0], &rset); + FD_SET((unsigned int)sockets[1], &rset); + + got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); + if (got != 2 || !FD_ISSET(sockets[0], &rset) + || !FD_ISSET(sockets[1], &rset)) { + /* I hope this is portable and appropriate. */ + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } + + /* And the paranoia department even now doesn't trust it to have arrive + (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ + { + struct sockaddr_in readfrom; + unsigned short buffer[2]; + + i = 1; + do { +#ifdef MSG_DONTWAIT + got = PerlSock_recvfrom(sockets[i], (char *) &buffer, + sizeof(buffer), MSG_DONTWAIT, + (struct sockaddr *) &readfrom, &size); +#else + got = PerlSock_recvfrom(sockets[i], (char *) &buffer, + sizeof(buffer), 0, + (struct sockaddr *) &readfrom, &size); +#endif + + if (got == -1) + goto tidy_up_and_fail; + if (got != sizeof(port) + || size != sizeof(struct sockaddr_in) + /* Check other socket sent us its port. */ + || buffer[0] != (unsigned short) addresses[!i].sin_port + /* Check kernel says we got the datagram from that socket */ + || readfrom.sin_family != addresses[!i].sin_family + || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr + || readfrom.sin_port != addresses[!i].sin_port) + goto abort_tidy_up_and_fail; + } while (i--); + } + /* My caller (my_socketpair) has validated that this is non-NULL */ + fd[0] = sockets[0]; + fd[1] = sockets[1]; + /* I hereby declare this connection open. May God bless all who cross + her. */ + return 0; + + abort_tidy_up_and_fail: + errno = ECONNABORTED; + tidy_up_and_fail: + { + const int save_errno = errno; + if (sockets[0] != -1) + PerlLIO_close(sockets[0]); + if (sockets[1] != -1) + PerlLIO_close(sockets[1]); + errno = save_errno; + return -1; + } +} +#endif /* EMULATE_SOCKETPAIR_UDP */ + +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) +int +Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { + /* Stevens says that family must be AF_LOCAL, protocol 0. + I'm going to enforce that, then ignore it, and use TCP (or UDP). */ + dTHX; + int listener = -1; + int connector = -1; + int acceptor = -1; + struct sockaddr_in listen_addr; + struct sockaddr_in connect_addr; + Sock_size_t size; + + if (protocol +#ifdef AF_UNIX + || family != AF_UNIX +#endif + ) { + errno = EAFNOSUPPORT; + return -1; + } + if (!fd) { + errno = EINVAL; + return -1; + } + +#ifdef EMULATE_SOCKETPAIR_UDP + if (type == SOCK_DGRAM) + return S_socketpair_udp(fd); +#endif + + listener = PerlSock_socket(AF_INET, type, 0); + if (listener == -1) + return -1; + memset(&listen_addr, 0, sizeof(listen_addr)); + listen_addr.sin_family = AF_INET; + listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + listen_addr.sin_port = 0; /* kernel choses port. */ + if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, + sizeof(listen_addr)) == -1) + goto tidy_up_and_fail; + if (PerlSock_listen(listener, 1) == -1) + goto tidy_up_and_fail; + + connector = PerlSock_socket(AF_INET, type, 0); + if (connector == -1) + goto tidy_up_and_fail; + /* We want to find out the port number to connect to. */ + size = sizeof(connect_addr); + if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(connect_addr)) + goto abort_tidy_up_and_fail; + if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, + sizeof(connect_addr)) == -1) + goto tidy_up_and_fail; + + size = sizeof(listen_addr); + acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, + &size); + if (acceptor == -1) + goto tidy_up_and_fail; + if (size != sizeof(listen_addr)) + goto abort_tidy_up_and_fail; + PerlLIO_close(listener); + /* Now check we are talking to ourself by matching port and host on the + two sockets. */ + if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(connect_addr) + || listen_addr.sin_family != connect_addr.sin_family + || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr + || listen_addr.sin_port != connect_addr.sin_port) { + goto abort_tidy_up_and_fail; + } + fd[0] = connector; + fd[1] = acceptor; + return 0; + + abort_tidy_up_and_fail: +#ifdef ECONNABORTED + errno = ECONNABORTED; /* This would be the standard thing to do. */ +#else +# ifdef ECONNREFUSED + errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ +# else + errno = ETIMEDOUT; /* Desperation time. */ +# endif +#endif + tidy_up_and_fail: + { + const int save_errno = errno; + if (listener != -1) + PerlLIO_close(listener); + if (connector != -1) + PerlLIO_close(connector); + if (acceptor != -1) + PerlLIO_close(acceptor); + errno = save_errno; + return -1; + } +} +#else +/* In any case have a stub so that there's code corresponding + * to the my_socketpair in global.sym. */ +int +Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { +#ifdef HAS_SOCKETPAIR + return socketpair(family, type, protocol, fd); +#else + return -1; +#endif +} +#endif + +/* + +=for apidoc sv_nosharing + +Dummy routine which "shares" an SV when there is no sharing module present. +Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument. +Exists to avoid test for a NULL function pointer and because it could +potentially warn under some level of strict-ness. + +=cut +*/ + +void +Perl_sv_nosharing(pTHX_ SV *sv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); +} + +U32 +Perl_parse_unicode_opts(pTHX_ const char **popt) +{ + const char *p = *popt; + U32 opt = 0; + + if (*p) { + if (isDIGIT(*p)) { + opt = (U32) atoi(p); + while (isDIGIT(*p)) p++; + if (*p && *p != '\n' && *p != '\r') + Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } + else { + for (; *p; p++) { + switch (*p) { + case PERL_UNICODE_STDIN: + opt |= PERL_UNICODE_STDIN_FLAG; break; + case PERL_UNICODE_STDOUT: + opt |= PERL_UNICODE_STDOUT_FLAG; break; + case PERL_UNICODE_STDERR: + opt |= PERL_UNICODE_STDERR_FLAG; break; + case PERL_UNICODE_STD: + opt |= PERL_UNICODE_STD_FLAG; break; + case PERL_UNICODE_IN: + opt |= PERL_UNICODE_IN_FLAG; break; + case PERL_UNICODE_OUT: + opt |= PERL_UNICODE_OUT_FLAG; break; + case PERL_UNICODE_INOUT: + opt |= PERL_UNICODE_INOUT_FLAG; break; + case PERL_UNICODE_LOCALE: + opt |= PERL_UNICODE_LOCALE_FLAG; break; + case PERL_UNICODE_ARGV: + opt |= PERL_UNICODE_ARGV_FLAG; break; + default: + if (*p != '\n' && *p != '\r') + Perl_croak(aTHX_ + "Unknown Unicode option letter '%c'", *p); + } + } + } + } + else + opt = PERL_UNICODE_DEFAULT_FLAGS; + + if (opt & ~PERL_UNICODE_ALL_FLAGS) + Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, + (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); + + *popt = p; + + return opt; +} + +U32 +Perl_seed(pTHX) +{ + dVAR; + /* + * This is really just a quick hack which grabs various garbage + * values. It really should be a real hash algorithm which + * spreads the effect of every input bit onto every output bit, + * if someone who knows about such things would bother to write it. + * Might be a good idea to add that function to CORE as well. + * No numbers below come from careful analysis or anything here, + * except they are primes and SEED_C1 > 1E6 to get a full-width + * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should + * probably be bigger too. + */ +#if RANDBITS > 16 +# define SEED_C1 1000003 +#define SEED_C4 73819 +#else +# define SEED_C1 25747 +#define SEED_C4 20639 +#endif +#define SEED_C2 3 +#define SEED_C3 269 +#define SEED_C5 26107 + +#ifndef PERL_NO_DEV_RANDOM + int fd; +#endif + U32 u; +#ifdef VMS +# include + /* when[] = (low 32 bits, high 32 bits) of time since epoch + * in 100-ns units, typically incremented ever 10 ms. */ + unsigned int when[2]; +#else +# ifdef HAS_GETTIMEOFDAY + struct timeval when; +# else + Time_t when; +# endif +#endif + +/* This test is an escape hatch, this symbol isn't set by Configure. */ +#ifndef PERL_NO_DEV_RANDOM +#ifndef PERL_RANDOM_DEVICE + /* /dev/random isn't used by default because reads from it will block + * if there isn't enough entropy available. You can compile with + * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there + * is enough real entropy to fill the seed. */ +# define PERL_RANDOM_DEVICE "/dev/urandom" +#endif + fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); + if (fd != -1) { + if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) + u = 0; + PerlLIO_close(fd); + if (u) + return u; + } +#endif + +#ifdef VMS + _ckvmssts(sys$gettim(when)); + u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; +#else +# ifdef HAS_GETTIMEOFDAY + PerlProc_gettimeofday(&when,NULL); + u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; +# else + (void)time(&when); + u = (U32)SEED_C1 * when; +# endif +#endif + u += SEED_C3 * (U32)PerlProc_getpid(); + u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); +#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ + u += SEED_C5 * (U32)PTR2UV(&when); +#endif + return u; +} + +UV +Perl_get_hash_seed(pTHX) +{ + dVAR; + const char *s = PerlEnv_getenv("PERL_HASH_SEED"); + UV myseed = 0; + + if (s) + while (isSPACE(*s)) s++; + if (s && isDIGIT(*s)) + myseed = (UV)Atoul(s); + else +#ifdef USE_HASH_SEED_EXPLICIT + if (s) +#endif + { + /* Compute a random seed */ + (void)seedDrand01((Rand_seed_t)seed()); + myseed = (UV)(Drand01() * (NV)UV_MAX); +#if RANDBITS < (UVSIZE * 8) + /* Since there are not enough randbits to to reach all + * the bits of a UV, the low bits might need extra + * help. Sum in another random number that will + * fill in the low bits. */ + myseed += + (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); +#endif /* RANDBITS < (UVSIZE * 8) */ + if (myseed == 0) { /* Superparanoia. */ + myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ + if (myseed == 0) + Perl_croak(aTHX_ "Your random numbers are not that random"); + } + } + PL_rehash_seed_set = TRUE; + + return myseed; +} + +#ifdef USE_ITHREADS +bool +Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) +{ + const char * const stashpv = CopSTASHPV(c); + const char * const name = HvNAME_get(hv); + PERL_UNUSED_CONTEXT; + + if (stashpv == name) + return TRUE; + if (stashpv && name) + if (strEQ(stashpv, name)) + return TRUE; + return FALSE; +} +#endif + + +#ifdef PERL_GLOBAL_STRUCT + +struct perl_vars * +Perl_init_global_struct(pTHX) +{ + struct perl_vars *plvarsp = NULL; +#ifdef PERL_GLOBAL_STRUCT +# define PERL_GLOBAL_STRUCT_INIT +# include "opcode.h" /* the ppaddr and check */ + const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); + const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ + plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); + if (!plvarsp) + exit(1); +# else + plvarsp = PL_VarsPtr; +# endif /* PERL_GLOBAL_STRUCT_PRIVATE */ +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +# undef PERLVARISC +# define PERLVAR(var,type) /**/ +# define PERLVARA(var,n,type) /**/ +# define PERLVARI(var,type,init) plvarsp->var = init; +# define PERLVARIC(var,type,init) plvarsp->var = init; +# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char); +# include "perlvars.h" +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +# undef PERLVARISC +# ifdef PERL_GLOBAL_STRUCT + plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); + if (!plvarsp->Gppaddr) + exit(1); + plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t)); + if (!plvarsp->Gcheck) + exit(1); + Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); + Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); +# endif +# ifdef PERL_SET_VARS + PERL_SET_VARS(plvarsp); +# endif +# undef PERL_GLOBAL_STRUCT_INIT +#endif + return plvarsp; +} + +#endif /* PERL_GLOBAL_STRUCT */ + +#ifdef PERL_GLOBAL_STRUCT + +void +Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) +{ +#ifdef PERL_GLOBAL_STRUCT +# ifdef PERL_UNSET_VARS + PERL_UNSET_VARS(plvarsp); +# endif + free(plvarsp->Gppaddr); + free(plvarsp->Gcheck); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + free(plvarsp); +# endif +#endif +} + +#endif /* PERL_GLOBAL_STRUCT */ + +#ifdef PERL_MEM_LOG + +#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 + +Malloc_t +Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + const STRLEN len = my_sprintf(buf, + "alloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + typename, n * typesize, PTR2UV(newalloc)); + PerlLIO_write(2, buf, len); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + typename, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); + PerlLIO_write(2, buf, len); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, + PTR2UV(oldalloc)); + PerlLIO_write(2, buf, len); +#endif + return oldalloc; +} + +#endif /* PERL_MEM_LOG */ + +/* +=for apidoc my_sprintf + +The C library C, wrapped if necessary, to ensure that it will return +the length of the string written to the buffer. Only rare pre-ANSI systems +need the wrapper function - usually this is a direct call to C. + +=cut +*/ +#ifndef SPRINTF_RETURNS_STRLEN +int +Perl_my_sprintf(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} +#endif + +void +Perl_my_clearenv(pTHX) +{ + dVAR; +#if ! defined(PERL_MICRO) +# if defined(PERL_IMPLICIT_SYS) || defined(WIN32) + PerlEnv_clearenv(); +# else /* ! (PERL_IMPLICIT_SYS || WIN32) */ +# if defined(USE_ENVIRON_ARRAY) +# if defined(USE_ITHREADS) + /* only the parent thread can clobber the process environment */ + if (PL_curinterp == aTHX) +# endif /* USE_ITHREADS */ + { +# if ! defined(PERL_USE_SAFE_PUTENV) + if ( !PL_use_safe_putenv) { + I32 i; + if (environ == PL_origenviron) + environ = (char**)safesysmalloc(sizeof(char*)); + else + for (i = 0; environ[i]; i++) + (void)safesysfree(environ[i]); + } + environ[0] = NULL; +# else /* PERL_USE_SAFE_PUTENV */ +# if defined(HAS_CLEARENV) + (void)clearenv(); +# elif defined(HAS_UNSETENV) + int bsiz = 80; /* Most envvar names will be shorter than this. */ + char *buf = (char*)safesysmalloc(bsiz * sizeof(char)); + while (*environ != NULL) { + char *e = strchr(*environ, '='); + int l = e ? e - *environ : strlen(*environ); + if (bsiz < l + 1) { + (void)safesysfree(buf); + bsiz = l + 1; + buf = (char*)safesysmalloc(bsiz * sizeof(char)); + } + strncpy(buf, *environ, l); + *(buf + l) = '\0'; + (void)unsetenv(buf); + } + (void)safesysfree(buf); +# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */ + /* Just null environ and accept the leakage. */ + *environ = NULL; +# endif /* HAS_CLEARENV || HAS_UNSETENV */ +# endif /* ! PERL_USE_SAFE_PUTENV */ + } +# endif /* USE_ENVIRON_ARRAY */ +# endif /* PERL_IMPLICIT_SYS || WIN32 */ +#endif /* PERL_MICRO */ +} + +#ifdef PERL_IMPLICIT_CONTEXT + +/* implements the MY_CXT_INIT macro. The first time a module is loaded, +the global PL_my_cxt_index is incremented, and that value is assigned to +that module's static my_cxt_index (who's address is passed as an arg). +Then, for each interpreter this function is called for, it makes sure a +void* slot is available to hang the static data off, by allocating or +extending the interpreter's PL_my_cxt_list array */ + +void * +Perl_my_cxt_init(pTHX_ int *index, size_t size) +{ + dVAR; + void *p; + if (*index == -1) { + /* this module hasn't been allocated an index yet */ + MUTEX_LOCK(&PL_my_ctx_mutex); + *index = PL_my_cxt_index++; + MUTEX_UNLOCK(&PL_my_ctx_mutex); + } + + /* make sure the array is big enough */ + if (PL_my_cxt_size <= *index) { + if (PL_my_cxt_size) { + while (PL_my_cxt_size <= *index) + PL_my_cxt_size *= 2; + Renew(PL_my_cxt_list, PL_my_cxt_size, void *); + } + else { + PL_my_cxt_size = 16; + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + } + } + /* newSV() allocates one more than needed */ + p = (void*)SvPVX(newSV(size-1)); + PL_my_cxt_list[*index] = p; + Zero(p, size, char); + return p; +} +#endif + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */