From 2a2895e4840770d4a8364f068bd139620e4385b8 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 1 Sep 2018 18:33:59 +0200 Subject: [PATCH 1/2] 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. --- chicken-install.scm | 30 +++-- csc.scm | 13 ++- egg-compile.scm | 317 ++++++++++++++++++++++++---------------------------- 3 files changed, 168 insertions(+), 192 deletions(-) diff --git a/chicken-install.scm b/chicken-install.scm index 5d66a77c..e5b28e02 100644 --- a/chicken-install.scm +++ b/chicken-install.scm @@ -497,14 +497,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) "*") + " " (qs* to platform)))) (d "~a~%" cmd) - (system cmd))) + (system+ cmd platform))) (define (check-remote-version name lversion cached) (let loop ((locs default-locations)) @@ -881,10 +880,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) @@ -906,21 +908,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..f722b887 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) " " 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) " " 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) " " 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) " " 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) " " 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) " " 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)) + (outlnk (qs* (conc sname +link-file-extension+) platform)) (dest (destination-repository mode)) - (dfile (quotearg (slashify dest platform))) - (ddir (quotearg (slashify (shell-variable "DESTDIR" platform) - platform)))) + (dfile (qs* dest platform)) + (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)) (print cmd " " outlnk " " ddir - (quotearg (slashify (conc dest "/" - output-file - +link-file-extension+) - platform))) + (qs* (conc dest "/" output-file +link-file-extension+) + platform)) (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)) (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)) + (ddir (shell-variable "DESTDIR" platform)) + (destf (qs* (conc dest "/" output-file ext) platform))) (print "\n" mkdir " " ddir dfile) (when (eq? platform 'unix) (print dcmd " " ddir destf)) @@ -699,51 +701,40 @@ (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)) (dest (destination-repository mode)) - (dfile (quotearg (slashify dest platform))) - (ddir (quotearg (slashify (shell-variable "DESTDIR" platform) - platform)))) + (dfile (qs* dest platform)) + (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)) (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)) (dest (destination-repository mode)) - (dfile (quotearg (slashify dest platform))) - (ddir (quotearg (slashify (shell-variable "DESTDIR" platform) - platform)))) + (dfile (qs* dest platform)) + (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)) (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)) (dest (destination-repository mode)) - (dfile (quotearg (slashify dest platform))) - (ddir (quotearg (slashify (shell-variable "DESTDIR" platform) - platform)))) + (dfile (qs* dest platform)) + (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)) (print-end-command platform))) (define ((install-program name #!key mode output-file) srcdir platform) @@ -752,16 +743,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)) (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)) + (ddir (shell-variable "DESTDIR" platform)) + (destf (qs* (conc dest "/" output-file ext) platform))) (print "\n" mkdir " " ddir dfile) (when (eq? platform 'unix) (print dcmd " " ddir destf)) @@ -774,9 +762,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)) + (ddir (shell-variable "DESTDIR" platform))) (print "\n" mkdir " " ddir dfile) (let-values (((ds fs) (partition directory? sfiles))) (for-each @@ -785,13 +772,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))) + (print dcmd " " (qs* d platform) " " ddir (if fdir - (slashify (make-pathname dfile fdir) - platform) + (qs* (make-pathname dfile fdir) platform) dfile)) (print-end-command platform))) ds) @@ -802,13 +787,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))) + (print fcmd " " (qs* f platform) " " ddir (if fdir - (slashify (make-pathname dfile fdir) - platform) + (qs* (make-pathname dfile fdir) platform) dfile))) (print-end-command platform)) fs))))) @@ -839,8 +822,7 @@ (with-output-to-file dest (lambda () (prefix platform) - (print (cd-command platform) - " " (quotearg (slashify srcdir platform))) + (print (cd-command platform) " " (qs* srcdir platform)) (for-each (lambda (cmd) (cmd srcdir platform)) cmds) @@ -855,15 +837,16 @@ (printf #<string name))) -(define (quotearg str) - (let* ((str (->string str)) - (lst (string->list str))) - (if (any char-whitespace? lst) - (string-append "\"" str "\"") - str))) - -(define (slashify str platform) - (if (eq? platform 'windows) - (list->string - (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)) +;; 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 +956,7 @@ EOF (define (prepare-custom-command cmd platform) (unless (eq? 'windows platform) - (print "chmod +x " (quotearg cmd)))) + (print "chmod +x " (qs* cmd platform)))) (define (custom-cmd custom srcdir platform) (and custom (prefix srcdir -- 2.11.0