This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[patch] Cwd.xs optimizations/abstraction
authorDoug MacEachern <dougm@covalent.net>
Thu, 31 May 2001 17:37:37 +0000 (10:37 -0700)
committerJarkko Hietaniemi <jhi@iki.fi>
Fri, 1 Jun 2001 12:47:21 +0000 (12:47 +0000)
Message-ID: <Pine.LNX.4.21.0105311733270.732-100000@mako.covalent.net>

p4raw-id: //depot/perl@10369

embed.h
embed.pl
ext/Cwd/Cwd.xs
global.sym
lib/Cwd.pm
objXSUB.h
perlapi.c
pod/perlapi.pod
proto.h
util.c

diff --git a/embed.h b/embed.h
index 4acb7f3..1a2f0e0 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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
 #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)
 #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)
 #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
 #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
index 91165b3..139270b 100755 (executable)
--- 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
index 872591d..7b36716 100644 (file)
 #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;
index 17e3df3..544e1cf 100644 (file)
@@ -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
index 4e4d39c..27a3105 100644 (file)
@@ -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;
index c830fe1..a3cb92c 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #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
 #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
index b839a35..b8ec2c5 100644 (file)
--- 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)
index b8dfd82..aa72c9c 100644 (file)
@@ -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<He???> macros
+contents of the return value can be accessed using the C<He?> macros
 described here.  Note that the caller is responsible for suitably
 incrementing the reference count of C<val> 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<svtype>.
+=item svtype
 
-       svtype  SvTYPE(SV* sv)
+An enum of flags for Perl types.  These are found in the file B<sv.h> 
+in the C<svtype> enum.  Test these flags with the C<SvTYPE> 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<sv.h> 
-in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV.  See C<svtype>.
+
+       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</sv_pvn_force>.
 =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 (file)
--- 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 (file)
--- 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;
+}