X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=bda2beb092aad6bce279d94397e8badec6520335;hb=cc507455df60f06ecd74b2df5a0ae9f17fb3291d;hp=7281fec8627eff9c8cdd091fb01b2742796919a1;hpb=5c831c245cbd15531aac8207bd2cc7d8bf7a2bab;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 7281fec..bda2beb 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -40,13 +40,6 @@ # define vfork fork #endif -#ifdef I_FCNTL -# include -#endif -#ifdef I_SYS_FILE -# include -#endif - #ifdef I_SYS_WAIT # include #endif @@ -95,7 +88,8 @@ Perl_safesysmalloc(MEM_SIZE size) Perl_croak_nocontext("panic: malloc"); #endif ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) malloc %ld bytes\n",PTR2UV(ptr),PL_an++,(long)size)); + 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) return ptr; else if (PL_nomemok) @@ -115,7 +109,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { dTHX; Malloc_t ptr; -#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) +#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ @@ -138,9 +132,10 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Perl_croak_nocontext("panic: realloc"); #endif ptr = PerlMem_realloc(where,size); - - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) rfree\n",PTR2UV(where),PL_an++)); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) realloc %ld bytes\n",PTR2UV(ptr),PL_an++,(long)size)); + PERL_ALLOC_CHECK(ptr); + + 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) return ptr; @@ -159,8 +154,10 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { +#ifdef PERL_IMPLICIT_SYS dTHX; - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) free\n",PTR2UV(where),PL_an++)); +#endif + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { /*SUPPRESS 701*/ PerlMem_free(where); @@ -188,7 +185,8 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif size *= count; ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) calloc %ld x %ld bytes\n",PTR2UV(ptr),PL_an++,(long)count,(long)size)); + PERL_ALLOC_CHECK(ptr); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); if (ptr != Nullch) { memset((void*)ptr, 0, size); return ptr; @@ -703,8 +701,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) if (setlocale_failure) { char *p; bool locwarn = (printwarn > 1 || - printwarn && - (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))); + (printwarn && + (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); if (locwarn) { #ifdef LC_ALL @@ -909,6 +907,15 @@ Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ +/* +=for apidoc fbm_compile + +Analyses the string in order to make fast searches on it using fbm_instr() +-- the Boyer-Moore algorithm. + +=cut +*/ + void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { @@ -969,6 +976,17 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) /* If SvTAIL is actually due to \Z or \z, this gives false positives if multiline */ +/* +=for apidoc fbm_instr + +Returns the location of the SV in the string delimited by C and +C. It returns C if the string can't be found. The C +does not have to be fbm_compiled, but the search will not be as fast +then. + +=cut +*/ + char * Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) { @@ -979,17 +997,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 multiline = flags & FBMrf_MULTILINE; if (bigend - big < littlelen) { - check_tail: if ( SvTAIL(littlestr) && (bigend - big == littlelen - 1) && (littlelen == 1 - || *big == *little && memEQ(big, little, littlelen - 1))) + || (*big == *little && memEQ(big, little, littlelen - 1)))) return (char*)big; return Nullch; } if (littlelen <= 2) { /* Special-cased */ - register char c; if (littlelen == 1) { if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ @@ -1141,7 +1157,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit while (tmp--) { if (*--s == *--little) continue; - differ: s = olds + 1; /* here we pay the price for failure */ little = oldlittle; if (s < bigend) /* fake up continue to outer loop */ @@ -1301,6 +1316,14 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) /* copy a string to a safe spot */ +/* +=for apidoc savepv + +Copy a string to a safe spot. This does not use an SV. + +=cut +*/ + char * Perl_savepv(pTHX_ const char *sv) { @@ -1313,6 +1336,15 @@ Perl_savepv(pTHX_ const char *sv) /* same thing but with a known length */ +/* +=for apidoc savepvn + +Copy a string to a safe spot. The C indicates number of bytes to +copy. This does not use an SV. + +=cut +*/ + char * Perl_savepvn(pTHX_ const char *sv, register I32 len) { @@ -1416,9 +1448,9 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; - if (PL_curcop->cop_line) - Perl_sv_catpvf(aTHX_ sv, " at %_ line %"IVdf, - CopFILESV(PL_curcop), (IV)PL_curcop->cop_line); + if (CopLINE(PL_curcop)) + Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 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'); @@ -1464,6 +1496,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } else { message = Nullch; + msglen = 0; } DEBUG_S(PerlIO_printf(Perl_debug_log, @@ -1617,6 +1650,16 @@ Perl_croak_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=for apidoc croak + +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. + +=cut +*/ + void Perl_croak(pTHX_ const char *pat, ...) { @@ -1696,6 +1739,16 @@ Perl_warn_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=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. + +=cut +*/ + void Perl_warn(pTHX_ const char *pat, ...) { @@ -1821,7 +1874,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } #ifndef VMS /* VMS' my_setenv() is in VMS.c */ -#if !defined(WIN32) && !defined(CYGWIN) +#if !defined(WIN32) && !defined(__CYGWIN__) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -1871,8 +1924,8 @@ Perl_my_setenv(pTHX_ char *nam, char *val) #endif /* PERL_USE_SAFE_PUTENV */ } -#else /* WIN32 || CYGWIN */ -#if defined(CYGWIN) +#else /* WIN32 || __CYGWIN__ */ +#if defined(__CYGWIN__) /* * Save environ of perl.exe, currently Cygwin links in separate environ's * for each exe/dll. Probably should be a member of impure_ptr. @@ -1886,7 +1939,7 @@ Perl_my_setenv_init(char ***penviron) } void -my_setenv(char *nam, char *val) +Perl_my_setenv(pTHX_ char *nam, char *val) { /* You can not directly manipulate the environ[] array because * the routines do some additional work that syncs the Cygwin @@ -1898,13 +1951,13 @@ my_setenv(char *nam, char *val) if (!oldstr) return; unsetenv(nam); - Safefree(oldstr); + safesysfree(oldstr); return; } setenv(nam, val, 1); environ = *Perl_main_environ; /* environ realloc can occur in setenv */ if(oldstr && environ[setenv_getix(nam)] != oldstr) - Safefree(oldstr); + safesysfree(oldstr); } #else /* if WIN32 */ @@ -2000,9 +2053,10 @@ Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ } #endif +/* this is a drop-in replacement for bcopy() */ #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) char * -Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len) +Perl_my_bcopy(register const char *from,register char *to,register I32 len) { char *retval = to; @@ -2020,9 +2074,10 @@ Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len } #endif +/* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * -Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) +Perl_my_memset(register char *loc, register I32 ch, register I32 len) { char *retval = loc; @@ -2032,9 +2087,10 @@ Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) } #endif +/* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char * -Perl_my_bzero(pTHX_ register char *loc, register I32 len) +Perl_my_bzero(register char *loc, register I32 len) { char *retval = loc; @@ -2044,9 +2100,10 @@ Perl_my_bzero(pTHX_ register char *loc, register I32 len) } #endif +/* this is a drop-in replacement for memcmp() */ #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 -Perl_my_memcmp(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_my_memcmp(const char *s1, const char *s2, register I32 len) { register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; @@ -2222,7 +2279,7 @@ VTOH(vtohl,long) #endif /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) +#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) { @@ -2298,8 +2355,8 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) } #endif /* defined OS2 */ /*SUPPRESS 560*/ - if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), getpid()); + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + sv_setiv(GvSV(tmpgv), PerlProc_getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -2494,7 +2551,7 @@ Perl_rsignal_state(pTHX_ int signo) oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); if (sig_trapped) - PerlProc_kill(getpid(), signo); + PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } @@ -2514,7 +2571,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #endif /* !HAS_SIGACTION */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2570,7 +2627,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif /* !DOSISH */ -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { @@ -2593,7 +2650,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) HE *entry; hv_iterinit(PL_pidstatus); - if (entry = hv_iternext(PL_pidstatus)) { + if ((entry = hv_iternext(PL_pidstatus))) { pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); @@ -3120,15 +3177,26 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f } #endif +#ifdef MACOS_TRADITIONAL + if (dosearch && !strchr(scriptname, ':') && + (s = PerlEnv_getenv("Commands"))) +#else if (dosearch && !strchr(scriptname, '/') #ifdef DOSISH && !strchr(scriptname, '\\') #endif - && (s = PerlEnv_getenv("PATH"))) { + && (s = PerlEnv_getenv("PATH"))) +#endif + { bool seen_dot = 0; PL_bufend = s + strlen(s); while (s < PL_bufend) { +#ifdef MACOS_TRADITIONAL + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + ',', + &len); +#else #if defined(atarist) || defined(DOSISH) for (len = 0; *s # ifdef atarist @@ -3145,10 +3213,15 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f ':', &len); #endif /* ! (atarist || DOSISH) */ +#endif /* MACOS_TRADITIONAL */ if (s < PL_bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ +#ifdef MACOS_TRADITIONAL + if (len && tmpbuf[len - 1] != ':') + tmpbuf[len++] = ':'; +#else if (len #if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' @@ -3158,6 +3231,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; +#endif (void)strcpy(tmpbuf + len, scriptname); #endif /* !VMS */ @@ -3182,7 +3256,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f continue; if (S_ISREG(PL_statbuf.st_mode) && cando(S_IRUSR,TRUE,&PL_statbuf) -#ifndef DOSISH +#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) && cando(S_IXUSR,TRUE,&PL_statbuf) #endif ) @@ -3216,8 +3290,46 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f return (scriptname ? savepv(scriptname) : Nullch); } +#ifndef PERL_GET_CONTEXT_DEFINED + +void * +Perl_get_context(void) +{ +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# ifdef OLD_PTHREADS_API + pthread_addr_t t; + if (pthread_getspecific(PL_thr_key, &t)) + Perl_croak_nocontext("panic: pthread_getspecific"); + return (void*)t; +# else +# ifdef I_MACH_CTHREADS + return (void*)cthread_data(cthread_self()); +# else + return (void*)pthread_getspecific(PL_thr_key); +# endif +# endif +#else + return (void*)NULL; +#endif +} + +void +Perl_set_context(void *t) +{ +#if defined(USE_THREADS) || 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 +#endif +} + +#endif /* !PERL_GET_CONTEXT_DEFINED */ #ifdef USE_THREADS + #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ void @@ -3292,18 +3404,6 @@ Perl_cond_wait(pTHX_ perl_cond *cp) } #endif /* FAKE_THREADS */ -#ifdef PTHREAD_GETSPECIFIC_INT -struct perl_thread * -Perl_getTHR(pTHX) -{ - pthread_addr_t t; - - if (pthread_getspecific(PL_thr_key, &t)) - Perl_croak(aTHX_ "panic: pthread_getspecific"); - return (struct perl_thread *) t; -} -#endif - MAGIC * Perl_condpair_magic(pTHX_ SV *sv) { @@ -3319,11 +3419,11 @@ Perl_condpair_magic(pTHX_ SV *sv) COND_INIT(&cp->owner_cond); COND_INIT(&cp->cond); cp->owner = 0; - MUTEX_LOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + LOCK_CRED_MUTEX; /* XXX need separate mutex? */ mg = mg_find(sv, 'm'); if (mg) { /* someone else beat us to initialising it */ - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ MUTEX_DESTROY(&cp->mutex); COND_DESTROY(&cp->owner_cond); COND_DESTROY(&cp->cond); @@ -3334,7 +3434,7 @@ Perl_condpair_magic(pTHX_ SV *sv) mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: condpair_magic %p\n", thr, sv));) } @@ -3413,7 +3513,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) /* 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 */ @@ -3443,7 +3545,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) av_store(thr->threadsv, i, sv); sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); DEBUG_S(PerlIO_printf(Perl_debug_log, - "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); + "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", + (IV)i, t, thr)); } } thr->threadsvp = AvARRAY(thr->threadsv); @@ -3677,7 +3780,8 @@ Perl_my_fflush_all(pTHX) } NV -Perl_my_atof(pTHX_ const char* s) { +Perl_my_atof(pTHX_ const char* s) +{ #ifdef USE_LOCALE_NUMERIC if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { NV x, y; @@ -3696,3 +3800,23 @@ Perl_my_atof(pTHX_ const char* s) { return Perl_atof(s); #endif } + +void +Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj) +{ + SV *sv; + char *name; + + assert(gv); + + sv = sv_newmortal(); + gv_efullname3(sv, gv, Nullch); + name = SvPVX(sv); + + Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name); + + if (io && IoDIRP(io)) + Perl_warner(aTHX_ WARN_CLOSED, + "\t(Are you trying to call %s() on dirhandle %s?)\n", + func, name); +}