diff options
Diffstat (limited to 'util.c')
| -rw-r--r-- | util.c | 266 |
1 files changed, 266 insertions, 0 deletions
@@ -4421,3 +4421,269 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, #endif } + +#define SV_CWD_RETURN_UNDEF \ +sv_setsv(sv, &PL_sv_undef); \ +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'))) + +/* +=for apidoc sv_getcwd + +Fill the sv with current working directory + +=cut +*/ + +/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. + * rewritten again by dougm, optimized for use with xs TARG, and to prefer + * getcwd(3) if available + * Comments from the orignal: + * This is a faster version of getcwd. It's also more dangerous + * 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) +{ +#ifndef HAS_GETCWD + 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) { + CWDXS_RETURN_SVUNDEF(sv); + } + + orig_cdev = statbuf.st_dev; + orig_cino = statbuf.st_ino; + cdev = orig_cdev; + cino = orig_cino; + + for (;;) { + odev = cdev; + oino = cino; + + 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; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) {dp->d_name[0] == '.' + continue; + } + + 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; + } + } + + if (!dp) { + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + + if (pathlen) { + /* shift down */ + Move(SvPVX(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); + +#ifdef VOID_CLOSEDIR + PerlDir_close(dir); +#else + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } +#endif + } + + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); + + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + 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"); + } +#endif + + return TRUE; +} + +/* +=for apidoc sv_realpath + +Emulate realpath(3) + +XXX: add configure test for realpath(3) and prefer if available +=cut + */ +int +Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) +{ + DIR *parent; + Direntry_t *dp; + char dotdots[MAXPATHLEN] = { 0 }; + char name[MAXPATHLEN] = { 0 }; + int namelen = 0, pathlen = 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; +} |