Hi all, The attached patch gets rid of change-directory and change-directory* in favour of using (current-directory) with an argument. The argument can either be a string or a file descriptor. As far as I know we can't have ports open on directories. If we can, we'll have to add support for using current-directory with a port, too, for consistency.
This opens an important question though: Should current-directory return whatever is passed in, or should it call itself with no arguments to get the name of the directory we changed into? Note that this will fail if we passed in a file descriptor to a directory which was unlinked! So even though this is somewhat weird I think just returning whatever was passed in (if the change succeeded) is probably the best we can do. Trying to return a normalized pathname if a string is passed in could be acceptable, but might be too much magic. Cheers, Peter
From 672dfe5a3f613c752178444596d2fd335f9a5472 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 13 Aug 2017 17:45:52 +0200
Subject: [PATCH] Remove change-directory(*) in favour of current-directory
We now also implement 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.
---
chicken-install.scm | 4 ++--
posix-common.scm | 16 ++++++++++++++--
posix.scm | 7 +++----
posixunix.scm | 17 -----------------
posixwin.scm | 39 ++++++++++++++++++++-------------------
types.db | 5 +----
6 files changed, 40 insertions(+), 48 deletions(-)
diff --git a/chicken-install.scm b/chicken-install.scm
index ad8bbfa6..2f209be8 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -853,12 +853,12 @@
(file-exists? tscript))
(let ((old (current-directory))
(cmd (string-append default-csi " -s " tscript " " name " " (or version ""))))
- (change-directory testdir)
+ (current-directory testdir)
(let ((r (system cmd)))
(d "running: ~a~%" cmd)
(flush-output (current-error-port))
(cond ((zero? r)
- (change-directory old)
+ (current-directory old)
#t)
(else
(print "test script failed with nonzero exit status")
diff --git a/posix-common.scm b/posix-common.scm
index da68a48c..d265d578 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -496,8 +496,20 @@ EOF
(define (current-directory #!optional dir)
(if dir
- (change-directory dir)
- (let* ((buffer (make-string 1024))
+ (let ((r (cond ((fixnum? dir) (##core#inline "C_fchdir" dir))
+ ((string? dir)
+ (##core#inline "C_chdir"
+ (##sys#make-c-string dir 'current-directory)))
+ (else
+ (##sys#signal-hook
+ #:type-error 'current-directory
+ "bad argument type - not a fixnum or string" dir)) ) ) )
+ (if (fx< r 0)
+ (posix-error #:file-error 'current-directory "cannot change current directory" dir)
+ ;; TODO: Always return a (canonicalized?) string?
+ ;; Now we're returning whatever is passed in, as-is.
+ dir) )
+ (let* ((buffer (make-string 1024)) ; TODO: Buffer length?
(len (##core#inline "C_curdir" buffer)) )
#+(or unix cygwin)
(##sys#update-errno)
diff --git a/posix.scm b/posix.scm
index 8115bfd3..5dbc4c3b 100644
--- a/posix.scm
+++ b/posix.scm
@@ -41,10 +41,9 @@
(module chicken.posix
(block-device? call-with-input-pipe call-with-output-pipe
- change-directory change-directory* character-device? close-input-pipe
- close-output-pipe create-fifo create-pipe
- create-session create-symbolic-link current-directory
- current-effective-group-id current-effective-user-id
+ character-device? close-input-pipe close-output-pipe
+ create-fifo create-pipe create-session create-symbolic-link
+ current-directory current-effective-group-id current-effective-user-id
current-effective-user-name current-group-id current-process-id
current-user-id current-user-name directory
directory? duplicate-fileno emergency-exit fcntl/dupfd fcntl/getfd
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 a5bb6904..7932242a 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -305,26 +305,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 +739,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)
diff --git a/types.db b/types.db
index e62c82db..efbee46a 100644
--- a/types.db
+++ b/types.db
@@ -1917,8 +1917,6 @@
(chicken.posix#emergency-exit (procedure chicken.posix#emergency-exit (#!optional fixnum) noreturn))
(chicken.posix#call-with-input-pipe (#(procedure #:enforce) chicken.posix#call-with-input-pipe (string (procedure (input-port) . *) #!optional symbol) . *))
(chicken.posix#call-with-output-pipe (#(procedure #:enforce) chicken.posix#call-with-output-pipe (string (procedure (input-port) . *) #!optional symbol) . *))
-(chicken.posix#change-directory (#(procedure #:clean #:enforce) chicken.posix#change-directory (string) string))
-(chicken.posix#change-directory* (#(procedure #:clean #:enforce) chicken.posix#change-directory* (fixnum) fixnum))
(chicken.posix#close-input-pipe (#(procedure #:clean #:enforce) chicken.posix#close-input-pipe (input-port) fixnum))
(chicken.posix#close-output-pipe (#(procedure #:clean #:enforce) chicken.posix#close-output-pipe (output-port) fixnum))
(chicken.posix#create-fifo (#(procedure #:clean #:enforce) chicken.posix#create-fifo (string #!optional fixnum) undefined))
@@ -1926,8 +1924,7 @@
(chicken.posix#create-session (#(procedure #:clean) chicken.posix#create-session () fixnum))
(chicken.posix#create-symbolic-link (#(procedure #:clean #:enforce) chicken.posix#create-symbolic-link (string string) undefined))
-;; extra arg for "parameterize" - ugh, what a hack...
-(chicken.posix#current-directory (#(procedure #:clean #:enforce) chicken.posix#current-directory (#!optional string *) string))
+(chicken.posix#current-directory (#(procedure #:clean #:enforce) chicken.posix#current-directory (#!optional (or string fixnum) *) (or string fixnum)))
(chicken.posix#current-effective-group-id (#(procedure #:clean) chicken.posix#current-effective-group-id () fixnum))
(chicken.posix#current-effective-user-id (#(procedure #:clean) chicken.posix#current-effective-user-id () fixnum))
--
2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
