~ chicken-core (chicken-5) dc07113cf79a1930c6a109c738138dbea15afbc0
commit dc07113cf79a1930c6a109c738138dbea15afbc0
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Sep 1 18:33:59 2018 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Sep 6 12:17:40 2018 +0200
Fix quotation in scripts generated by chicken-install and csc (#1515)
Instead of rolling our own quotation (which never works), we use the
tried and true "qs" procedure from (chicken process). Unfortunately,
this procedure expects 'mingw32 as input, so we have to map platform
back to its original value again...
While testing this patch on UNIX with a path that contained spaces, I
also encountered a problem in the linking command which csc generates:
It was also misquoting its arguments.
While we're at it, we also remove the unused write-info procedure. We
also ensure all "system" invocations have their quotes fixed on
Windows.
Many thanks to Kristian Lein-Mathisen for finding this bug.
Signed-off-by: felix <felix@call-with-current-continuation.org>
Added fix for double-quoting in "prepare-custom-command"
diff --git a/chicken-install.scm b/chicken-install.scm
index c01a1556..17f1acec 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -498,14 +498,13 @@
(define (copy-egg-sources from to)
;;XXX should probably be done manually, instead of calling tool
- (let ((cmd (quote-all
- (string-append
- (copy-directory-command platform)
- " " (quotearg (slashify (make-pathname from "*") platform))
- " " (quotearg (slashify to platform)))
- platform)))
+ (let ((cmd (string-append
+ (copy-directory-command platform)
+ ;; Don't quote the globbing character!
+ " " (make-pathname (qs* from platform #t) "*")
+ " " (qs* to platform #t))))
(d "~a~%" cmd)
- (system cmd)))
+ (system+ cmd platform)))
(define (check-remote-version name lversion cached)
(let loop ((locs default-locations))
@@ -882,10 +881,13 @@
(if (and (directory-exists? testdir)
(file-exists? tscript))
(let ((old (current-directory))
- (cmd (string-append default-csi " -s " tscript " " name " " (or version ""))))
+ (cmd (string-append (qs* default-csi platform)
+ " -s " (qs* tscript platform)
+ " " (qs* name platform)
+ " " (or version ""))))
(change-directory testdir)
(d "running: ~a~%" cmd)
- (let ((r (system cmd)))
+ (let ((r (system+ cmd platform)))
(flush-output (current-error-port))
(cond ((zero? r)
(change-directory old)
@@ -907,21 +909,15 @@
(get-environment-variable "DYLD_LIBRARY_PATH"))))
(if dyld
(string-append "/usr/bin/env DYLD_LIBRARY_PATH="
- (qs dyld)
+ (qs* dyld platform)
" ")
""))
"sh " script))
stop))
-(define (write-info name info mode)
- (d "writing info for egg ~a~%" name info)
- (let ((infofile (make-pathname name (destination-repository mode))))
- (when (eq? platform 'unix)
- (exec (string-append "chmod a+r " (quotearg infofile))))))
-
(define (exec cmd #!optional (stop #t))
(d "executing: ~s~%" cmd)
- (let ((r (system cmd)))
+ (let ((r (system+ cmd platform)))
(unless (zero? r)
(if stop
(error "shell command terminated with nonzero exit code" r cmd)
diff --git a/csc.scm b/csc.scm
index 75074ee8..454a6373 100644
--- a/csc.scm
+++ b/csc.scm
@@ -258,12 +258,12 @@
(cond (elf
(list
(conc "-L" library-dir)
- (conc " -Wl,-R"
+ (conc "-Wl,-R"
(if deployed
- "\\$ORIGIN"
- (quotewrap (if host-mode
- host-libdir
- TARGET_RUN_LIB_HOME))))))
+ "$ORIGIN"
+ (if host-mode
+ host-libdir
+ TARGET_RUN_LIB_HOME)))))
(aix
(list (conc "-Wl,-R\"" library-dir "\"")))
(else
@@ -1005,7 +1005,8 @@ EOF
(define (linker-options)
(string-intersperse
- (append linking-optimization-options link-options)))
+ (map quote-option
+ (append linking-optimization-options link-options) ) ) )
(define (linker-libraries)
(string-intersperse
diff --git a/egg-compile.scm b/egg-compile.scm
index 0efa98d2..714930b8 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -469,8 +469,9 @@
predefined-types eggfile
custom types-file inline-file)
srcdir platform)
- (let* ((cmd (or (custom-cmd custom srcdir platform)
- default-csc))
+ (let* ((cmd (qs* (or (custom-cmd custom srcdir platform)
+ default-csc)
+ platform))
(sname (prefix srcdir name))
(ssname (and source (prefix srcdir source)))
(opts (append (if (null? options)
@@ -479,32 +480,35 @@
(if (and types-file
(not predefined-types))
(list "-emit-types-file"
- (quotearg (prefix srcdir (conc types-file ".types"))))
+ (qs* (prefix srcdir (conc types-file ".types"))
+ platform))
'())
(if inline-file
(list "-emit-inline-file"
- (quotearg (prefix srcdir (conc inline-file ".inline"))))
+ (qs* (prefix srcdir (conc inline-file ".inline"))
+ platform))
'())))
- (out (quotearg (target-file (conc sname
- ".static"
- (object-extension platform))
- mode)))
- (src (quotearg (or ssname (conc sname ".scm")))))
+ (out (qs* (target-file (conc sname
+ ".static"
+ (object-extension platform))
+ mode)
+ platform))
+ (src (qs* (or ssname (conc sname ".scm")) platform)))
(when custom
(prepare-custom-command cmd platform))
- (print "\n" (slashify default-builder platform) " " out " " cmd
+ (print "\n" (qs* default-builder platform #t) " " out " " cmd
(if keep-generated-files " -k" "")
" -setup-mode -static -I " srcdir
" -emit-link-file "
- (quotearg (conc sname +link-file-extension+))
+ (qs* (conc sname +link-file-extension+) platform)
(if (eq? mode 'host) " -host" "")
" -D compiling-extension -c -unit " name
" -D compiling-static-extension"
- " -C -I" srcdir (arglist opts)
+ " -C -I" srcdir (arglist opts platform)
" " src " -o " out " : "
- src " " (quotearg eggfile) " "
- (if custom (quotearg cmd) "") " "
- (filelist srcdir source-dependencies))
+ src " " (qs* eggfile platform) " "
+ (if custom (qs* cmd platform) "") " "
+ (filelist srcdir source-dependencies platform))
(print-end-command platform)))
(define ((compile-dynamic-extension name #!key mode mode
@@ -513,8 +517,9 @@
source-dependencies
custom types-file inline-file)
srcdir platform)
- (let* ((cmd (or (custom-cmd custom srcdir platform)
- default-csc))
+ (let* ((cmd (qs* (or (custom-cmd custom srcdir platform)
+ default-csc)
+ platform))
(sname (prefix srcdir name))
(opts (append (if (null? options)
default-dynamic-compilation-options
@@ -522,46 +527,49 @@
(if (and types-file
(not predefined-types))
(list "-emit-types-file"
- (quotearg (prefix srcdir (conc types-file ".types"))))
+ (qs* (prefix srcdir (conc types-file ".types"))
+ platform))
'())
(if inline-file
(list "-emit-inline-file"
- (quotearg (prefix srcdir (conc inline-file ".inline"))))
+ (qs* (prefix srcdir (conc inline-file ".inline"))
+ platform))
'())))
(ssname (and source (prefix srcdir source)))
- (out (quotearg (target-file (conc sname ".so") mode)))
- (src (quotearg (or ssname (conc sname ".scm")))))
+ (out (qs* (target-file (conc sname ".so") mode) platform))
+ (src (qs* (or ssname (conc sname ".scm")) platform)))
(when custom
(prepare-custom-command cmd platform))
- (print "\n" (slashify default-builder platform) " " out " " cmd
+ (print "\n" (qs* default-builder platform #t) " " out " " cmd
(if keep-generated-files " -k" "")
(if (eq? mode 'host) " -host" "")
" -D compiling-extension -J -s"
- " -setup-mode -I " srcdir " -C -I" srcdir (arglist opts)
- (arglist link-options) " " src " -o " out " : "
- src " " (quotearg eggfile) " "
- (if custom (quotearg cmd) "") " "
- (filelist srcdir source-dependencies))
+ " -setup-mode -I " srcdir " -C -I" srcdir
+ (arglist opts platform) (arglist link-options platform)
+ " " src " -o " out " : " src " " (qs* eggfile platform) " "
+ (if custom (qs* cmd platform) "") " "
+ (filelist srcdir source-dependencies platform))
(print-end-command platform)))
(define ((compile-import-library name #!key mode
source-dependencies
(options '()) (link-options '()))
srcdir platform)
- (let* ((cmd default-csc)
+ (let* ((cmd (qs* default-csc platform))
(sname (prefix srcdir name))
(opts (if (null? options)
default-import-library-compilation-options
options))
- (out (quotearg (target-file (conc sname ".import.so") mode)))
- (src (quotearg (conc sname ".import.scm"))))
- (print "\n" (slashify default-builder platform) " " out " " cmd
+ (out (qs* (target-file (conc sname ".import.so") mode)
+ platform))
+ (src (qs* (conc sname ".import.scm") platform)))
+ (print "\n" (qs* default-builder platform #t) " " out " " cmd
(if keep-generated-files " -k" "")
" -setup-mode -s"
(if (eq? mode 'host) " -host" "")
- " -I " srcdir " -C -I" srcdir (arglist opts)
- (arglist link-options) " " src " -o " out " : "
- src (filelist srcdir source-dependencies))
+ " -I " srcdir " -C -I" srcdir (arglist opts platform)
+ (arglist link-options platform) " " src " -o " out " : "
+ src (filelist srcdir source-dependencies platform))
(print-end-command platform)))
(define ((compile-dynamic-program name #!key source mode
@@ -569,28 +577,30 @@
source-dependencies
custom eggfile)
srcdir platform)
- (let* ((cmd (or (custom-cmd custom srcdir platform)
- default-csc))
+ (let* ((cmd (qs* (or (custom-cmd custom srcdir platform)
+ default-csc)
+ platform))
(sname (prefix srcdir name))
(ssname (and source (prefix srcdir source)))
(opts (if (null? options)
default-dynamic-compilation-options
options))
- (out (quotearg (target-file (conc sname
- (executable-extension platform))
- mode)))
- (src (quotearg (or ssname (conc sname ".scm")))))
+ (out (qs* (target-file (conc sname
+ (executable-extension platform))
+ mode)
+ platform))
+ (src (qs* (or ssname (conc sname ".scm")) platform)))
(when custom
(prepare-custom-command cmd platform))
- (print "\n" (slashify default-builder platform) " " out " " cmd
+ (print "\n" (qs* default-builder platform #t) " " out " " cmd
(if keep-generated-files " -k" "")
" -setup-mode"
(if (eq? mode 'host) " -host" "")
- " -I " srcdir " -C -I" srcdir (arglist opts)
- (arglist link-options) " " src " -o " out " : "
- src " " (quotearg eggfile) " "
- (if custom (quotearg cmd) "") " "
- (filelist srcdir source-dependencies))
+ " -I " srcdir " -C -I" srcdir (arglist opts platform)
+ (arglist link-options platform) " " src " -o " out " : "
+ src " " (qs* eggfile platform) " "
+ (if custom (qs* cmd platform) "") " "
+ (filelist srcdir source-dependencies platform))
(print-end-command platform)))
(define ((compile-static-program name #!key source
@@ -598,28 +608,30 @@
source-dependencies
custom mode eggfile)
srcdir platform)
- (let* ((cmd (or (custom-cmd custom srcdir platform)
- default-csc))
+ (let* ((cmd (qs* (or (custom-cmd custom srcdir platform)
+ default-csc)
+ platform))
(sname (prefix srcdir name))
(ssname (and source (prefix srcdir source)))
(opts (if (null? options)
default-static-compilation-options
options))
- (out (quotearg (target-file (conc sname
- (executable-extension platform))
- mode)))
- (src (quotearg (or ssname (conc sname ".scm")))))
+ (out (qs* (target-file (conc sname
+ (executable-extension platform))
+ mode)
+ platform))
+ (src (qs* (or ssname (conc sname ".scm")) platform)))
(when custom
(prepare-custom-command cmd platform))
- (print "\n" (slashify default-builder platform) " " out " " cmd
+ (print "\n" (qs* default-builder platform #t) " " out " " cmd
(if keep-generated-files " -k" "")
(if (eq? mode 'host) " -host" "")
" -static -setup-mode -I " srcdir " -C -I"
- srcdir (arglist opts)
- (arglist link-options) " " src " -o " out " : "
- src " " (quotearg eggfile) " "
- (if custom (quotearg cmd) "") " "
- (filelist srcdir source-dependencies))
+ srcdir (arglist opts platform)
+ (arglist link-options platform) " " src " -o " out " : "
+ src " " (qs* eggfile platform) " "
+ (if custom (qs* cmd platform) "") " "
+ (filelist srcdir source-dependencies platform))
(print-end-command platform)))
(define ((compile-generated-file name #!key source custom
@@ -628,13 +640,13 @@
(let* ((cmd (custom-cmd custom srcdir platform))
(sname (prefix srcdir name))
(ssname (and source (prefix srcdir source)))
- (out (quotearg (or ssname sname))))
+ (out (qs* (or ssname sname) platform)))
(prepare-custom-command cmd platform)
- (print "\n" (slashify default-builder platform)
+ (print "\n" (qs* default-builder platform #t)
" " out " " cmd " : "
- (quotearg cmd) " "
- (quotearg eggfile) " "
- (filelist srcdir source-dependencies))
+ (qs* cmd platform) " "
+ (qs* eggfile platform) " "
+ (filelist srcdir source-dependencies platform))
(print-end-command platform)))
@@ -646,25 +658,18 @@
(mkdir (mkdir-command platform))
(ext (object-extension platform))
(sname (prefix srcdir name))
- (out (quotearg (slashify (target-file (conc sname ".static" ext)
- mode) platform)))
- (outlnk (quotearg (slashify (conc sname +link-file-extension+)
- platform)))
+ (out (qs* (target-file (conc sname ".static" ext) mode)
+ platform #t))
+ (outlnk (qs* (conc sname +link-file-extension+) platform #t))
(dest (destination-repository mode))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/"
- output-file
- ext)
- platform)))
+ (qs* (conc dest "/" output-file ext) platform #t))
(print cmd " " outlnk " " ddir
- (quotearg (slashify (conc dest "/"
- output-file
- +link-file-extension+)
- platform)))
+ (qs* (conc dest "/" output-file +link-file-extension+)
+ platform #t))
(print-end-command platform)))
(define ((install-dynamic-extension name #!key mode (ext ".so")
@@ -674,14 +679,11 @@
(dcmd (remove-file-command platform))
(mkdir (mkdir-command platform))
(sname (prefix srcdir name))
- (out (quotearg (slashify (target-file (conc sname ext) mode)
- platform)))
+ (out (qs* (target-file (conc sname ext) mode) platform #t))
(dest (destination-repository mode))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform)))
- (destf (quotearg (slashify (conc dest "/" output-file ext)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform))
+ (destf (qs* (conc dest "/" output-file ext) platform #t)))
(print "\n" mkdir " " ddir dfile)
(when (eq? platform 'unix)
(print dcmd " " ddir destf))
@@ -699,51 +701,42 @@
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
(sname (prefix srcdir name))
- (out (quotearg (slashify (target-file (conc sname ".import.scm")
- mode)
- platform)))
+ (out (qs* (target-file (conc sname ".import.scm") mode)
+ platform #t))
(dest (destination-repository mode))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/" name ".import.scm")
- platform)))
+ (qs* (conc dest "/" name ".import.scm") platform #t))
(print-end-command platform)))
(define ((install-types-file name #!key mode types-file)
srcdir platform)
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
- (out (quotearg (slashify (prefix srcdir
- (conc types-file ".types"))
- platform)))
+ (out (qs* (prefix srcdir (conc types-file ".types"))
+ platform #t))
(dest (destination-repository mode))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/" types-file ".types")
- platform)))
+ (qs* (conc dest "/" types-file ".types") platform #t))
(print-end-command platform)))
(define ((install-inline-file name #!key mode inline-file)
srcdir platform)
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
- (out (quotearg (slashify (prefix srcdir
- (conc inline-file ".inline"))
- platform)))
+ (out (qs* (prefix srcdir (conc inline-file ".inline"))
+ platform #t))
(dest (destination-repository mode))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/" inline-file ".inline")
- platform)))
+ (qs* (conc dest "/" inline-file ".inline") platform #t))
(print-end-command platform)))
(define ((install-program name #!key mode output-file) srcdir platform)
@@ -752,16 +745,13 @@
(mkdir (mkdir-command platform))
(ext (executable-extension platform))
(sname (prefix srcdir name))
- (out (quotearg (slashify (target-file (conc sname ext) mode)
- platform)))
+ (out (qs* (target-file (conc sname ext) mode) platform #t))
(dest (if (eq? mode 'target)
default-bindir
(override-prefix "/bin" host-bindir)))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform)))
- (destf (quotearg (slashify (conc dest "/" output-file ext)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform))
+ (destf (qs* (conc dest "/" output-file ext) platform #t)))
(print "\n" mkdir " " ddir dfile)
(when (eq? platform 'unix)
(print dcmd " " ddir destf))
@@ -774,9 +764,8 @@
(root (string-append srcdir "/"))
(mkdir (mkdir-command platform))
(sfiles (map (cut prefix srcdir <>) files))
- (dfile (quotearg (slashify dest platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform))))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
(let-values (((ds fs) (partition directory? sfiles)))
(for-each
@@ -785,13 +774,11 @@
(fdir (pathname-directory ds)))
(when fdir
(print mkdir " " ddir
- (slashify (make-pathname dfile fdir)
- platform)))
- (print dcmd " " (quotearg (slashify d platform))
+ (qs* (make-pathname dfile fdir) platform #t)))
+ (print dcmd " " (qs* d platform #t)
" " ddir
(if fdir
- (slashify (make-pathname dfile fdir)
- platform)
+ (qs* (make-pathname dfile fdir) platform #t)
dfile))
(print-end-command platform)))
ds)
@@ -802,13 +789,11 @@
(fdir (pathname-directory fs)))
(when fdir
(print mkdir " " ddir
- (slashify (make-pathname dfile fdir)
- platform)))
- (print fcmd " " (quotearg (slashify f platform))
+ (qs* (make-pathname dfile fdir) platform #t)))
+ (print fcmd " " (qs* f platform)
" " ddir
(if fdir
- (slashify (make-pathname dfile fdir)
- platform)
+ (qs* (make-pathname dfile fdir) platform #t)
dfile)))
(print-end-command platform))
fs)))))
@@ -839,8 +824,7 @@
(with-output-to-file dest
(lambda ()
(prefix platform)
- (print (cd-command platform)
- " " (quotearg (slashify srcdir platform)))
+ (print (cd-command platform) " " (qs* srcdir platform #t))
(for-each
(lambda (cmd) (cmd srcdir platform))
cmds)
@@ -855,15 +839,16 @@
(printf #<<EOF
#!/bin/sh~%
set -e
-PATH="~a":$PATH
-export CHICKEN_CC="~a"
-export CHICKEN_CXX="~a"
-export CHICKEN_CSC="~a"
-export CHICKEN_CSI="~a"
+PATH=~a:$PATH
+export CHICKEN_CC=~a
+export CHICKEN_CXX=~a
+export CHICKEN_CSC=~a
+export CHICKEN_CSI=~a
EOF
- default-bindir default-cc default-cxx default-csc
- default-csi))
+ (qs* default-bindir platform) (qs* default-cc platform)
+ (qs* default-cxx platform) (qs* default-csc platform)
+ (qs* default-csi platform)))
((windows)
(printf #<<EOF
@echo off~%
@@ -874,8 +859,9 @@ set CHICKEN_CSC=~a
set CHICKEN_CSI=~a
EOF
- default-bindir default-cc default-cxx default-csc
- default-csi))))
+ (qs* default-bindir platform) (qs* default-cc platform)
+ (qs* default-cxx platform) (qs* default-csc platform)
+ (qs* default-csi platform)))))
(define ((build-suffix mode name info) platform)
(case platform
@@ -908,11 +894,10 @@ EOF
(dcmd (remove-file-command platform))
(mkdir (mkdir-command platform))
(dir (destination-repository mode))
- (qdir (quotearg (slashify dir platform)))
- (dest (quotearg (slashify (make-pathname dir name +egg-info-extension+)
- platform)))
- (ddir (quotearg (slashify (shell-variable "DESTDIR" platform)
- platform))))
+ (qdir (qs* dir platform #t))
+ (dest (qs* (make-pathname dir name +egg-info-extension+)
+ platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
(case platform
((unix)
(printf #<<EOF
@@ -935,18 +920,16 @@ EOF
(string-intersperse (string-split infostr "\n") "^\n\n")
ddir dest)))))
-
;;; some utilities for mangling + quoting
-(define (prefix dir name)
- (make-pathname dir (->string name)))
-
-(define (quotearg str)
- (let* ((str (->string str))
- (lst (string->list str)))
- (if (any char-whitespace? lst)
- (string-append "\"" str "\"")
- str)))
+;; The qs procedure quotes for mingw32 or other platforms. We
+;; "normalised" the platform to "windows" in chicken-install, so we
+;; have to undo that here again. It can also convert slashes to
+;; backslashes on Windows, which is necessary in many cases when
+;; running programs via "cmd".
+(define (qs* arg platform #!optional slashify?)
+ (let ((path (if slashify? (slashify arg platform) arg)))
+ (qs path (if (eq? platform 'windows) 'mingw32 platform))))
(define (slashify str platform)
(if (eq? platform 'windows)
@@ -954,21 +937,28 @@ EOF
(map (lambda (c) (if (char=? #\/ c) #\\ c)) (string->list str)))
str))
-(define (quote-all str platform)
- (if (and (eq? platform 'windows)
- (positive? (string-length str))
- (char=? #\" (string-ref str 0)))
- (string-append "\"" str "\"")
- str))
+(define (prefix dir name)
+ (make-pathname dir (->string name)))
+
+;; Workaround for obscure behaviour of "system" on Windows: If a
+;; string starts with double quotes, you _must_ wrap the whole string
+;; in an extra set of quotes to avoid the outer quotes being stripped.
+;; Don't ask.
+(define (system+ str platform)
+ (system (if (and (eq? platform 'windows)
+ (positive? (string-length str))
+ (char=? #\" (string-ref str 0)))
+ (string-append "\"" str "\"")
+ str)))
(define (target-file fname mode)
(if (eq? mode 'target) (string-append fname ".target") fname))
-(define (arglist lst)
- (apply conc (map (lambda (x) (conc " " (quotearg x))) lst)))
+(define (arglist lst platform)
+ (apply conc (map (lambda (x) (conc " " (qs* x platform))) lst)))
-(define (filelist dir lst)
- (arglist (map (cut prefix dir <>) lst)))
+(define (filelist dir lst platform)
+ (arglist (map (cut prefix dir <>) lst) platform))
(define (shell-variable var platform)
(case platform
@@ -977,7 +967,7 @@ EOF
(define (prepare-custom-command cmd platform)
(unless (eq? 'windows platform)
- (print "chmod +x " (quotearg cmd))))
+ (print "chmod +x " cmd)))
(define (custom-cmd custom srcdir platform)
(and custom (prefix srcdir
Trap