Implement command line quoting

command-line-test.scm

@@ -0,0 +1,56 @@
+(import (scheme base) (command-line) (srfi 64))
+
+(test-begin "command-line")
+
+(define (esc-char char)
+  (case char
+    ((#\B) #\\)
+    ((#\Q) #\")
+    (else char)))
+
+(define (esc s) (string-map esc-char s))
+
+(define examples
+  '(((args)
+     (posix "")
+     (windows ""))
+    ((args "foo")
+     (posix "foo")
+     (windows "foo"))
+    ((args "-+foo/bar@baz.qux")
+     (posix "-+foo/bar@baz.qux")
+     (windows "-+foo/bar@baz.qux"))
+    ((args "foo" "hello world" "bar")
+     (posix "foo Qhello worldQ bar")
+     (windows "foo Qhello worldQ bar"))
+    ((args "foo" "helloBworld" "bar")
+     (posix "foo QhelloBBworldQ bar")
+     (windows "foo QhelloBworldQ bar"))
+    ((args "argument1" "argument 2" "BsomeBpath withBspaces")
+     (posix "argument1 Qargument 2Q QBBsomeBBpath withBBspacesQ")
+     (windows "argument1 Qargument 2Q QBsomeBpath withBspacesQ"))
+    ((args "argument1" "she said, Qyou had me at helloQ" "BsomeBpath withBspaces")
+     (posix
+      "argument1 Qshe said, BQyou had me at helloBQQ QBBsomeBBpath withBBspacesQ")
+     (windows
+      "argument1 Qshe said, BQyou had me at helloBQQ QBsomeBpath withBspacesQ"))
+    ((args "argument1" "argumentQ2" "argument3" "argument4")
+     (posix "argument1 QargumentBQ2Q argument3 argument4")
+     (windows "argument1 QargumentBQ2Q argument3 argument4"))
+    ((args "foo" "helloBworld" "bar")
+     (posix "foo QhelloBBworldQ bar")
+     (windows "foo QhelloBworldQ bar"))
+    ((args "BsomeBdirectory withBspacesB")
+     (posix "QBBsomeBBdirectory withBBspacesBBQ")
+     (windows "QBsomeBdirectory withBspacesBBQ"))))
+
+(for-each
+ (lambda (example)
+   (let ((args (map esc (cdr (assoc 'args example))))
+         (posix (esc (cadr (assoc 'posix example))))
+         (windows (esc (cadr (assoc 'windows example)))))
+     (test-equal "posix" posix (join-posix-command-line args))
+     (test-equal "windows" windows (join-windows-command-line args))))
+ examples)
+
+(test-end)

command-line.scm

@@ -0,0 +1,73 @@
+(define (with-input-from-string string proc)
+  (call-with-port
+   (open-input-string string)
+   (lambda (port)
+     (parameterize ((current-input-port port))
+       (proc)))))
+
+(define (with-output-to-string proc)
+  (call-with-port
+   (open-output-string)
+   (lambda (port)
+     (parameterize ((current-output-port port))
+       (proc) (get-output-string port)))))
+
+(define (safe-without-quotes? arg)
+  (define (safe-char? char)
+    (case char
+      ((#\_ #\- #\+ #\/ #\@ #\.) #t)
+      (else (or (char<=? #\0 char #\9)
+                (char<=? #\A char #\Z)
+                (char<=? #\a char #\z)))))
+  (and (not (= 0 (string-length arg)))
+       (with-input-from-string arg
+         (lambda ()
+           (let loop ()
+             (let ((char (read-char)))
+               (or (eof-object? char) (and (safe-char? char) (loop)))))))))
+
+(define (join-command-line double-quote args)
+  (if (null? args) ""
+      (with-output-to-string
+        (lambda ()
+          (let loop ((args args))
+            (let ((arg (car args)))
+              (if (safe-without-quotes? arg)
+                  (write-string arg)
+                  (begin (write-char #\")
+                         (with-input-from-string arg double-quote)
+                         (write-char #\")))
+              (unless (null? (cdr args))
+                (write-char #\space)
+                (loop (cdr args)))))))))
+
+(define (double-quote-posix)
+  (let loop ()
+    (let ((char (read-char)))
+      (unless (eof-object? char)
+        (case char ((#\\ #\" #\` #\$ #\newline) (write-char #\\)))
+        (write-char char)
+        (loop)))))
+
+(define (double-quote-windows)
+  (define (write-backslashes n) (write-string (make-string n #\\)))
+  (let loop ((backslashes 0))
+    (let ((char (read-char)))
+      (cond ((eqv? #\\ char)
+             (loop (+ backslashes 1)))
+            ((eof-object? char)
+             (write-backslashes (* 2 backslashes)))
+            ((char=? #\" char)
+             (write-backslashes (+ 1 (* 2 backslashes)))
+             (write-char char)
+             (loop 0))
+            (else
+             (write-backslashes backslashes)
+             (write-char char)
+             (loop 0))))))
+
+(define (join-posix-command-line args)
+  (join-command-line double-quote-posix args))
+
+(define (join-windows-command-line args)
+  (join-command-line double-quote-windows args))

command-line.sld

@@ -0,0 +1,5 @@
+(define-library (command-line)
+  (export join-posix-command-line
+          join-windows-command-line)
+  (import (scheme base))
+  (include "command-line.scm"))