From 672dfe5a3f613c752178444596d2fd335f9a5472 Mon Sep 17 00:00:00 2001 From: Peter Bex 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