>From 4aff832727dc554c157b190f27cf7399589ba1e1 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 22 Jun 2014 13:31:26 +0200 Subject: [PATCH] Remove ##sys#expand-home-path as shell expansion has no place in a filesystem API. The functionality is now available as a separate egg for those who need it. An added advantage is that expansion must be explicitly performed, and that the egg can be developed separately. Thanks to Florian Zumbiehl. --- NEWS | 3 + eval.scm | 2 - files.scm | 14 ++--- library.scm | 126 +++++++++++-------------------------- manual/Extensions to the standard | 6 -- posix-common.scm | 35 +++++------ posixunix.scm | 78 +++++++++++------------ posixwin.scm | 12 ++-- tests/path-tests.scm | 9 +-- 9 files changed, 111 insertions(+), 174 deletions(-) diff --git a/NEWS b/NEWS index a9ded9e..6feb672 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,9 @@ - Unit tcp now implicitly depends on ports instead of extras. This may break programs which don't use modules and forgot to require extras but use procedures from it. + - Removed deprecated implicit expansion of $VAR- and ~ in pathnames. + The ~-expansion functionality is now available in the + "pathname-expand" egg (#1001, #1079) (thanks to Florian Zumbiehl). - Unit lolevel: - Restore long-lost but still documented "vector-like?" procedure (#983) diff --git a/eval.scm b/eval.scm index fea8a02..a131fbf 100644 --- a/eval.scm +++ b/eval.scm @@ -966,8 +966,6 @@ (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) ) (set! ##sys#load (lambda (input evaluator pf #!optional timer printer) - (when (string? input) - (set! input (##sys#expand-home-path input)) ) (let* ((fname (cond [(port? input) #f] [(not (string? input)) (badfile input)] diff --git a/files.scm b/files.scm index 805eb1d..e85f805 100644 --- a/files.scm +++ b/files.scm @@ -385,14 +385,12 @@ EOF (display p out) ) (cdr parts)) (when (fx= i prev) (##sys#write-char-0 sep out)) - (let* ((r1 (get-output-string out)) - (r (##sys#expand-home-path r1))) - (when (string=? r1 r) - (when abspath - (set! r (##sys#string-append (string sep) r))) - (when drive - (set! r (##sys#string-append drive r)))) - r)))) + (let ((r (get-output-string out))) + (when abspath + (set! r (##sys#string-append (string sep) r))) + (when drive + (set! r (##sys#string-append drive r))) + r)))) ((*char-pds? (string-ref path i)) (when (and (null? parts) (fx= i prev)) (set! abspath #t)) diff --git a/library.scm b/library.scm index dae789a..b249ce8 100644 --- a/library.scm +++ b/library.scm @@ -1948,63 +1948,32 @@ EOF name) ) name) ) ) ) -(define (##sys#pathname-resolution name thunk . _) - (thunk (##sys#expand-home-path name)) ) - -;; DEPRECATED: implicit $VAR- and ~-expansion will be removed in -;; future versions. See ticket #1001 -(define ##sys#expand-home-path - (lambda (path) - (let ((len (##sys#size path))) - (if (fx> len 0) - (case (##core#inline "C_subchar" path 0) - ((#\~) - (let ((rest (##sys#substring path 1 len))) - (##sys#string-append (or (get-environment-variable "HOME") "") rest) ) ) - ((#\$) - (let loop ((i 1)) - (if (fx>= i len) - path - (let ((c (##core#inline "C_subchar" path i))) - (if (or (eq? c #\/) (eq? c #\\)) - (##sys#string-append - (or (get-environment-variable (##sys#substring path 1 i)) "") - (##sys#substring path i len)) - (loop (fx+ i 1)) ) ) ) ) ) - (else path) ) - "") ) ) ) - (define open-input-file) (define open-output-file) (define close-input-port) (define close-output-port) (let () - (define (open name inp modes loc) (##sys#check-string name loc) - (##sys#pathname-resolution - name - (lambda (name) - (let ([fmode (if inp "r" "w")] - [bmode ""] ) - (do ([modes modes (##sys#slot modes 1)]) - ((null? modes)) - (let ([o (##sys#slot modes 0)]) - (case o - [(#:binary) (set! bmode "b")] - [(#:text) (set! bmode "")] - [(#:append) - (if inp - (##sys#error loc "cannot use append mode with input file") - (set! fmode "a") ) ] - [else (##sys#error loc "invalid file option" o)] ) ) ) - (let ([port (##sys#make-port inp ##sys#stream-port-class name 'stream)]) - (unless (##sys#open-file-port port name (##sys#string-append fmode bmode)) - (##sys#update-errno) - (##sys#signal-hook #:file-error loc (##sys#string-append "cannot open file - " strerror) name) ) - port) ) ) - #:open (not inp) modes) ) + (let ([fmode (if inp "r" "w")] + [bmode ""] ) + (do ([modes modes (##sys#slot modes 1)]) + ((null? modes)) + (let ([o (##sys#slot modes 0)]) + (case o + [(#:binary) (set! bmode "b")] + [(#:text) (set! bmode "")] + [(#:append) + (if inp + (##sys#error loc "cannot use append mode with input file") + (set! fmode "a") ) ] + [else (##sys#error loc "invalid file option" o)] ) ) ) + (let ([port (##sys#make-port inp ##sys#stream-port-class name 'stream)]) + (unless (##sys#open-file-port port name (##sys#string-append fmode bmode)) + (##sys#update-errno) + (##sys#signal-hook #:file-error loc (##sys#string-append "cannot open file - " strerror) name) ) + port) ) ) (define (close port loc) (##sys#check-port port loc) @@ -2074,25 +2043,17 @@ EOF (define (file-exists? name) (##sys#check-string name 'file-exists?) - (##sys#pathname-resolution - name - (lambda (name) - (and (##sys#file-exists? - (##sys#platform-fixup-pathname name) - #f #f 'file-exists?) - name) ) - #:exists?) ) + (and (##sys#file-exists? + (##sys#platform-fixup-pathname name) + #f #f 'file-exists?) + name) ) (define (directory-exists? name) (##sys#check-string name 'directory-exists?) - (##sys#pathname-resolution - name - (lambda (name) - (and (##sys#file-exists? - (##sys#platform-fixup-pathname name) - #f #t 'directory-exists?) - name) ) - #:exists?) ) + (and (##sys#file-exists? + (##sys#platform-fixup-pathname name) + #f #t 'directory-exists?) + name) ) (define (##sys#flush-output port) ((##sys#slot (##sys#slot port 2) 5) port) ; flush-output @@ -2123,33 +2084,22 @@ EOF (define (delete-file filename) (##sys#check-string filename 'delete-file) - (##sys#pathname-resolution - filename - (lambda (filename) - (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename 'delete-file))) - (##sys#update-errno) - (##sys#signal-hook - #:file-error 'delete-file - (##sys#string-append "cannot delete file - " strerror) filename) ) - filename) - #:delete) ) + (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename 'delete-file))) + (##sys#update-errno) + (##sys#signal-hook + #:file-error 'delete-file + (##sys#string-append "cannot delete file - " strerror) filename) ) + filename) (define (rename-file old new) (##sys#check-string old 'rename-file) (##sys#check-string new 'rename-file) - (##sys#pathname-resolution - old - (lambda (old) - (##sys#pathname-resolution - new - (lambda (new) - (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old 'rename-file) (##sys#make-c-string new))) - (##sys#update-errno) - (##sys#signal-hook - #:file-error 'rename-file - (##sys#string-append "cannot rename file - " strerror) old new) ) - new))) - #:rename new) ) + (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old 'rename-file) (##sys#make-c-string new))) + (##sys#update-errno) + (##sys#signal-hook + #:file-error 'rename-file + (##sys#string-append "cannot rename file - " strerror) old new) ) + new) ;;; Decorate procedure with arbitrary data diff --git a/manual/Extensions to the standard b/manual/Extensions to the standard index 45fd3ea..4cc34df 100644 --- a/manual/Extensions to the standard +++ b/manual/Extensions to the standard @@ -186,12 +186,6 @@ an optional 2nd parameter: if not {{#f}} (which is the default), toplevel bindings to standard procedures are mutable and new toplevel bindings may be introduced. -=== Pathnames expansion - -The ''tilde'' character ({{~}}) is automatically expanded in pathnames. -Additionally, if a pathname starts with {{$VARIABLE...}}, then the prefix is replaced -by the value of the given environment variable. - === Optional arguments for port-related procedures If the procedures {{current-input-port}} and diff --git a/posix-common.scm b/posix-common.scm index 9bcda4f..5d0a732 100644 --- a/posix-common.scm +++ b/posix-common.scm @@ -224,7 +224,7 @@ EOF ((string? file) (let ((path (##sys#make-c-string (##sys#platform-fixup-pathname - (##sys#expand-home-path file)) + file) loc))) (if link (##core#inline "C_lstat" path) @@ -253,7 +253,7 @@ EOF (lambda (f t) (##sys#check-number t 'set-file-modification-time) (let ((r ((foreign-lambda int "set_file_mtime" c-string scheme-object) - (##sys#expand-home-path f) t))) + f t))) (when (fx< r 0) (posix-error #:file-error 'set-file-modification-time @@ -429,21 +429,20 @@ EOF (unless (fx= 0 (##core#inline "C_rmdir" sname)) (posix-error #:file-error 'delete-directory "cannot delete directory" dir) ))) (##sys#check-string name 'delete-directory) - (let ((name (##sys#expand-home-path name))) - (if recursive - (let ((files (find-files ; relies on `find-files' to list dir-contents before dir - name - dotfiles: #t - follow-symlinks: #f))) - (for-each - (lambda (f) - ((cond ((symbolic-link? f) delete-file) - ((directory? f) rmdir) - (else delete-file)) - f)) - files) - (rmdir name)) - (rmdir name))))) + (if recursive + (let ((files (find-files ; relies on `find-files' to list dir-contents before dir + name + dotfiles: #t + follow-symlinks: #f))) + (for-each + (lambda (f) + ((cond ((symbolic-link? f) delete-file) + ((directory? f) rmdir) + (else delete-file)) + f)) + files) + (rmdir name)) + (rmdir name)))) (define directory (lambda (#!optional (spec (current-directory)) show-dotfiles?) @@ -453,7 +452,7 @@ EOF [entry (##sys#make-pointer)] ) (##core#inline "C_opendir" - (##sys#make-c-string (##sys#expand-home-path spec) 'directory) handle) + (##sys#make-c-string spec 'directory) handle) (if (##sys#null-pointer? handle) (posix-error #:file-error 'directory "cannot open directory" spec) (let loop () diff --git a/posixunix.scm b/posixunix.scm index 7e0a71b..da92f63 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -506,7 +506,7 @@ EOF (##sys#check-string filename 'file-open) (##sys#check-exact flags 'file-open) (##sys#check-exact mode 'file-open) - (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename) 'file-open) flags mode)]) + (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)]) (when (eq? -1 fd) (posix-error #:file-error 'file-open "cannot open file" filename flags mode) ) fd) ) ) ) ) @@ -618,22 +618,21 @@ EOF (define create-directory (lambda (name #!optional parents?) (##sys#check-string name 'create-directory) - (let ((name (##sys#expand-home-path name))) - (unless (or (fx= 0 (##sys#size name)) - (file-exists? name)) - (if parents? - (let loop ((dir (let-values (((dir file ext) (decompose-pathname name))) - (if file (make-pathname dir file ext) dir)))) - (when (and dir (not (directory? dir))) - (loop (pathname-directory dir)) - (*create-directory 'create-directory dir)) ) - (*create-directory 'create-directory name) ) ) - name))) + (unless (or (fx= 0 (##sys#size name)) + (file-exists? name)) + (if parents? + (let loop ((dir (let-values (((dir file ext) (decompose-pathname name))) + (if file (make-pathname dir file ext) dir)))) + (when (and dir (not (directory? dir))) + (loop (pathname-directory dir)) + (*create-directory 'create-directory dir)) ) + (*create-directory 'create-directory name) ) ) + name)) (define change-directory (lambda (name) (##sys#check-string name 'change-directory) - (let ((sname (##sys#make-c-string (##sys#expand-home-path 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))) @@ -1059,7 +1058,7 @@ EOF (lambda (fname m) (##sys#check-string fname 'change-file-mode) (##sys#check-exact m 'change-file-mode) - (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname) 'change-file-mode) m) 0) + (when (fx< (##core#inline "C_chmod" (##sys#make-c-string fname 'change-file-mode) m) 0) (posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) ) (define change-file-owner @@ -1067,7 +1066,7 @@ EOF (##sys#check-string fn 'change-file-owner) (##sys#check-exact uid 'change-file-owner) (##sys#check-exact gid 'change-file-owner) - (when (fx< (##core#inline "C_chown" (##sys#make-c-string (##sys#expand-home-path fn) 'change-file-owner) uid gid) 0) + (when (fx< (##core#inline "C_chown" (##sys#make-c-string fn 'change-file-owner) uid gid) 0) (posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) ) (define-foreign-variable _r_ok int "R_OK") @@ -1077,7 +1076,7 @@ EOF (let () (define (check filename acc loc) (##sys#check-string filename loc) - (let ([r (fx= 0 (##core#inline "C_test_access" (##sys#make-c-string (##sys#expand-home-path filename) loc) acc))]) + (let ([r (fx= 0 (##core#inline "C_test_access" (##sys#make-c-string filename loc) acc))]) (unless r (##sys#update-errno)) r) ) (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?))) @@ -1117,8 +1116,8 @@ EOF (##sys#check-string new 'create-symbolic-link) (when (fx< (##core#inline "C_symlink" - (##sys#make-c-string (##sys#expand-home-path old) 'create-symbolic-link) - (##sys#make-c-string (##sys#expand-home-path new) 'create-symbolic-link) ) + (##sys#make-c-string old 'create-symbolic-link) + (##sys#make-c-string new 'create-symbolic-link) ) 0) (posix-error #:file-error 'create-symbol-link "cannot create symbolic link" old new) ) ) ) @@ -1136,24 +1135,23 @@ EOF (define (read-symbolic-link fname #!optional canonicalize) (##sys#check-string fname 'read-symbolic-link) - (let ((fname (##sys#expand-home-path fname))) - (if canonicalize - (receive (base-origin base-directory directory-components) (decompose-directory fname) - (let loop ((components directory-components) - (result (string-append (or base-origin "") (or base-directory "")))) - (if (null? components) - result - (let ((pathname (make-pathname result (car components)))) - (if (file-exists? pathname) - (loop (cdr components) - (if (symbolic-link? pathname) - (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link))) - (if (absolute-pathname? target) - target - (make-pathname result target))) - pathname)) - (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname)))))) - (##sys#read-symbolic-link fname 'read-symbolic-link)))) + (if canonicalize + (receive (base-origin base-directory directory-components) (decompose-directory fname) + (let loop ((components directory-components) + (result (string-append (or base-origin "") (or base-directory "")))) + (if (null? components) + result + (let ((pathname (make-pathname result (car components)))) + (if (file-exists? pathname) + (loop (cdr components) + (if (symbolic-link? pathname) + (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link))) + (if (absolute-pathname? target) + target + (make-pathname result target))) + pathname)) + (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname)))))) + (##sys#read-symbolic-link fname 'read-symbolic-link))) (define file-link (let ([link (foreign-lambda int "link" c-string c-string)]) @@ -1354,7 +1352,7 @@ EOF (define file-truncate (lambda (fname off) (##sys#check-number off 'file-truncate) - (when (fx< (cond [(string? fname) (##core#inline "C_truncate" (##sys#make-c-string (##sys#expand-home-path fname) 'file-truncate) off)] + (when (fx< (cond [(string? fname) (##core#inline "C_truncate" (##sys#make-c-string fname 'file-truncate) off)] [(fixnum? fname) (##core#inline "C_ftruncate" fname off)] [else (##sys#error 'file-truncate "invalid file" fname)] ) 0) @@ -1413,7 +1411,7 @@ EOF (##sys#check-string fname 'create-fifo) (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))]) (##sys#check-exact mode 'create-fifo) - (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string (##sys#expand-home-path fname) 'create-fifo) mode) 0) + (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0) (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) ) (define fifo? @@ -1421,7 +1419,7 @@ EOF (##sys#check-string filename 'fifo?) (case (##core#inline "C_i_fifo_p" - (##sys#make-c-string (##sys#expand-home-path filename) 'fifo?)) + (##sys#make-c-string filename 'fifo?)) ((#t) #t) ((#f) #f) ((0) (##sys#signal-hook #:file-error 'fifo? "file does not exist" filename) ) @@ -1631,7 +1629,7 @@ EOF (let ([s (car el)]) (##sys#check-string s 'process-execute) (setenv i s (##sys#size s)) ) ) ) - (let* ([prg (##sys#make-c-string (##sys#expand-home-path filename) 'process-execute)] + (let* ([prg (##sys#make-c-string filename 'process-execute)] [r (if envlist (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg) )] ) diff --git a/posixwin.scm b/posixwin.scm index c1778f0..cfd44a8 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -736,7 +736,7 @@ EOF (##sys#check-string filename 'file-open) (##sys#check-exact flags 'file-open) (##sys#check-exact mode 'file-open) - (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename) 'file-open) flags mode)]) + (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)]) (when (eq? -1 fd) (##sys#update-errno) (##sys#signal-hook #:file-error 'file-open "cannot open file" filename flags mode) ) @@ -811,7 +811,7 @@ EOF (define create-directory (lambda (name #!optional parents?) (##sys#check-string name 'create-directory) - (let ((name (##sys#expand-home-path name))) + (let ((name name)) (if parents? (create-directory-helper-parents name) (create-directory-helper name)) @@ -820,7 +820,7 @@ EOF (define change-directory (lambda (name) (##sys#check-string name 'change-directory) - (let ((sname (##sys#make-c-string (##sys#expand-home-path 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 @@ -1020,7 +1020,7 @@ EOF (lambda (fname m) (##sys#check-string fname 'change-file-mode) (##sys#check-exact m 'change-file-mode) - (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname) 'change-file-mode) m) 0) + (when (fx< (##core#inline "C_chmod" (##sys#make-c-string fname 'change-file-mode) m) 0) (##sys#update-errno) (##sys#signal-hook #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) ) @@ -1031,7 +1031,7 @@ EOF (let () (define (check filename acc loc) (##sys#check-string filename loc) - (let ([r (fx= 0 (##core#inline "C_test_access" (##sys#make-c-string (##sys#expand-home-path filename) loc) acc))]) + (let ([r (fx= 0 (##core#inline "C_test_access" (##sys#make-c-string filename loc) acc))]) (unless r (##sys#update-errno)) r) ) (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?))) @@ -1214,7 +1214,7 @@ EOF (build-exec-argvec loc (and arglst ($quote-args-list arglst exactf)) setarg 1) (build-exec-argvec loc envlst setenv 0) (##core#inline "C_flushall") - (##sys#make-c-string (##sys#expand-home-path filename) loc) ) ) ) + (##sys#make-c-string filename loc) ) ) ) (define ($exec-teardown loc msg filename res) (##sys#update-errno) diff --git a/tests/path-tests.scm b/tests/path-tests.scm index b40ea89..4e22205 100644 --- a/tests/path-tests.scm +++ b/tests/path-tests.scm @@ -52,12 +52,9 @@ (test "../../foo" (normalize-pathname "../../foo" 'unix)) (test "c:\\." (normalize-pathname "c:\\" 'windows)) -(define home (get-environment-variable "HOME")) - -(when home - (test (string-append home "/foo") (normalize-pathname "~/foo" 'unix)) - (test "c:~/foo" (normalize-pathname "c:~/foo" 'unix)) - (test (string-append home "\\foo") (normalize-pathname "c:~\\foo" 'windows))) +(test "~/foo" (normalize-pathname "~/foo" 'unix)) +(test "c:~/foo" (normalize-pathname "c:~/foo" 'unix)) +(test "c:~\\foo" (normalize-pathname "c:~\\foo" 'windows)) (assert (directory-null? "/.//")) (assert (directory-null? "")) -- 1.7.10.4