X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=b6155564738eedef11404c2e1478214819f6e53e;hb=c525946d6533f3d951b57391ea1d735971287550;hp=d604562c30e41028664ca1f2ef2bc30f82daac5f;hpb=2986a63f7e513cf37f46db9f211b77071260031f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index d604562..b615556 100644 --- a/util.c +++ b/util.c @@ -26,17 +26,6 @@ #endif #endif -#ifdef I_VFORK -# include -#endif - -/* Put this after #includes because fork and vfork prototypes may - conflict. -*/ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef I_SYS_WAIT # include #endif @@ -56,14 +45,14 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; # define FD_CLOEXEC 1 /* NeXT needs this */ #endif -/* paranoid version of system's malloc() */ - /* NOTE: Do not call the next three routines directly. Use the macros * in handy.h, so that we can easily redefine everything to do tracking of * allocated hunks back to the original New to track down any memory leaks. * XXX This advice seems to be widely ignored :-( --AD August 1996. */ +/* paranoid version of system's malloc() */ + Malloc_t Perl_safesysmalloc(MEM_SIZE size) { @@ -336,6 +325,37 @@ S_xstat(pTHX_ int flag) #endif /* LEAKTEST */ +/* These must be defined when not using Perl's malloc for binary + * compatibility */ + +#ifndef MYMALLOC + +Malloc_t Perl_malloc (MEM_SIZE nbytes) +{ + dTHXs; + return PerlMem_malloc(nbytes); +} + +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) +{ + dTHXs; + return PerlMem_calloc(elements, size); +} + +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) +{ + dTHXs; + return PerlMem_realloc(where, nbytes); +} + +Free_t Perl_mfree (Malloc_t where) +{ + dTHXs; + PerlMem_free(where); +} + +#endif + /* copy a string up to some (non-backslashed) delimiter, if any */ char * @@ -692,16 +712,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit 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() */ @@ -742,7 +754,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit */ /* If SvTAIL is actually due to \Z or \z, this gives false positives - if PL_multiline. In fact if !PL_multiline the autoritative answer + if PL_multiline. In fact if !PL_multiline the authoritative answer is not supported yet. */ char * @@ -781,33 +793,20 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift /* The value of pos we can stop at: */ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); if (previous + start_shift > stop_pos) { +/* + stop_pos does not include SvTAIL in the count, so this check is incorrect + (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 +*/ +#if 0 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ goto check_tail; +#endif return Nullch; } 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 { if (pos >= stop_pos) break; @@ -827,7 +826,6 @@ 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; @@ -994,17 +992,60 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } +STATIC COP* +S_closest_cop(pTHX_ COP *cop, OP *o) +{ + /* 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) { + OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + { + 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 = (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 0; +} + SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; + COP *cop; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 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. + */ + + 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)); + CopFILE(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'); @@ -1806,7 +1847,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* 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]); if (did_pipes) { @@ -1858,7 +1899,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #undef THAT } /* Parent */ - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ /* Close child's end of pipe */ PerlLIO_close(p[that]); if (did_pipes) @@ -1939,7 +1980,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return Nullfp; 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]); if (did_pipes) { @@ -2000,7 +2041,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THIS #undef THAT } - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ PerlLIO_close(p[that]); if (did_pipes) PerlLIO_close(pp[1]); @@ -2045,7 +2086,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return PerlIO_fdopen(p[This], mode); } #else -#if defined(atarist) || defined(DJGPP) +#if defined(atarist) FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) @@ -2057,10 +2098,72 @@ 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) +{ +#if defined(USE_THREADS) || 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) +{ +#if defined(USE_THREADS) || 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_THREADS) || 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) @@ -2361,7 +2464,7 @@ Perl_pidgone(pTHX_ Pid_t pid, int status) return; } -#if defined(atarist) || defined(OS2) || defined(DJGPP) +#if defined(atarist) || defined(OS2) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -2375,9 +2478,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); I32 result = pclose(f); + PerlIO_releaseFILE(ptr,f); + return result; +} +#endif + #if defined(DJGPP) +int djgpp_pclose(); +I32 +Perl_my_pclose(pTHX_ PerlIO *ptr) +{ + /* Needs work for PerlIO ! */ + FILE *f = PerlIO_findFILE(ptr); + I32 result = djgpp_pclose(f); result = (result << 8) & 0xff00; -#endif PerlIO_releaseFILE(ptr,f); return result; } @@ -2790,7 +2904,7 @@ Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; - SvUPGRADE(sv, SVt_PVMG); + (void)SvUPGRADE(sv, SVt_PVMG); mg = mg_find(sv, PERL_MAGIC_mutex); if (!mg) { condpair_t *cp; @@ -2817,7 +2931,7 @@ Perl_condpair_magic(pTHX_ SV *sv) 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));) + "%p: condpair_magic %p\n", thr, sv))); } } return mg; @@ -2844,7 +2958,7 @@ Perl_sv_lock(pTHX_ SV *osv) MgOWNER(mg) = thr; DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) + PTR2UV(thr), PTR2UV(sv))); MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } @@ -2923,6 +3037,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_reg_start_tmpl = 0; PL_reg_poscache = Nullch; + PL_peepp = MEMBER_TO_FPTR(Perl_peep); + /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex); @@ -3583,7 +3699,7 @@ return FALSE (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* -=for apidoc sv_getcwd +=for apidoc getcwd_sv Fill the sv with current working directory @@ -3598,33 +3714,39 @@ Fill the sv with current working directory * because you might chdir out of a directory that you can't chdir * back into. */ -/* XXX: this needs more porting #ifndef HAS_GETCWD */ int -Perl_sv_getcwd(pTHX_ register SV *sv) +Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO -#ifndef HAS_GETCWD +#ifdef HAS_GETCWD + { + char buf[MAXPATHLEN]; + + /* Some getcwd()s automatically allocate a buffer of the given + * size from the heap if they are given a NULL buffer pointer. + * The problem is that this behaviour is not portable. */ + 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; + } + } + +#else + struct stat statbuf; int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; int namelen, pathlen=0; DIR *dir; Direntry_t *dp; -#endif (void)SvUPGRADE(sv, SVt_PV); -#ifdef HAS_GETCWD - - SvGROW(sv, 128); - while ((getcwd(SvPVX(sv), SvLEN(sv)-1) == NULL) && errno == ERANGE) { - SvGROW(sv, SvLEN(sv) + 128); - } - SvCUR_set(sv, strlen(SvPVX(sv))); - SvPOK_only(sv); - -#else - if (PerlLIO_lstat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; } @@ -3681,6 +3803,10 @@ Perl_sv_getcwd(pTHX_ register SV *sv) SV_CWD_RETURN_UNDEF; } + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; + } + SvGROW(sv, pathlen + namelen + 1); if (pathlen) { @@ -3702,12 +3828,14 @@ Perl_sv_getcwd(pTHX_ register SV *sv) #endif } - SvCUR_set(sv, pathlen); - *SvEND(sv) = '\0'; - SvPOK_only(sv); + if (pathlen) { + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); - if (PerlDir_chdir(SvPVX(sv)) < 0) { - SV_CWD_RETURN_UNDEF; + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } } if (PerlLIO_stat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; @@ -3728,166 +3856,3 @@ Perl_sv_getcwd(pTHX_ register SV *sv) #endif } -/* -=for apidoc sv_realpath - -Wrap or emulate realpath(3). - -=cut - */ -int -Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) -{ -#ifndef PERL_MICRO - char name[MAXPATHLEN] = { 0 }, *s; - STRLEN pathlen, namelen; - - /* Don't use strlen() to avoid running off the end. */ - s = memchr(path, '\0', MAXPATHLEN); - pathlen = s ? s - path : MAXPATHLEN; - -#ifdef HAS_REALPATH - - /* Be paranoid about the use of realpath(), - * it is an infamous source of buffer overruns. */ - - /* Is the source buffer too long? */ - if (pathlen == MAXPATHLEN) { - Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", - path, s ? '=' : '>', MAXPATHLEN); - SV_CWD_RETURN_UNDEF; - } - - /* Here goes nothing. */ - if (realpath(path, name) == NULL) { - Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %s", - path, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } - - /* Is the destination buffer too long? - * Don't use strlen() to avoid running off the end. */ - s = memchr(name, '\0', MAXPATHLEN); - namelen = s ? s - name : MAXPATHLEN; - if (namelen == MAXPATHLEN) { - Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", - path, s ? '=' : '>', MAXPATHLEN); - SV_CWD_RETURN_UNDEF; - } - - /* The coast is clear? */ - sv_setpvn(sv, name, namelen); - SvPOK_only(sv); - - return TRUE; -#else - { - DIR *parent; - Direntry_t *dp; - char dotdots[MAXPATHLEN] = { 0 }; - struct stat cst, pst, tst; - - if (PerlLIO_stat(path, &cst) < 0) { - Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s", - path, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } - - (void)SvUPGRADE(sv, SVt_PV); - - if (!len) { - len = strlen(path); - } - Copy(path, dotdots, len, char); - - for (;;) { - strcat(dotdots, "/.."); - StructCopy(&cst, &pst, struct stat); - - if (PerlLIO_stat(dotdots, &cst) < 0) { - Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } - - if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) { - /* We've reached the root: previous is same as current */ - break; - } else { - STRLEN dotdotslen = strlen(dotdots); - - /* Scan through the dir looking for name of previous */ - if (!(parent = PerlDir_open(dotdots))) { - Perl_warn(aTHX_ "sv_realpath: opendir(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } - - SETERRNO(0,SS$_NORMAL); /* for readdir() */ - while ((dp = PerlDir_read(parent)) != NULL) { - if (SV_CWD_ISDOT(dp)) { - continue; - } - - Copy(dotdots, name, dotdotslen, char); - name[dotdotslen] = '/'; -#ifdef DIRNAMLEN - namelen = dp->d_namlen; -#else - namelen = strlen(dp->d_name); -#endif - Copy(dp->d_name, name + dotdotslen + 1, namelen, char); - name[dotdotslen + 1 + namelen] = 0; - - if (PerlLIO_lstat(name, &tst) < 0) { - PerlDir_close(parent); - Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s", - name, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } - - if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino) - break; - - SETERRNO(0,SS$_NORMAL); /* for readdir() */ - } - - if (!dp && errno) { - Perl_warn(aTHX_ "sv_realpath: readdir(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } - - SvGROW(sv, pathlen + namelen + 1); - if (pathlen) { - /* shift down */ - Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); - } - - *SvPVX(sv) = '/'; - Move(dp->d_name, SvPVX(sv)+1, namelen, char); - pathlen += (namelen + 1); - -#ifdef VOID_CLOSEDIR - PerlDir_close(parent); -#else - if (PerlDir_close(parent) < 0) { - Perl_warn(aTHX_ "sv_realpath: closedir(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } -#endif - } - } - - SvCUR_set(sv, pathlen); - SvPOK_only(sv); - - return TRUE; - } -#endif -#else - return FALSE; -#endif -} -