From: Doug MacEachern Date: Thu, 31 May 2001 17:37:37 +0000 (-0700) Subject: [patch] Cwd.xs optimizations/abstraction X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f22d8e4b6ac8b32788591ab647fd40e18ea984f2;p=p5sagit%2Fp5-mst-13.2.git [patch] Cwd.xs optimizations/abstraction Message-ID: p4raw-id: //depot/perl@10369 --- diff --git a/embed.h b/embed.h index 4acb7f3..1a2f0e0 100644 --- a/embed.h +++ b/embed.h @@ -668,6 +668,7 @@ #define sv_collxfrm Perl_sv_collxfrm #endif #define sv_compile_2op Perl_sv_compile_2op +#define sv_getcwd Perl_sv_getcwd #define sv_dec Perl_sv_dec #define sv_dump Perl_sv_dump #define sv_derived_from Perl_sv_derived_from @@ -691,6 +692,7 @@ #define sv_pos_b2u Perl_sv_pos_b2u #define sv_pvutf8n_force Perl_sv_pvutf8n_force #define sv_pvbyten_force Perl_sv_pvbyten_force +#define sv_realpath Perl_sv_realpath #define sv_reftype Perl_sv_reftype #define sv_replace Perl_sv_replace #define sv_report_used Perl_sv_report_used @@ -2163,6 +2165,7 @@ #define sv_collxfrm(a,b) Perl_sv_collxfrm(aTHX_ a,b) #endif #define sv_compile_2op(a,b,c,d) Perl_sv_compile_2op(aTHX_ a,b,c,d) +#define sv_getcwd(a) Perl_sv_getcwd(aTHX_ a) #define sv_dec(a) Perl_sv_dec(aTHX_ a) #define sv_dump(a) Perl_sv_dump(aTHX_ a) #define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b) @@ -2186,6 +2189,7 @@ #define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) #define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b) #define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b) +#define sv_realpath(a,b,c) Perl_sv_realpath(aTHX_ a,b,c) #define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b) #define sv_replace(a,b) Perl_sv_replace(aTHX_ a,b) #define sv_report_used() Perl_sv_report_used(aTHX) @@ -4249,6 +4253,8 @@ #endif #define Perl_sv_compile_2op CPerlObj::Perl_sv_compile_2op #define sv_compile_2op Perl_sv_compile_2op +#define Perl_sv_getcwd CPerlObj::Perl_sv_getcwd +#define sv_getcwd Perl_sv_getcwd #define Perl_sv_dec CPerlObj::Perl_sv_dec #define sv_dec Perl_sv_dec #define Perl_sv_dump CPerlObj::Perl_sv_dump @@ -4297,6 +4303,8 @@ #define sv_pvutf8n_force Perl_sv_pvutf8n_force #define Perl_sv_pvbyten_force CPerlObj::Perl_sv_pvbyten_force #define sv_pvbyten_force Perl_sv_pvbyten_force +#define Perl_sv_realpath CPerlObj::Perl_sv_realpath +#define sv_realpath Perl_sv_realpath #define Perl_sv_reftype CPerlObj::Perl_sv_reftype #define sv_reftype Perl_sv_reftype #define Perl_sv_replace CPerlObj::Perl_sv_replace diff --git a/embed.pl b/embed.pl index 91165b3..139270b 100755 --- a/embed.pl +++ b/embed.pl @@ -1136,7 +1136,7 @@ DOC: redo FUNC; } } else { - warn "$file:$line:$in"; + warn "$file:$line:$in (=cut missing?)"; } } } @@ -2029,6 +2029,7 @@ Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2 Ap |char* |sv_collxfrm |SV* sv|STRLEN* nxp #endif Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|AV** avp +Apd |int |sv_getcwd |SV* sv Apd |void |sv_dec |SV* sv Ap |void |sv_dump |SV* sv Apd |bool |sv_derived_from|SV* sv|const char* name @@ -2055,6 +2056,7 @@ Ap |void |sv_pos_b2u |SV* sv|I32* offsetp Aopd |char* |sv_pvn_force |SV* sv|STRLEN* lp Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp +Apd |int |sv_realpath |SV* sv|char *path|STRLEN len Apd |char* |sv_reftype |SV* sv|int ob Apd |void |sv_replace |SV* sv|SV* nsv Ap |void |sv_report_used diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs index 872591d..7b36716 100644 --- a/ext/Cwd/Cwd.xs +++ b/ext/Cwd/Cwd.xs @@ -2,250 +2,36 @@ #include "perl.h" #include "XSUB.h" -/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. - * 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. */ -char * -_cwdxs_fastcwd(void) -{ -/* XXX Should we just use getcwd(3) if available? */ - struct stat statbuf; - int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; - int i = 0, j = 0, k = 0, ndirs = 16, pathlen = 0, namelen; - DIR *dir; - Direntry_t *dp; - char **names, *path; - - Newz(0, names, ndirs, char*); - - if (PerlLIO_lstat(".", &statbuf) < 0) { - Safefree(names); - return FALSE; - } - 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) { - Safefree(names); - return FALSE; - } - if (PerlLIO_stat(".", &statbuf) < 0) { - Safefree(names); - return FALSE; - } - cdev = statbuf.st_dev; - cino = statbuf.st_ino; - if (odev == cdev && oino == cino) - break; - - if (!(dir = PerlDir_open("."))) { - Safefree(names); - return FALSE; - } - - while ((dp = PerlDir_read(dir)) != NULL) { - if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { - Safefree(names); - return FALSE; - } - if (strEQ(dp->d_name, ".")) - continue; - if (strEQ(dp->d_name, "..")) - continue; - tdev = statbuf.st_dev; - tino = statbuf.st_ino; - if (tino == oino && tdev == odev) - break; - } - - if (!dp) { - Safefree(names); - return FALSE; - } - - if (i >= ndirs) { - ndirs += 16; - Renew(names, ndirs, char*); - } -#ifdef DIRNAMLEN - namelen = dp->d_namlen; -#else - namelen = strlen(dp->d_name); -#endif - Newz(0, *(names + i), namelen + 1, char); - Copy(dp->d_name, *(names + i), namelen, char); - *(names[i] + namelen) = '\0'; - pathlen += (namelen + 1); - ++i; - -#ifdef VOID_CLOSEDIR - PerlDir_close(dir); -#else - if (PerlDir_close(dir) < 0) { - Safefree(names); - return FALSE; - } -#endif - } - - Newz(0, path, pathlen + 1, char); - for (j = i - 1; j >= 0; j--) { - *(path + k) = '/'; - Copy(names[j], path + k + 1, strlen(names[j]) + 1, char); - k = k + strlen(names[j]) + 1; - Safefree(names[j]); - } +MODULE = Cwd PACKAGE = Cwd - if (PerlDir_chdir(path) < 0) { - Safefree(names); - Safefree(path); - return FALSE; - } - if (PerlLIO_stat(".", &statbuf) < 0) { - Safefree(names); - Safefree(path); - return FALSE; - } - 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"); +PROTOTYPES: ENABLE - Safefree(names); - return(path); +void +fastcwd() +PPCODE: +{ + dXSTARG; + sv_getcwd(TARG); + XSprePUSH; PUSHTARG; } -char * -_cwdxs_abs_path(char *start) +void +abs_path(svpath=Nullsv) + SV *svpath +PPCODE: { - DIR *parent; - Direntry_t *dp; - char dotdots[MAXPATHLEN] = { 0 }; - char name[MAXPATHLEN] = { 0 }; - char *cwd; - int namelen = 0; - struct stat cst, pst, tst; - - if (PerlLIO_stat(start, &cst) < 0) { - warn("abs_path: stat(\"%s\"): %s", start, Strerror(errno)); - return FALSE; - } - - Newz(0, cwd, MAXPATHLEN, char); - Copy(start, dotdots, strlen(start), char); - - for (;;) { - strcat(dotdots, "/.."); - StructCopy(&cst, &pst, struct stat); + dXSTARG; + char *path; + STRLEN len; - if (PerlLIO_stat(dotdots, &cst) < 0) { - Safefree(cwd); - warn("abs_path: stat(\"%s\"): %s", dotdots, Strerror(errno)); - return FALSE; + if (svpath) { + path = SvPV(svpath, len); } - - 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))) { - Safefree(cwd); - warn("abs_path: opendir(\"%s\"): %s", dotdots, Strerror(errno)); - return FALSE; - } - - SETERRNO(0,SS$_NORMAL); /* for readdir() */ - while ((dp = PerlDir_read(parent)) != NULL) { - if (strEQ(dp->d_name, ".")) - continue; - if (strEQ(dp->d_name, "..")) - 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) { - Safefree(cwd); - PerlDir_close(parent); - warn("abs_path: lstat(\"%s\"): %s", name, Strerror(errno)); - return FALSE; - } - - if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino) - break; - - SETERRNO(0,SS$_NORMAL); /* for readdir() */ - } - - - if (!dp && errno) { - warn("abs_path: readdir(\"%s\"): %s", dotdots, Strerror(errno)); - Safefree(cwd); - return FALSE; - } - - Move(cwd, cwd + namelen + 1, strlen(cwd), char); - Copy(dp->d_name, cwd + 1, namelen, char); -#ifdef VOID_CLOSEDIR - PerlDir_close(parent); -#else - if (PerlDir_close(parent) < 0) { - warn("abs_path: closedir(\"%s\"): %s", dotdots, Strerror(errno)); - Safefree(cwd); - return FALSE; - } -#endif - *cwd = '/'; + else { + path = "."; + len = 1; } - } - return cwd; + sv_realpath(TARG, path, len); + XSprePUSH; PUSHTARG; } - - -MODULE = Cwd PACKAGE = Cwd - -PROTOTYPES: ENABLE - -char * -_fastcwd() -PPCODE: - char * buf; - buf = _cwdxs_fastcwd(); - if (buf) { - PUSHs(sv_2mortal(newSVpv(buf, 0))); - Safefree(buf); - } - else - XSRETURN_UNDEF; - -char * -_abs_path(start = ".") - char * start -PREINIT: - char * buf; -PPCODE: - buf = _cwdxs_abs_path(start); - if (buf) { - PUSHs(sv_2mortal(newSVpv(buf, 0))); - Safefree(buf); - } - else - XSRETURN_UNDEF; diff --git a/global.sym b/global.sym index 17e3df3..544e1cf 100644 --- a/global.sym +++ b/global.sym @@ -410,6 +410,7 @@ Perl_sv_cmp Perl_sv_cmp_locale Perl_sv_collxfrm Perl_sv_compile_2op +Perl_sv_getcwd Perl_sv_dec Perl_sv_dump Perl_sv_derived_from @@ -433,6 +434,7 @@ Perl_sv_pos_b2u Perl_sv_pvn_force Perl_sv_pvutf8n_force Perl_sv_pvbyten_force +Perl_sv_realpath Perl_sv_reftype Perl_sv_replace Perl_sv_report_used diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 4e4d39c..27a3105 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -85,8 +85,10 @@ use base qw/ Exporter /; our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); -# Indicates if the XS portion has been loaded or not -my $Booted = 0; +eval { + require XSLoader; + XSLoader::load('Cwd'); +}; # The 'natural and safe form' for UNIX (pwd may be setuid root) @@ -123,19 +125,6 @@ sub getcwd abs_path('.'); } -# Now a callout to an XSUB. We have to delay booting of the XSUB -# until the first time fastcwd is called since Cwd::cwd is needed in the -# building of perl when dynamic loading may be unavailable -sub fastcwd { - unless ($Booted) { - require XSLoader; - XSLoader::load("Cwd"); - ++$Booted; - } - return &Cwd::_fastcwd; -} - - # Keeps track of current working directory in PWD environment var # Usage: # use Cwd 'chdir'; @@ -206,17 +195,6 @@ sub chdir { 1; } -# Now a callout to an XSUB -sub abs_path -{ - unless ($Booted) { - require XSLoader; - XSLoader::load("Cwd"); - ++$Booted; - } - return &Cwd::_abs_path(@_); -} - # added function alias for those of us more # used to the libc function. --tchrist 27-Jan-00 *realpath = \&abs_path; diff --git a/objXSUB.h b/objXSUB.h index c830fe1..a3cb92c 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -1645,6 +1645,10 @@ #define Perl_sv_compile_2op pPerl->Perl_sv_compile_2op #undef sv_compile_2op #define sv_compile_2op Perl_sv_compile_2op +#undef Perl_sv_getcwd +#define Perl_sv_getcwd pPerl->Perl_sv_getcwd +#undef sv_getcwd +#define sv_getcwd Perl_sv_getcwd #undef Perl_sv_dec #define Perl_sv_dec pPerl->Perl_sv_dec #undef sv_dec @@ -1737,6 +1741,10 @@ #define Perl_sv_pvbyten_force pPerl->Perl_sv_pvbyten_force #undef sv_pvbyten_force #define sv_pvbyten_force Perl_sv_pvbyten_force +#undef Perl_sv_realpath +#define Perl_sv_realpath pPerl->Perl_sv_realpath +#undef sv_realpath +#define sv_realpath Perl_sv_realpath #undef Perl_sv_reftype #define Perl_sv_reftype pPerl->Perl_sv_reftype #undef sv_reftype diff --git a/perlapi.c b/perlapi.c index b839a35..b8ec2c5 100644 --- a/perlapi.c +++ b/perlapi.c @@ -2981,6 +2981,13 @@ Perl_sv_compile_2op(pTHXo_ SV* sv, OP** startp, char* code, AV** avp) return ((CPerlObj*)pPerl)->Perl_sv_compile_2op(sv, startp, code, avp); } +#undef Perl_sv_getcwd +int +Perl_sv_getcwd(pTHXo_ SV* sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_getcwd(sv); +} + #undef Perl_sv_dec void Perl_sv_dec(pTHXo_ SV* sv) @@ -3142,6 +3149,13 @@ Perl_sv_pvbyten_force(pTHXo_ SV* sv, STRLEN* lp) return ((CPerlObj*)pPerl)->Perl_sv_pvbyten_force(sv, lp); } +#undef Perl_sv_realpath +int +Perl_sv_realpath(pTHXo_ SV* sv, char *path, STRLEN len) +{ + return ((CPerlObj*)pPerl)->Perl_sv_realpath(sv, path, len); +} + #undef Perl_sv_reftype char* Perl_sv_reftype(pTHXo_ SV* sv, int ob) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index b8dfd82..aa72c9c 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -952,7 +952,7 @@ parameter is the precomputed hash value; if it is zero then Perl will compute it. The return value is the new hash entry so created. It will be NULL if the operation failed or if the value did not need to be actually stored within the hash (as in the case of tied hashes). Otherwise the -contents of the return value can be accessed using the C macros +contents of the return value can be accessed using the C macros described here. Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function returned NULL. @@ -2408,19 +2408,19 @@ false, defined or undefined. Does not handle 'get' magic. =for hackers Found in file sv.h -=item SvTYPE - -Returns the type of the SV. See C. +=item svtype - svtype SvTYPE(SV* sv) +An enum of flags for Perl types. These are found in the file B +in the C enum. Test these flags with the C macro. =for hackers Found in file sv.h -=item svtype +=item SvTYPE -An enum of flags for Perl types. These are found in the file B -in the C enum. Test these flags with the C macro. +Returns the type of the SV. See C. + + svtype SvTYPE(SV* sv) =for hackers Found in file sv.h @@ -2754,6 +2754,15 @@ Free the memory used by an SV. =for hackers Found in file sv.c +=item sv_getcwd + +Fill the sv with current working directory + + int sv_getcwd(SV* sv) + +=for hackers +Found in file util.c + =item sv_gets Get a line from the filehandle and store it into the SV, optionally @@ -2894,6 +2903,16 @@ L. =for hackers Found in file sv.c +=item sv_realpath + +Emulate realpath(3) + +XXX: add configure test for realpath(3) and prefer if available + int sv_realpath(SV* sv, char *path, STRLEN len) + +=for hackers +Found in file util.c + =item sv_reftype Returns a string describing what the SV is a reference to. diff --git a/proto.h b/proto.h index c824a79..5104261 100644 --- a/proto.h +++ b/proto.h @@ -752,6 +752,7 @@ PERL_CALLCONV I32 Perl_sv_cmp_locale(pTHX_ SV* sv1, SV* sv2); PERL_CALLCONV char* Perl_sv_collxfrm(pTHX_ SV* sv, STRLEN* nxp); #endif PERL_CALLCONV OP* Perl_sv_compile_2op(pTHX_ SV* sv, OP** startp, char* code, AV** avp); +PERL_CALLCONV int Perl_sv_getcwd(pTHX_ SV* sv); PERL_CALLCONV void Perl_sv_dec(pTHX_ SV* sv); PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv); PERL_CALLCONV bool Perl_sv_derived_from(pTHX_ SV* sv, const char* name); @@ -776,6 +777,7 @@ PERL_CALLCONV void Perl_sv_pos_b2u(pTHX_ SV* sv, I32* offsetp); PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp); PERL_CALLCONV char* Perl_sv_pvutf8n_force(pTHX_ SV* sv, STRLEN* lp); PERL_CALLCONV char* Perl_sv_pvbyten_force(pTHX_ SV* sv, STRLEN* lp); +PERL_CALLCONV int Perl_sv_realpath(pTHX_ SV* sv, char *path, STRLEN len); PERL_CALLCONV char* Perl_sv_reftype(pTHX_ SV* sv, int ob); PERL_CALLCONV void Perl_sv_replace(pTHX_ SV* sv, SV* nsv); PERL_CALLCONV void Perl_sv_report_used(pTHX); diff --git a/util.c b/util.c index 9a3ff31..06c3551 100644 --- a/util.c +++ b/util.c @@ -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; +}