>From c7f594ab48d7bdfc3fdedf4fa9e1c59d1a917b2c Mon Sep 17 00:00:00 2001 From: Florian Zumbiehl Date: Fri, 15 Mar 2013 07:58:02 +0100 Subject: [PATCH] Remove ##sys#expand-home-path. Remove ##sys#expand-home-path as shell expansion has no place in a filesystem API. Signed-off-by: Peter Bex --- NEWS | 3 ++ eval.scm | 2 - files.scm | 14 +++---- library.scm | 123 +++++++++++++++++------------------------------------- manual/Unit utils | 13 ++++++ posix-common.scm | 35 ++++++++-------- posixunix.scm | 45 ++++++++++---------- posixwin.scm | 12 +++--- utils.scm | 12 ++++++ 9 files changed, 117 insertions(+), 142 deletions(-) diff --git a/NEWS b/NEWS index c2d16fb..bfb7a6e 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,9 @@ - Security fixes - ./.csirc is no longer loaded from the current directory upon startup of csi, which could lead to untrusted code execution. (thanks to Florian Zumbiehl) + - Path operations no longer implicitly expand ~ and shell variables at the + start of a string. ~-expansion can now be done explicitly through a + new "EP" procedure from unit utils. (thanks to Florian Zumbiehl) - Tools - csc: added "-oi"/"-ot" options as alternatives to "-emit-inline-file" diff --git a/eval.scm b/eval.scm index 62227cd..e92d6f7 100644 --- a/eval.scm +++ b/eval.scm @@ -940,8 +940,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 7398350..6bbd6f6 100644 --- a/files.scm +++ b/files.scm @@ -383,14 +383,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 5a2862e..f223b23 100644 --- a/library.scm +++ b/library.scm @@ -1934,30 +1934,6 @@ EOF name) ) name) ) ) ) -(define (##sys#pathname-resolution name thunk . _) - (thunk (##sys#expand-home-path name)) ) - -(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) @@ -1967,28 +1943,24 @@ EOF (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) @@ -2058,25 +2030,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 @@ -2107,33 +2071,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/Unit utils b/manual/Unit utils index 8c1df37..7109988 100644 --- a/manual/Unit utils +++ b/manual/Unit utils @@ -47,6 +47,19 @@ characters that would have a special meaning to the shell are escaped using backslash ({{\}}). +=== Directory expansion + +==== ep + +(ep PATH) + +Expands an optional leading {{~}} character in {{PATH}} to the value +of the {{HOME}} environment variable. If {{$HOME}} is not set, it +will be expanded to the empty string. This exist since Chicken 4.8.2, +as a convenience method to emulate earlier implicit behaviour of all +path procedures. + + === Dynamic compilation ==== compile-file diff --git a/posix-common.scm b/posix-common.scm index 1f7c4b3..3b8602e 100644 --- a/posix-common.scm +++ b/posix-common.scm @@ -160,7 +160,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) @@ -189,7 +189,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 @@ -323,21 +323,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?) @@ -347,7 +346,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 6d1fe51..e35f919 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -608,7 +608,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) ) ) ) ) @@ -765,22 +765,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))) @@ -1205,7 +1204,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 @@ -1213,7 +1212,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") @@ -1223,7 +1222,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?))) @@ -1263,8 +1262,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) ) ) ) @@ -1276,7 +1275,7 @@ EOF (##sys#check-string fname 'read-symbolic-link) (let ((len (##core#inline "C_do_readlink" - (##sys#make-c-string (##sys#expand-home-path fname) 'read-symbolic-link) buf))) + (##sys#make-c-string fname 'read-symbolic-link) buf))) (if (fx< len 0) (if canonicalize fname @@ -1479,7 +1478,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) @@ -1538,7 +1537,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? @@ -1546,7 +1545,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) ) @@ -1797,7 +1796,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 d2cc927..86515be 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -967,7 +967,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) ) @@ -1100,7 +1100,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)) @@ -1109,7 +1109,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 @@ -1309,7 +1309,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) ) ) ) @@ -1320,7 +1320,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?))) @@ -1530,7 +1530,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/utils.scm b/utils.scm index 715219d..263a095 100644 --- a/utils.scm +++ b/utils.scm @@ -75,6 +75,18 @@ (string->list str))))))) +;;; Expand pathnames for home directory +(define (ep 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) ) ) + (else path) ) + "") ) ) + + ;;; Compile and load file (define compile-file-options (make-parameter '("-O2" "-d2"))) -- 1.7.12