~ chicken-core (chicken-5) 4f91e654f04254ba1039e327460e643fefbf5e36
commit 4f91e654f04254ba1039e327460e643fefbf5e36
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Jun 22 13:31:26 2014 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jul 2 09:00:43 2014 +1200
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 ("pathname-expand"). An added advantage is that expansion must be
explicitly performed, and that the egg can be developed separately.
Thanks to Florian Zumbiehl.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 0d62ee04..bbb2b304 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,9 @@
- SRFI-13: fix string-copy! in cases source and destination strings'
memory areas overlap (#1135).
- Fixed bug in make-kmp-restart-vector from SRFI-13.
+ - 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 fea8a028..a131fbf6 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 805eb1de..e85f8059 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 dae789a0..1cf6d037 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 45fd3ea3..4cc34df6 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 9bcda4f3..5d0a732c 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 7e0a71ba..da92f63a 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 c1778f0f..cfd44a83 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 b40ea893..4e22205b 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? ""))
Trap