Implement Cwd::abs_path in XS

Message-ID: <Pine.LNX.4.21.0104231151340.3238-100000@marmot.rim.canoe.ca>

p4raw-id: //depot/perl@9797

diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs
index 0f2fde0..cc63a5b 100644 (file)
--- a/ext/Cwd/Cwd.xs
+++ b/ext/Cwd/Cwd.xs
@@ -122,6 +122,91 @@ _cwdxs_fastcwd(void)
   return(path);
 }
 
+char *
+_cwdxs_abs_path(char *start)
+{
+  DIR *parent;
+  Direntry_t *dp;
+  char dotdots[MAXPATHLEN] = "", dir[MAXPATHLEN] = "";
+  char name[FILENAME_MAX] = "";
+  char *cwd;
+  int namelen;
+  struct stat cst, pst, tst;
+
+  if (PerlLIO_stat(start, &cst) < 0) {
+    warn("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);
+
+    if (PerlLIO_stat(dotdots, &cst) < 0) {
+      Safefree(cwd);
+      warn("stat(%s): %s", dotdots, Strerror(errno));
+      return FALSE;
+    }
+    
+    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 {
+      /* Scan through the dir looking for name of previous */
+      if (!(parent = PerlDir_open(dotdots))) {
+        Safefree(cwd);
+        warn("opendir(%s): %s", dotdots, Strerror(errno));
+        return FALSE;
+      }
+    
+      while ((dp = PerlDir_read(parent)) != NULL) {
+        if (strEQ(dp->d_name, "."))
+          continue;
+        if (strEQ(dp->d_name, ".."))
+          continue;
+        
+        Zero(name, FILENAME_MAX, char);
+        Copy(dotdots, name, strlen(dotdots), char);
+        *(name + strlen(dotdots)) = '/';
+        strcat(name, dp->d_name);
+        
+        if (PerlLIO_lstat(name, &tst) < 0) {
+          Safefree(cwd);
+          PerlDir_close(parent);
+          warn("lstat(%s): %s", name, Strerror(errno));
+          return FALSE;
+        }
+        
+        if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino)
+          break;
+      }
+      
+#ifdef DIRNAMLEN
+      namelen = dp->d_namlen;
+#else
+      namelen = strlen(dp->d_name);
+#endif
+      Move(cwd, cwd + namelen + 1, strlen(cwd), char);
+      Copy(dp->d_name, cwd + 1, namelen, char);
+#ifdef VOID_CLOSEDIR
+      PerlDir_close(dir);
+#else
+      if (PerlDir_close(parent) < 0) {
+        warn("closedir(%s): %s", dotdots, Strerror(errno));
+        Safefree(cwd);
+        return FALSE;
+      }
+#endif
+      *cwd = '/';
+    }
+  }
+
+  return cwd;
+}
+  
 
 MODULE = Cwd           PACKAGE = Cwd
 
@@ -138,3 +223,17 @@ PPCODE:
     }
     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/lib/Cwd.pm b/lib/Cwd.pm
index ecf57a2..4e4d39c 100644 (file)
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -85,6 +85,8 @@ 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;
 
 # The 'natural and safe form' for UNIX (pwd may be setuid root)
 
@@ -124,12 +126,11 @@ sub getcwd
 # 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
-my $booted = 0;
 sub fastcwd {
-    unless ($booted) {
+    unless ($Booted) {
        require XSLoader;
         XSLoader::load("Cwd");
-       ++$booted;
+       ++$Booted;
     }
     return &Cwd::_fastcwd;
 }
@@ -205,61 +206,15 @@ sub chdir {
     1;
 }
 
-# Taken from Cwd.pm It is really getcwd with an optional
-# parameter instead of '.'
-#
-
+# Now a callout to an XSUB
 sub abs_path
 {
-    my $start = @_ ? shift : '.';
-    my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
-    unless (@cst = stat( $start ))
-    {
-       carp "stat($start): $!";
-       return '';
+    unless ($Booted) {
+        require XSLoader;
+        XSLoader::load("Cwd");
+        ++$Booted;
     }
-    $cwd = '';
-    $dotdots = $start;
-    do
-    {
-       $dotdots .= '/..';
-       @pst = @cst;
-       unless (opendir(PARENT, $dotdots))
-       {
-           carp "opendir($dotdots): $!";
-           return '';
-       }
-       unless (@cst = stat($dotdots))
-       {
-           carp "stat($dotdots): $!";
-           closedir(PARENT);
-           return '';
-       }
-       if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
-       {
-           $dir = undef;
-       }
-       else
-       {
-           do
-           {
-               unless (defined ($dir = readdir(PARENT)))
-               {
-                   carp "readdir($dotdots): $!";
-                   closedir(PARENT);
-                   return '';
-               }
-               $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
-           }
-           while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
-                  $tst[1] != $pst[1]);
-       }
-       $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
-       closedir(PARENT);
-    } while (defined $dir);
-    chop($cwd) unless $cwd eq '/'; # drop the trailing /
-    $cwd;
+    return &Cwd::_abs_path(@_);
 }
 
 # added function alias for those of us more