X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=623c44cf8169f11d75415b8407f8a1d9ef20a382;hb=d424a232f6c786ba60298440b9c4cec451863a98;hp=d95f1e00e18cf8f7cc87be949b397a35cde5f0b9;hpb=c95c94b15b7d8f41273b51b8ded25db157723aa1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index d95f1e0..623c44c 100644 --- a/util.c +++ b/util.c @@ -339,19 +339,19 @@ S_xstat(pTHX_ int flag) Malloc_t Perl_malloc (MEM_SIZE nbytes) { dTHXs; - return PerlMem_malloc(nbytes); + return (Malloc_t)PerlMem_malloc(nbytes); } Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) { dTHXs; - return PerlMem_calloc(elements, size); + return (Malloc_t)PerlMem_calloc(elements, size); } Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) { dTHXs; - return PerlMem_realloc(where, nbytes); + return (Malloc_t)PerlMem_realloc(where, nbytes); } Free_t Perl_mfree (Malloc_t where) @@ -546,7 +546,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); @@ -578,9 +578,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register STRLEN littlelen = l; register 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)))) @@ -707,7 +707,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; register unsigned char *oldlittle; - if (littlelen > bigend - big) + if (littlelen > (STRLEN)(bigend - big)) return Nullch; --littlelen; /* Last char found by table lookup */ @@ -752,7 +752,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit /* 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. @@ -883,18 +883,21 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) =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 = Nullch; - if (sv) { - New(902,newaddr,strlen(sv)+1,char); - (void)strcpy(newaddr,sv); + if (pv) { + New(902,newaddr,strlen(pv)+1,char); + (void)strcpy(newaddr,pv); } return newaddr; } @@ -904,22 +907,23 @@ Perl_savepv(pTHX_ const char *sv) /* =for apidoc savepvn -Copy a string to a safe spot. The C indicates number of bytes to -copy. If pointer is NULL allocate space for a string of size specified. -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 *sv, register I32 len) +Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; New(903,newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ - if (sv) { - Copy(sv,newaddr,len,char); /* might not be null terminated */ + if (pv) { + Copy(pv,newaddr,len,char); /* might not be null terminated */ newaddr[len] = '\0'; /* is now */ } else { @@ -931,18 +935,18 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len) /* =for apidoc savesharedpv -Copy a string to a safe spot in memory shared between threads. -This does not use an SV. +A version of C which allocates the duplicate string in memory +which is shared between threads. =cut */ char * -Perl_savesharedpv(pTHX_ const char *sv) +Perl_savesharedpv(pTHX_ const char *pv) { register char *newaddr = Nullch; - if (sv) { - newaddr = PerlMemShared_malloc(strlen(sv)+1); - (void)strcpy(newaddr,sv); + if (pv) { + newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); + (void)strcpy(newaddr,pv); } return newaddr; } @@ -1109,9 +1113,10 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(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_5005THREADS if (thr->tid) @@ -1584,11 +1589,16 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) *(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) { +#ifdef USE_ITHREADS + /* only parent thread can modify process environment */ + if (PL_curinterp == aTHX) +#endif + { #ifndef PERL_USE_SAFE_PUTENV /* most putenv()s leak, so we manipulate environ directly */ register I32 i=setenv_getix(nam); /* where does it go? */ @@ -1632,7 +1642,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val) my_setenv_format(environ[i], nam, nlen, val, vlen); #else /* PERL_USE_SAFE_PUTENV */ -# if defined(__CYGWIN__) +# if defined(__CYGWIN__) || defined( EPOC) setenv(nam, val, 1); # else char *new_env; @@ -1647,6 +1657,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val) (void)putenv(new_env); # endif /* __CYGWIN__ */ #endif /* PERL_USE_SAFE_PUTENV */ + } } #else /* WIN32 || NETWARE */ @@ -2085,6 +2096,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) 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]); @@ -2102,7 +2114,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) @@ -2112,7 +2123,11 @@ 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) @@ -2146,8 +2161,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THIS #undef THAT } - do_execfree(); /* free any memory malloced by child on fork */ - PerlLIO_close(p[that]); + do_execfree(); /* free any memory malloced by child on vfork */ if (did_pipes) PerlLIO_close(pp[1]); if (p[that] < p[This]) { @@ -2155,6 +2169,9 @@ 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; @@ -2275,7 +2292,7 @@ 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++) { @@ -2520,6 +2537,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) hv_iterinit(PL_pidstatus); if ((entry = hv_iternext(PL_pidstatus))) { + SV *sv; + char spid[TYPE_CHARS(int)]; + pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); @@ -2636,8 +2656,8 @@ Perl_same_dirent(pTHX_ char *a, char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); - struct stat tmpstatbuf1; - struct stat tmpstatbuf2; + Stat_t tmpstatbuf1; + Stat_t tmpstatbuf2; SV *tmpsv = sv_newmortal(); if (fa) @@ -3101,7 +3121,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) SvCUR_set(sv, sizeof(struct perl_thread)); thr = (Thread) SvPVX(sv); #ifdef DEBUGGING - memset(thr, 0xab, sizeof(struct perl_thread)); + Poison(thr, 1, struct perl_thread); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -3371,6 +3391,7 @@ Perl_my_fflush_all(pTHX) 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); @@ -3438,9 +3459,7 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) } if (gv && isGV(gv)) { - SV *sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPVX(sv); + name = GvENAME(gv); } if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { @@ -3859,7 +3878,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #else - struct stat statbuf; + Stat_t statbuf; int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; int namelen, pathlen=0; DIR *dir; @@ -4018,7 +4037,7 @@ Perl_new_vstring(pTHX_ char *s, SV *sv) /* this is atoi() that tolerates underscores */ char *end = pos; UV mult = 1; - if ( *(s-1) == '_') { + if ( s > pos && *(s-1) == '_') { mult = 10; } while (--end >= s) { @@ -4201,7 +4220,7 @@ S_socketpair_udp (int fd[2]) { } #endif /* EMULATE_SOCKETPAIR_UDP */ -#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) +#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. @@ -4299,7 +4318,11 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { * 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