Index: /branches/working-0711/ccl/level-1/linux-files.lisp =================================================================== --- /branches/working-0711/ccl/level-1/linux-files.lisp (revision 13140) +++ /branches/working-0711/ccl/level-1/linux-files.lisp (revision 13141) @@ -1026,4 +1026,5 @@ watched-fds watched-streams + external-format ) @@ -1042,4 +1043,5 @@ &key direction (element-type 'character) (sharing :private) + external-format &allow-other-keys) (etypecase object @@ -1066,4 +1068,6 @@ :sharing sharing :basic t + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) :auto-close t) (cons read-pipe close-in-parent) @@ -1077,4 +1081,6 @@ :basic t :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) :auto-close t) (cons write-pipe close-in-parent) @@ -1091,4 +1097,6 @@ (cons fd close-in-parent) (cons fd close-on-error))))) + #|| + ;; What's an FD-STREAM ? (fd-stream (let ((fd (fd-dup (ioblock-device (stream-ioblock object t))))) @@ -1097,4 +1105,5 @@ (cons fd close-in-parent) (cons fd close-on-error)))) + ||# (stream (ecase direction @@ -1105,17 +1114,17 @@ (%errno-disp fd)) (#_unlink template) - (loop - (multiple-value-bind (line no-newline) - (read-line object nil nil) - (unless line - (return)) - (let* ((len (length line))) - (%stack-block ((buf (1+ len))) - (%cstr-pointer line buf) - (fd-write fd buf len) - (if no-newline - (return)) - (setf (%get-byte buf) (char-code #\newline)) - (fd-write fd buf 1))))) + (let* ((out (make-fd-stream (fd-dup fd) + :direction :output + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format)))) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (if no-newline + (write-string line out) + (write-line line out)))) + (close out)) (fd-lseek fd 0 #$SEEK_SET) (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))) @@ -1167,5 +1176,16 @@ (changed) (maxfd 0) - (pairs (pairlis in-fds out-streams))) + (external-format (external-process-external-format p)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format)) + (pairs (pairlis + (mapcar (lambda (fd) + (cons fd + (make-fd-stream fd + :direction :input + :sharing :private + :encoding encoding + :line-termination line-termination))) + in-fds) out-streams))) (%stack-block ((in-fd-set *fd-set-size*)) (rlet ((tv #>timeval)) @@ -1181,5 +1201,5 @@ (setq maxfd 0) (dolist (p pairs) - (let* ((fd (car p))) + (let* ((fd (caar p))) (when (> fd maxfd) (setq maxfd fd)) @@ -1190,19 +1210,17 @@ 0) (dolist (p pairs) - (let* ((in-fd (car p)) + (let* ((in-fd (caar p)) + (in-stream (cdar p)) (out-stream (cdr p))) (when (fd-is-set in-fd in-fd-set) - (%stack-block ((buf 1024)) - (let* ((n (fd-read in-fd buf 1024))) - (declare (fixnum n)) - (if (<= n 0) - (without-interrupts - (decf (car token)) - (fd-close in-fd) - (setf (car p) nil changed t)) - (let* ((string (make-string 1024))) - (declare (dynamic-extent string)) - (%str-from-ptr buf n string) - (write-sequence string out-stream :end n)))))))))) + (let* ((buf (make-string 1024)) + (n (ignore-errors (read-sequence buf in-stream)))) + (declare (dynamic-extent buf)) + (if (or (null n) (eql n 0)) + (without-interrupts + (decf (car token)) + (close in-stream) + (setf (car p) nil changed t)) + (write-sequence buf out-stream :end n)))))))) (let* ((statusflags (check-pid (external-process-pid p) (logior @@ -1290,4 +1308,5 @@ env (sharing :private) + (external-format `(:character-encoding ,*terminal-character-encoding-name*)) (silently-ignore-catastrophic-failures *silently-ignore-catastrophic-failure-in-run-program*)) @@ -1319,5 +1338,6 @@ :error nil :token token - :status-hook status-hook))) + :status-hook status-hook + :external-format (setq external-format (normalize-external-format t external-format))))) (unwind-protect (progn @@ -1326,5 +1346,6 @@ :if-does-not-exist if-input-does-not-exist :element-type element-type - :sharing sharing)) + :sharing sharing + :external-format external-format)) (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) (get-descriptor-for output proc close-in-parent close-on-error @@ -1332,5 +1353,6 @@ :if-exists if-output-exists :element-type element-type - :sharing sharing)) + :sharing sharing + :external-format external-format)) (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) (if (eq error :output) @@ -1340,5 +1362,6 @@ :if-exists if-error-exists :sharing sharing - :element-type element-type))) + :element-type element-type + :external-format external-format))) (setf (external-process-input proc) in-stream (external-process-output proc) out-stream @@ -1446,4 +1469,5 @@ direction (element-type 'character) (sharing :private) + external-format &allow-other-keys) (etypecase object @@ -1470,4 +1494,6 @@ :basic t :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) :auto-close t) (cons read-pipe close-in-parent) @@ -1481,4 +1507,6 @@ :basic t :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) :auto-close t) (cons write-pipe close-in-parent) @@ -1495,10 +1523,4 @@ (cons fd close-in-parent) (cons fd close-on-error))))) - (fd-stream - (let ((fd (fd-dup (ioblock-device (stream-ioblock object t))))) - (values fd - nil - (cons fd close-in-parent) - (cons fd close-on-error)))) (stream (ecase direction @@ -1508,17 +1530,18 @@ (if (< fd 0) (%errno-disp fd)) - (loop - (multiple-value-bind (line no-newline) - (read-line object nil nil) - (unless line - (return)) - (let* ((len (length line))) - (%stack-block ((buf (1+ len))) - (%cstr-pointer line buf) - (fd-write fd buf len) - (if no-newline - (return)) - (setf (%get-byte buf) (char-code #\newline)) - (fd-write fd buf 1))))) + (let* ((out (make-fd-stream (fd-dup fd) + :direction :output + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format)))) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (if no-newline + (write-string line out) + (write-line line out)) + )) + (close out)) (fd-lseek fd 0 #$SEEK_SET) (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) @@ -1550,4 +1573,5 @@ watched-fds watched-streams + external-format ) @@ -1571,4 +1595,5 @@ status-hook (element-type 'character) (sharing :private) + (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf)) env) "Invoke an external program as an OS subprocess of lisp." @@ -1595,4 +1620,5 @@ :error nil :token token + :external-format (setq external-format (normalize-external-format t external-format)) :status-hook status-hook))) (unwind-protect @@ -1602,5 +1628,6 @@ :if-does-not-exist if-input-does-not-exist :sharing sharing - :element-type element-type)) + :element-type element-type + :external-format external-format)) (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) (get-descriptor-for output proc close-in-parent close-on-error @@ -1608,5 +1635,6 @@ :if-exists if-output-exists :sharing sharing - :element-type element-type)) + :element-type element-type + :external-format external-format)) (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) (if (eq error :output) @@ -1616,5 +1644,6 @@ :if-exists if-error-exists :sharing sharing - :element-type element-type))) + :element-type element-type + :external-format external-format))) (setf (external-process-input proc) in-stream (external-process-output proc) out-stream @@ -1743,5 +1772,13 @@ (terminated) (changed) - (pairs (pairlis in-fds out-streams)) + (pairs (pairlis (mapcar (lambda (fd) + (cons fd + (make-fd-stream fd + :direction :input + :sharing :private + :encoding encoding + :line-termination line-termination))) + in-fds) + out-streams)) ) (loop @@ -1768,11 +1805,12 @@ (return))) (dolist (p pairs) - (let* ((in-fd (car p)) + (let* ((in-fd (caar p)) + (in-stream (cdar p)) (out-stream (cdr p))) (when (or terminated (data-available-on-pipe-p in-fd)) - (%stack-block ((buf 1024)) - (let* ((n (fd-read in-fd buf 1024))) - (declare (fixnum n)) - (if (<= n 0) + (let* ((buf (make-string 1024))) + (declare (dynamic-extent buf)) + (let* ((n (ignore-errors (read-sequence buf in-stream)))) + (if (or (null n) (eql n 0)) (progn (without-interrupts @@ -1780,19 +1818,7 @@ (fd-close in-fd) (setf (car p) nil changed t))) - - (let* ((string (make-string n)) - (m 0)) - (declare (dynamic-extent string) - (fixnum m)) - ;; Not quite right: we really want to map - ;; CRLF to #\Newline, but stripping #\Return - ;; is usually the same thing and easier. - (dotimes (i n) - (let* ((code (%get-unsigned-byte buf i))) - (unless (eql code (char-code #\Return)) - (setf (schar string m) (code-char code)) - (incf m)))) - (write-sequence string out-stream :end m) - (force-output out-stream)))))))) + (progn + (write-sequence buf out-stream :end n) + (force-output out-stream)))))))) (unless terminated (setq terminated (eql (#_WaitForSingleObjectEx