~ chicken-core (chicken-5) 9603c61688c5e667364f5424d39f82e5a717d3fb
commit 9603c61688c5e667364f5424d39f82e5a717d3fb
Author: Mario Domenech Goulart <mario.goulart@gmail.com>
AuthorDate: Sun Jan 17 11:28:56 2016 -0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Thu Jan 21 19:18:45 2016 +0100
Fix path quoting patch (introduced in 5920000)
This is basically a revert of 5920000, a cherry pick of edd4926 (from
master) and a squash of them.
The changes in 5920000 were not the right ones to be commited (my
mistake). They correspond to a work-in-progress patch from the
https://lists.gnu.org/archive/html/chicken-hackers/2015-11/msg00017.html
thread.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken-install.scm b/chicken-install.scm
index 0798dcc0..185bdce2 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -522,6 +522,11 @@
(and (not (any loop (cdr p))) (fail)))
(else (error "invalid `platform' property" name (cadr platform))))))))
+ (define (back-slash->forward-slash path)
+ (if *windows-shell*
+ (string-translate path #\\ #\/)
+ path))
+
(define (make-install-command egg-name egg-version dep?)
(conc
*csi*
@@ -544,12 +549,12 @@
(let ((prefix (get-prefix)))
(if prefix
(sprintf " -e \"(destination-prefix \\\"~a\\\")\""
- (normalize-pathname prefix 'unix))
+ (back-slash->forward-slash (normalize-pathname prefix)))
""))
(let ((prefix (get-prefix #t)))
(if prefix
(sprintf " -e \"(runtime-prefix \\\"~a\\\")\""
- (normalize-pathname prefix 'unix))
+ (back-slash->forward-slash (normalize-pathname prefix)))
""))
(if (pair? *csc-features*)
(sprintf " -e \"(extra-features '~s)\"" *csc-features*)
diff --git a/csc.scm b/csc.scm
index 786f369a..0285938e 100644
--- a/csc.scm
+++ b/csc.scm
@@ -70,6 +70,7 @@
(define-foreign-variable BINARY_VERSION int "C_BINARY_VERSION")
(define-foreign-variable POSTINSTALL_PROGRAM c-string "C_INSTALL_POSTINSTALL_PROGRAM")
+(define windows-shell WINDOWS_SHELL)
;;; Parameters:
@@ -91,23 +92,30 @@
(define cross-chicken (##sys#fudge 39))
(define (prefix str dir default)
- (if chicken-prefix
- (make-pathname (list chicken-prefix dir) str)
- default) )
+ (quotewrap
+ (if chicken-prefix
+ (make-pathname (list chicken-prefix dir) str)
+ default) ))
+
+(define (back-slash->forward-slash path)
+ (if windows-shell
+ (string-translate path #\\ #\/)
+ path))
(define (quotewrap str)
+ (qs (back-slash->forward-slash (normalize-pathname str))))
+
+(define (quotewrap-no-slash-trans str)
(qs (normalize-pathname str)))
(define home
- (quotewrap
- (prefix "" "share" (if host-mode INSTALL_SHARE_HOME TARGET_SHARE_HOME))))
+ (prefix "" "share" (if host-mode INSTALL_SHARE_HOME TARGET_SHARE_HOME)))
(define translator
- (quotewrap
- (prefix "chicken" "bin"
- (make-pathname
- INSTALL_BIN_HOME
- CHICKEN_PROGRAM))))
+ (prefix "chicken" "bin"
+ (make-pathname
+ INSTALL_BIN_HOME
+ CHICKEN_PROGRAM)))
(define compiler (quotewrap (if host-mode INSTALL_CC TARGET_CC)))
(define c++-compiler (quotewrap (if host-mode INSTALL_CXX TARGET_CXX)))
@@ -123,7 +131,6 @@
(define shared-library-extension ##sys#load-dynamic-extension)
(define default-translation-optimization-options '())
(define pic-options (if (or mingw cygwin) '("-DPIC") '("-fPIC" "-DPIC")))
-(define windows-shell WINDOWS_SHELL)
(define generate-manifest #f)
(define libchicken (string-append "lib" INSTALL_LIB_NAME))
@@ -221,11 +228,10 @@
(define default-library-files
(list
- (quotewrap
- (prefix default-library "lib"
- (string-append
- (if host-mode INSTALL_LIB_HOME TARGET_LIB_HOME)
- (string-append "/" default-library)))) ))
+ (prefix default-library "lib"
+ (string-append
+ (if host-mode INSTALL_LIB_HOME TARGET_LIB_HOME)
+ (string-append "/" default-library)))) )
(define default-shared-library-files
(list (string-append "-l" (if host-mode INSTALL_LIB_NAME TARGET_LIB_NAME))))
@@ -246,10 +252,10 @@
(define builtin-compile-options
(append
- (if include-dir (list (conc "-I\"" include-dir "\"")) '())
+ (if include-dir (list (conc "-I" include-dir)) '())
(cond ((get-environment-variable "CHICKEN_C_INCLUDE_PATH") =>
(lambda (path)
- (map (cut string-append "-I\"" <> "\"") (string-split path ":;"))))
+ (map (cut string-append "-I" <>) (map quotewrap (string-split path ":;")))))
(else '()))))
(define compile-only-flag "-c")
@@ -269,25 +275,24 @@
(append
(cond (elf
(list
- (conc "-L\"" library-dir "\"")
- (conc " -Wl,-R\""
+ (conc "-L" library-dir)
+ (conc " -Wl,-R"
(if deployed
"\\$ORIGIN"
(prefix "" "lib"
(if host-mode
INSTALL_LIB_HOME
- TARGET_RUN_LIB_HOME)))
- "\"")) )
- (aix
- (list (conc "-Wl,-R\"" library-dir "\"")))
+ TARGET_RUN_LIB_HOME))))))
+ (aix
+ (list (conc "-Wl,-R\"" library-dir "\"")))
(else
- (list (conc "-L\"" library-dir "\""))))
+ (list (conc "-L" library-dir))))
(if (and deployed (memq (software-version) '(freebsd openbsd netbsd)))
(list "-Wl,-z,origin")
'())
(cond ((get-environment-variable "CHICKEN_C_LIBRARY_PATH") =>
(lambda (path)
- (map (cut string-append "-L\"" <> "\"") (string-split path ":;"))))
+ (map (cut string-append "-L" <>) (string-split path ":;"))))
(else '()))))
(define target-filename #f)
@@ -580,8 +585,8 @@ EOF
(sprintf
"~A ~A ~A"
(if windows-shell "move" "mv")
- (quotewrap target-filename)
- (quotewrap (string-append target-filename ".old")))))
+ ((if windows-shell quotewrap-no-slash-trans quotewrap) target-filename)
+ ((if windows-shell quotewrap-no-slash-trans quotewrap) (string-append target-filename ".old")))))
(run-linking)) ) ]
[else
(let* ([arg (car args)]
@@ -998,8 +1003,8 @@ EOF
(if windows-shell
"copy /Y"
"cp")
- (quotewrap from)
- (quotewrap to))))
+ ((if windows-shell quotewrap-no-slash-trans quotewrap) from)
+ ((if windows-shell quotewrap-no-slash-trans quotewrap) to))))
(define (linker-options)
(string-append
diff --git a/tests/path-tests.scm b/tests/path-tests.scm
index 52eefc4b..68ac9024 100644
--- a/tests/path-tests.scm
+++ b/tests/path-tests.scm
@@ -69,7 +69,7 @@
(test '(#f "/" (".")) (receive (decompose-directory "/.//")))
(if ##sys#windows-platform
- (test '(#f "\\" #f) (receive (decompose-directory "///\\///")))
+ (test '(#f "/" #f) (receive (decompose-directory "///\\///")))
(test '(#f "/" ("\\")) (receive (decompose-directory "///\\///"))))
(test '(#f "/" ("foo")) (receive (decompose-directory "//foo//")))
@@ -183,22 +183,38 @@
(test '("a." ".b" #f) (receive (decompose-pathname "a.\\.b")))
(test '(#f "a.\\" "b") (receive (decompose-pathname "a.\\.b"))))
-(test "x/y/z.q" (make-pathname "x/y" "z" "q"))
-(test "x/y/z.q" (make-pathname "x/y" "z.q"))
-(test "x/y/z.q" (make-pathname "x/y/" "z.q"))
-(test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+(cond (##sys#windows-platform
+ (test "x/y\\z.q" (make-pathname "x/y" "z" "q"))
+ (test "x/y\\z.q" (make-pathname "x/y" "z.q"))
+ (test "x/y\\z.q" (make-pathname "x/y/" "z.q"))
+ (test "x/y\\z.q" (make-pathname "x/y/" "z.q"))
+ (test "x/y\\z.q" (make-pathname "x/y\\" "z.q"))
+ (test "x//y\\z.q" (make-pathname "x//y/" "z.q"))
+ (test "x\\y\\z.q" (make-pathname "x\\y" "z.q")))
+ (else
+ (test "x/y/z.q" (make-pathname "x/y" "z" "q"))
+ (test "x/y/z.q" (make-pathname "x/y" "z.q"))
+ (test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+ (test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+ (test "x/y\\/z.q" (make-pathname "x/y\\" "z.q"))
+ (test "x//y/z.q" (make-pathname "x//y/" "z.q"))
+ (test "x\\y/z.q" (make-pathname "x\\y" "z.q"))))
-(if ##sys#windows-platform
- (test "x/y/z.q" (make-pathname "x/y\\" "z.q"))
- (test "x/y\\/z.q" (make-pathname "x/y\\" "z.q")))
-
-(test "x//y/z.q" (make-pathname "x//y/" "z.q"))
-(test "x\\y/z.q" (make-pathname "x\\y" "z.q"))
(test 'error (handle-exceptions _ 'error (make-pathname '(#f) "foo")))
+
(test "/x/y/z" (make-pathname #f "/x/y/z"))
-(test "/x/y/z" (make-pathname "/" "x/y/z"))
-(test "/x/y/z" (make-pathname "/x" "/y/z"))
-(test "/x/y/z" (make-pathname '("/") "x/y/z"))
-(test "/x/y/z" (make-pathname '("/" "x") "y/z"))
-(test "/x/y/z" (make-pathname '("/x" "y") "z"))
-(test "/x/y/z/" (make-pathname '("/x" "y" "z") #f))
+
+(cond (##sys#windows-platform
+ (test "\\x/y/z" (make-pathname "/" "x/y/z"))
+ (test "/x\\y/z" (make-pathname "/x" "/y/z"))
+ (test "\\x/y/z" (make-pathname '("/") "x/y/z"))
+ (test "\\x\\y/z" (make-pathname '("/" "x") "y/z"))
+ (test "/x\\y\\z" (make-pathname '("/x" "y") "z"))
+ (test "/x\\y\\z\\" (make-pathname '("/x" "y" "z") #f)))
+ (else
+ (test "/x/y/z" (make-pathname "/" "x/y/z"))
+ (test "/x/y/z" (make-pathname "/x" "/y/z"))
+ (test "/x/y/z" (make-pathname '("/") "x/y/z"))
+ (test "/x/y/z" (make-pathname '("/" "x") "y/z"))
+ (test "/x/y/z" (make-pathname '("/x" "y") "z"))
+ (test "/x/y/z/" (make-pathname '("/x" "y" "z") #f))))
diff --git a/tests/test-find-files.scm b/tests/test-find-files.scm
index c3ef3e4d..62fe5a0a 100644
--- a/tests/test-find-files.scm
+++ b/tests/test-find-files.scm
@@ -24,14 +24,19 @@
(change-directory "find-files-test-dir")
(cond-expand
- ((and windows (not cygwin))) ; Cannot handle symlinks
- (else (create-symbolic-link "dir-link-target" "dir-link-name")))
+ ((and windows (not cygwin)) ; Cannot handle symlinks
+ (define (path lst)
+ (map (cut string-translate <> "/" "\\") lst)) )
+ (else
+ (create-symbolic-link "dir-link-target" "dir-link-name")
+ (define (path lst) lst)))
(test-begin "find-files")
(test-equal "no keyword args"
(find-files ".")
- `("./foo/bar/baz"
+ (path
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target/foo"
@@ -41,11 +46,12 @@
,@(cond-expand
((and windows (not cygwin)) '())
(else '("./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "dotfiles: #t"
(find-files "." dotfiles: #t)
+ (path
`("./foo/bar/baz/.quux"
"./foo/bar/baz"
"./foo/bar"
@@ -58,12 +64,13 @@
,@(cond-expand
((and windows (not cygwin)) '())
(else '("./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "follow-symlinks: #t"
(find-files "." follow-symlinks: #t)
- `("./foo/bar/baz"
+ (path
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target/foo"
@@ -75,12 +82,13 @@
(else '("./dir-link-name/foo"
"./dir-link-name/bar"
"./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "limit: 1"
(find-files "." limit: 1)
- `("./foo/bar"
+ (path
+ `("./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
@@ -89,11 +97,12 @@
,@(cond-expand
((and windows (not cygwin)) '())
(else '("./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "limit: 1 follow-symlinks: #t"
(find-files "." limit: 1 follow-symlinks: #t)
+ (path
`("./foo/bar"
"./foo"
"./dir-link-target/foo"
@@ -105,11 +114,12 @@
(else '("./dir-link-name/foo"
"./dir-link-name/bar"
"./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "limit: 2"
(find-files "." limit: 2)
+ (path
`("./foo/bar/baz"
"./foo/bar"
"./foo"
@@ -120,11 +130,12 @@
,@(cond-expand
((and windows (not cygwin)) '())
(else '("./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "limit: 2 follow-symlinks: #t"
(find-files "." limit: 2 follow-symlinks: #t)
+ (path
`("./foo/bar/baz"
"./foo/bar"
"./foo"
@@ -137,36 +148,39 @@
(else '("./dir-link-name/foo"
"./dir-link-name/bar"
"./dir-link-name")))
- "./file2")
+ "./file2"))
file-list=?)
(test-equal "test: (lambda (f) (directory? f))"
(find-files "." test: (lambda (f) (directory? f)))
- `("./foo/bar/baz"
+ (path
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target"
,@(cond-expand
((and windows (not cygwin)) '())
- (else '("./dir-link-name"))))
+ (else '("./dir-link-name")))))
file-list=?)
(test-equal "test: (lambda (f) (directory? f)) action: (lambda (f p) (cons (string-append \"--\" f) p))"
(find-files "."
test: (lambda (f) (directory? f))
action: (lambda (f p) (cons (string-append "--" f) p)))
- `("--./foo/bar/baz"
+ (path
+ `("--./foo/bar/baz"
"--./foo/bar"
"--./foo"
"--./dir-link-target"
,@(cond-expand
((and windows (not cygwin)) '())
- (else '("--./dir-link-name"))))
+ (else '("--./dir-link-name")))))
file-list=?)
(test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t"
(find-files "." dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t)
- `("./foo/bar/baz/.quux"
+ (path
+ `("./foo/bar/baz/.quux"
"./foo/bar/baz"
"./foo/bar"
"./foo/.x"
@@ -174,7 +188,7 @@
"./dir-link-target"
,@(cond-expand
((and windows (not cygwin)) '())
- (else '("./dir-link-name"))))
+ (else '("./dir-link-name")))))
file-list=?)
(test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t limit: 1"
@@ -183,13 +197,14 @@
test: (lambda (f) (directory? f))
follow-symlinks: #t
limit: 1)
- `("./foo/bar"
+ (path
+ `("./foo/bar"
"./foo/.x"
"./foo"
"./dir-link-target"
,@(cond-expand
((and windows (not cygwin)) '())
- (else '("./dir-link-name"))))
+ (else '("./dir-link-name")))))
file-list=?)
(test-end "find-files")
Trap