X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ab8356eab72d3bf335fe39c04dade4e489b6788f;hb=531b886104fed3302a6d671985aba5e2f6420dd5;hp=838c3620fbe32ba23a9d33f0005d151c7b5cbb14;hpb=8f95b30d1b432a64a1797b0957af01437ea8f0d4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 838c362..ab8356e 100644 --- a/util.c +++ b/util.c @@ -2051,7 +2051,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) @@ -2063,6 +2063,20 @@ 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 */ @@ -2367,7 +2381,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 @@ -2381,9 +2395,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; } @@ -3611,29 +3636,20 @@ Perl_sv_getcwd(pTHX_ register SV *sv) #ifdef HAS_GETCWD { - char* buf; - - SvPOK_off(sv); - New(0, buf, MAXPATHLEN, char); - if (buf) { - buf[MAXPATHLEN] = 0; - /* Yes, some getcwd()s automatically allocate a buffer - * if given a NULL one. Portability is the problem. - * XXX Configure probe needed. */ - if (getcwd(buf, MAXPATHLEN - 1)) { - STRLEN len = strlen(buf); - sv_setpvn(sv, buf, len); - SvPOK_only(sv); - SvCUR_set(sv, len); - } - else - sv_setsv(sv, &PL_sv_undef); - Safefree(buf); - } - else - sv_setsv(sv, &PL_sv_undef); - - return SvPOK(sv) ? TRUE : FALSE; + 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 @@ -3727,12 +3743,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; @@ -3753,150 +3771,3 @@ Perl_sv_getcwd(pTHX_ register SV *sv) #endif } -/* -=for apidoc sv_realpath - -Emulate realpath(3). - -The real realpath() is not used because it's a known can of worms. -We may have bugs but hey, they are our very own. - -=cut - */ -int -Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN maxlen) -{ -#ifndef PERL_MICRO - char name[MAXPATHLEN] = { 0 }; - char dotdots[MAXPATHLEN] = { 0 }; - char *s; - STRLEN pathlen, namelen; - DIR *parent; - Direntry_t *dp; - struct stat cst, pst, tst; - - if (!sv || !path || !maxlen) { - Perl_warn(aTHX_ "sv_realpath: realpath(0x%x, 0x%x, "")", - sv, path, maxlen); - SV_CWD_RETURN_UNDEF; - } - - /* Is the source buffer too long? - * Don't use strlen() to avoid running off the end. */ - if (maxlen >= MAXPATHLEN) - pathlen = maxlen; - else { - s = memchr(path, '\0', MAXPATHLEN); - pathlen = s ? s - path : MAXPATHLEN; - } - if (pathlen >= MAXPATHLEN) { - Perl_warn(aTHX_ "sv_realpath: source too large"); - SV_CWD_RETURN_UNDEF; - } - - 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); - - Copy(path, dotdots, maxlen, char); - - pathlen = 0; - - 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; - } - - if (pathlen + namelen + 1 >= MAXPATHLEN) { - Perl_warn(aTHX_ "sv_realpath: too long name"); - 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; -#else - return FALSE; /* MICROPERL */ -#endif -} -