1.0.12.21: using default external format for RUN-PROGRAM args and env

* Patch by Harald Hanche-Olsen: use STRING-TO-OCTETS to build the
  vector of string pointers. Also allows non-simple strings.

diff --git a/NEWS b/NEWS
index 28cef49..f2699ca 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@ changes in sbcl-1.0.13 relative to sbcl-1.0.12:
     unparsing of directory pathnames as files. Analogously,
     SB-EXT:PARSE-NATIVE-NAMESTRING takes an AS-DIRECTORY, forcing a
     filename to parse into a directory pathname.
+  * enhancement: RUN-PROGRAM allows unicode arguments and environments
+    to be used (using the default stream external format), and allows
+    non-simple strings to be used. (thanks to Harald Hanche-Olsen)
   * optimizations: COPY-SEQ, FILL, and SUBSEQ are 30-80% faster for
     strings and vectors whose element-type or simplicity is not fully
     known at compile-time.

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 5c4f9fc..3c6cf2b 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -67,7 +67,7 @@
 (defun unix-environment-cmucl-from-sbcl (sbcl)
   (mapcan
    (lambda (string)
-     (declare (type simple-base-string string))
+     (declare (string string))
      (let ((=-pos (position #\= string :test #'equal)))
        (if =-pos
            (list
@@ -90,8 +90,8 @@
   (mapcar
    (lambda (cons)
      (destructuring-bind (key . val) cons
-       (declare (type keyword key) (type simple-base-string val))
-       (concatenate 'simple-base-string (symbol-name key) "=" val)))
+       (declare (type keyword key) (string val))
+       (concatenate 'simple-string (symbol-name key) "=" val)))
    cmucl))
 \f
 ;;;; Import wait3(2) from Unix.
@@ -462,53 +462,46 @@ status slot."
                               (1- ,bytes-per-word))) (1- ,bytes-per-word))))
 
 (defun string-list-to-c-strvec (string-list)
-  ;; Make a pass over STRING-LIST to calculate the amount of memory
-  ;; needed to hold the strvec.
-  (let ((string-bytes 0)
-        ;; We need an extra for the null, and an extra 'cause exect
-        ;; clobbers argv[-1].
-        (vec-bytes (* #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)
-                      (+ (length string-list) 2))))
-    (declare (fixnum string-bytes vec-bytes))
-    (dolist (s string-list)
-      (enforce-type s simple-string)
-      (incf string-bytes (round-bytes-to-words (1+ (length s)))))
-    ;; Now allocate the memory and fill it in.
-    (let* ((total-bytes (+ string-bytes vec-bytes))
-           (vec-sap (sb-sys:allocate-system-memory total-bytes))
-           (string-sap (sap+ vec-sap vec-bytes))
-           (i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)))
-      (declare (type (and unsigned-byte fixnum) total-bytes i)
-               (type sb-sys:system-area-pointer vec-sap string-sap))
-      (dolist (s string-list)
-        (declare (simple-string s))
-        (let ((n (length s)))
-          ;; Blast the string into place.
-          (sb-kernel:copy-ub8-to-system-area (the simple-base-string
-                                               ;; FIXME
-                                               (coerce s 'simple-base-string))
-                                             0
-                                             string-sap 0
-                                             (1+ n))
-          ;; Blast the pointer to the string into place.
-          (setf (sap-ref-sap vec-sap i) string-sap)
-          (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
-          (incf i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))))
-      ;; Blast in the last null pointer.
-      (setf (sap-ref-sap vec-sap i) (int-sap 0))
-      (values vec-sap (sap+ vec-sap #.(/ sb-vm:n-machine-word-bits
-                                         sb-vm:n-byte-bits))
-              total-bytes))))
+  (let* ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))
+         ;; We need an extra for the null, and an extra 'cause exect
+         ;; clobbers argv[-1].
+         (vec-bytes (* bytes-per-word (+ (length string-list) 2)))
+         (octet-vector-list (mapcar (lambda (s)
+                                      (string-to-octets s :null-terminate t))
+                                    string-list))
+         (string-bytes (reduce #'+ octet-vector-list
+                               :key (lambda (s)
+                                      (round-bytes-to-words (length s)))))
+         (total-bytes (+ string-bytes vec-bytes))
+         ;; Memory to hold the vector of pointers and all the strings.
+         (vec-sap (sb-sys:allocate-system-memory total-bytes))
+         (string-sap (sap+ vec-sap vec-bytes))
+         ;; Index starts from [1]!
+         (vec-index-offset bytes-per-word))
+    (declare (index string-bytes vec-bytes total-bytes)
+             (sb-sys:system-area-pointer vec-sap string-sap))
+    (dolist (octets octet-vector-list)
+      (declare (type (simple-array (unsigned-byte 8) (*)) octets))
+      (let ((size (length octets)))
+        ;; Copy string.
+        (sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size)
+        ;; Put the pointer in the vector.
+        (setf (sap-ref-sap vec-sap vec-index-offset) string-sap)
+        ;; Advance string-sap for the next string.
+        (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ size))))
+        (incf vec-index-offset bytes-per-word)))
+    ;; Final null pointer.
+    (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0))
+    (values vec-sap (sap+ vec-sap bytes-per-word) total-bytes)))
 
 (defmacro with-c-strvec ((var str-list) &body body)
   (with-unique-names (sap size)
-    `(multiple-value-bind
-      (,sap ,var ,size)
-      (string-list-to-c-strvec ,str-list)
-      (unwind-protect
-           (progn
-             ,@body)
-        (sb-sys:deallocate-system-memory ,sap ,size)))))
+    `(multiple-value-bind (,sap ,var ,size)
+         (string-list-to-c-strvec ,str-list)
+       (unwind-protect
+            (progn
+              ,@body)
+         (sb-sys:deallocate-system-memory ,sap ,size)))))
 
 #-win32
 (sb-alien:define-alien-routine spawn sb-alien:int
@@ -625,6 +618,9 @@ standard arguments that can be passed to a Unix program. For no
 arguments, use NIL (which means that just the name of the program is
 passed as arg 0).
 
+The program arguments and the environment are encoded using the
+default external format for streams.
+
 RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp
 Users Manual for details about the PROCESS structure.
 
@@ -644,7 +640,7 @@ Users Manual for details about the PROCESS structure.
    The &KEY arguments have the following meanings:
 
    :ENVIRONMENT
-      a list of SIMPLE-BASE-STRINGs describing the new Unix environment
+      a list of STRINGs describing the new Unix environment
       (as in \"man environ\"). The default is to copy the environment of
       the current process.
    :ENV
@@ -786,6 +782,9 @@ argument. ARGS are the standard arguments that can be passed to a
 program. For no arguments, use NIL (which means that just the name of
 the program is passed as arg 0).
 
+The program arguments will be encoded using the default external
+format for streams.
+
 RUN-PROGRAM will return a PROCESS structure. See the CMU
 Common Lisp Users Manual for details about the PROCESS structure.
 

diff --git a/tests/run-program.test.sh b/tests/run-program.test.sh
index b95931a..50e12f3 100644 (file)
--- a/tests/run-program.test.sh
+++ b/tests/run-program.test.sh
@@ -20,7 +20,7 @@ export SOMETHING_IN_THE_ENVIRONMENT
 PATH=/some/path/that/does/not/exist:${PATH}
 export PATH
 
-${SBCL:-sbcl} <<EOF
+${SBCL:-sbcl} <<'EOF'
   ;; test that $PATH is searched
   (assert (zerop (sb-ext:process-exit-code
                   (sb-ext:run-program "true" () :search t :wait t))))
@@ -38,8 +38,26 @@ ${SBCL:-sbcl} <<EOF
                   (sb-ext:run-program "/usr/bin/env" ()
                                       :output stream
                                       :environment '("FEEFIE=foefum")))))
-    (assert (string= string "FEEFIE=foefum
+    (assert (equal string "FEEFIE=foefum
 ")))
+
+ ;; Unicode strings
+ (flet ((try (sb-impl::*default-external-format* x y)
+         (let* ((process (run-program
+                          "/bin/sh" (list "-c" (format nil "echo ~c, $SB_TEST_FOO." x))
+                          :environment (list (format nil "SB_TEST_FOO=~c" y))
+                          :output :stream
+                          :wait t))
+                (output (read-line (process-output process)))
+                (wanted (format nil "~c, ~c." x y)))
+           (unless (equal output wanted)
+             (error "wanted ~S, got ~S" wanted output))
+           (process-close process))))
+   (try :ascii #\s #\b)
+   (try :latin-1 (code-char 197) (code-char 229))
+   #+sb-unicode
+   (try :utf-8 #\GREEK_CAPITAL_LETTER_OMEGA #\GREEK_SMALL_LETTER_OMEGA))
+
   ;; The default Unix environment for the subprocess is the same as
   ;; for the parent process. (I.e., we behave like perl and lots of
   ;; other programs, but not like CMU CL.)

diff --git a/version.lisp-expr b/version.lisp-expr
index 6373f70..36c906d 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.12.20"
+"1.0.12.21"