~ chicken-core (chicken-5) 1491b55d1aca1b6a533b3f6170d185fd8db340fb

commit 1491b55d1aca1b6a533b3f6170d185fd8db340fb
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sun Aug 13 17:45:52 2017 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Fri Sep 1 15:57:32 2017 -0400

    Stub fchdir() on Windows to simplify change-directory[*]
    
    This implements fchdir() in Windows, by abstracting out the file
    descriptor->path mapping first introduced with fchmod(). Windows
    won't in fact actually allow you to "open" a directory so you won't be
    able to obtain a file handle to a directory using file-open, but at
    least this allows us to use the exact same code on Windows and Unix,
    thus reducing code duplication.
    
    In any case, abstracting the fd to path function can prove helpful in
    other situations too.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/posix-common.scm b/posix-common.scm
index da68a48c..e07dd5af 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -494,6 +494,20 @@ EOF
 
 ;;; Set or get current directory:
 
+(define change-directory
+  (lambda (name)
+    (##sys#check-string name 'change-directory)
+    (let ((sname (##sys#make-c-string name 'change-directory)))
+      (unless (fx= 0 (##core#inline "C_chdir" sname))
+       (posix-error #:file-error 'change-directory "cannot change current directory" name))
+      name)))
+
+(define (change-directory* fd)
+  (##sys#check-fixnum fd 'change-directory*)
+  (unless (fx= 0 (##core#inline "C_fchdir" fd))
+    (posix-error #:file-error 'change-directory* "cannot change current directory" fd))
+  fd)
+
 (define (current-directory #!optional dir)
   (if dir
       (change-directory dir)
diff --git a/posixunix.scm b/posixunix.scm
index 170e6494..d5224be2 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -560,23 +560,6 @@ static C_word C_i_fifo_p(C_word name)
 		(and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl)))))))))
 
 
-;;; Directory stuff:
-
-(define change-directory
-  (lambda (name)
-    (##sys#check-string name 'change-directory)
-    (let ((sname (##sys#make-c-string name 'change-directory)))
-      (unless (fx= 0 (##core#inline "C_chdir" sname))
-	(posix-error #:file-error 'change-directory "cannot change current directory" name) )
-      name)))
-
-(define (change-directory* fd)
-  (##sys#check-fixnum fd 'change-directory*) 
-  (unless (fx= 0 (##core#inline "C_fchdir" fd)) 
-    (posix-error #:file-error 'change-directory* "cannot change current directory" fd) )
-  fd)
-
-
 ;;; Pipes:
 
 (define open-input-pipe)
diff --git a/posixwin.scm b/posixwin.scm
index fca18f99..704b2689 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -33,7 +33,6 @@
 ; symbolic-link?
 ; set-signal-mask!  signal-mask	 signal-masked?	 signal-mask!  signal-unmask!
 ; user-information
-; change-directory*
 ; change-file-owner
 ; current-user-id  current-group-id  current-effective-user-id	current-effective-group-id
 ; current-effective-user-name
@@ -305,26 +304,40 @@ set_last_errno()
     return 0;
 }
 
-static C_word C_fchmod(C_word fd, C_word m)
+static int fd_to_path(C_word fd, TCHAR path[])
 {
-  TCHAR path[MAX_PATH];
   DWORD result;
   HANDLE fh = (HANDLE)_get_osfhandle(C_unfix(fd));
 
   if (fh == INVALID_HANDLE_VALUE) {
     set_last_errno();
-    return C_fix(-1);
+    return -1;
   }
 
   result = GetFinalPathNameByHandle(fh, path, MAX_PATH, VOLUME_NAME_DOS);
   if (result == 0) {
     set_last_errno();
-    return C_fix(-1);
+    return -1;
   } else if (result >= MAX_PATH) { /* Shouldn't happen */
     errno = ENOMEM; /* For lack of anything better */
-    return C_fix(-1);
+    return -1;
+  } else {
+    return 0;
   }
-  return C_fix(chmod(path, C_unfix(m)));
+}
+
+static C_word C_fchmod(C_word fd, C_word m)
+{
+  TCHAR path[MAX_PATH];
+  if (fd_to_path(fd, path) == -1) return C_fix(-1);
+  else return C_fix(chmod(path, C_unfix(m)));
+}
+
+static C_word C_fchdir(C_word fd)
+{
+  TCHAR path[MAX_PATH];
+  if (fd_to_path(fd, path) == -1) return C_fix(-1);
+  else return C_fix(chdir(path));
 }
 
 static int C_fcall
@@ -725,19 +738,6 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
 		  (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template))
 	      (values fd tmpl)))))))
 
-;;; Directory stuff:
-
-(define change-directory
-  (lambda (name)
-    (##sys#check-string name 'change-directory)
-    (let ((sname (##sys#make-c-string name 'change-directory)))
-      (unless (fx= 0 (##core#inline "C_chdir" sname))
-	(##sys#update-errno)
-	(##sys#signal-hook
-	 #:file-error 'change-directory "cannot change current directory" name) )
-      name)))
-
-
 ;;; Pipes:
 
 (define open-input-pipe)
@@ -1145,7 +1145,6 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
 
 ;;; unimplemented stuff:
 
-(define-unimplemented change-directory*)
 (define-unimplemented chown) ; covers set-file-group! and set-file-owner!
 (define-unimplemented create-fifo)
 (define-unimplemented create-session)