Changeset 13141


Ignore:
Timestamp:
Oct 30, 2009, 10:23:25 PM (10 years ago)
Author:
gz
Message:

Merge r13108 (:external-format arg to run-program)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/linux-files.lisp

    r13070 r13141  
    10261026    watched-fds
    10271027    watched-streams
     1028    external-format
    10281029    )
    10291030
     
    10421043                                    &key direction (element-type 'character)
    10431044                                    (sharing :private)
     1045                                    external-format
    10441046                                    &allow-other-keys)
    10451047    (etypecase object
     
    10661068                                    :sharing sharing
    10671069                                    :basic t
     1070                                    :encoding (external-format-character-encoding external-format)
     1071                                    :line-termination (external-format-line-termination external-format)
    10681072                                    :auto-close t)
    10691073                    (cons read-pipe close-in-parent)
     
    10771081                                    :basic t
    10781082                                    :sharing sharing
     1083                                    :encoding (external-format-character-encoding external-format)
     1084                                    :line-termination (external-format-line-termination external-format)
    10791085                                    :auto-close t)
    10801086                    (cons write-pipe close-in-parent)
     
    10911097                   (cons fd close-in-parent)
    10921098                   (cons fd close-on-error)))))
     1099      #||
     1100      ;; What's an FD-STREAM ?
    10931101      (fd-stream
    10941102       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
     
    10971105                 (cons fd close-in-parent)
    10981106                 (cons fd close-on-error))))
     1107      ||#
    10991108      (stream
    11001109       (ecase direction
     
    11051114                (%errno-disp fd))
    11061115              (#_unlink template)
    1107               (loop
    1108                 (multiple-value-bind (line no-newline)
    1109                     (read-line object nil nil)
    1110                   (unless line
    1111                     (return))
    1112                   (let* ((len (length line)))
    1113                     (%stack-block ((buf (1+ len)))
    1114                       (%cstr-pointer line buf)
    1115                       (fd-write fd buf len)
    1116                       (if no-newline
    1117                         (return))
    1118                       (setf (%get-byte buf) (char-code #\newline))
    1119                       (fd-write fd buf 1)))))
     1116              (let* ((out (make-fd-stream (fd-dup fd)
     1117                                          :direction :output
     1118                                          :encoding (external-format-character-encoding external-format)
     1119                                          :line-termination (external-format-line-termination external-format))))
     1120                (loop
     1121                  (multiple-value-bind (line no-newline)
     1122                      (read-line object nil nil)
     1123                    (unless line
     1124                      (return))
     1125                    (if no-newline
     1126                      (write-string line out)
     1127                      (write-line line out))))
     1128                (close out))
    11201129              (fd-lseek fd 0 #$SEEK_SET)
    11211130              (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
     
    11671176           (changed)
    11681177           (maxfd 0)
    1169            (pairs (pairlis in-fds out-streams)))
     1178           (external-format (external-process-external-format p))
     1179           (encoding (external-format-character-encoding external-format))
     1180           (line-termination (external-format-line-termination external-format))
     1181           (pairs (pairlis
     1182                   (mapcar (lambda (fd)
     1183                             (cons fd
     1184                                   (make-fd-stream fd
     1185                                                   :direction :input
     1186                                                   :sharing :private
     1187                                                   :encoding encoding
     1188                                                   :line-termination line-termination)))
     1189                                     in-fds) out-streams)))
    11701190      (%stack-block ((in-fd-set *fd-set-size*))
    11711191        (rlet ((tv #>timeval))
     
    11811201              (setq maxfd 0)
    11821202              (dolist (p pairs)
    1183                 (let* ((fd (car p)))
     1203                (let* ((fd (caar p)))
    11841204                  (when (> fd maxfd)
    11851205                    (setq maxfd fd))
     
    11901210                       0)
    11911211                (dolist (p pairs)
    1192                   (let* ((in-fd (car p))
     1212                  (let* ((in-fd (caar p))
     1213                         (in-stream (cdar p))
    11931214                         (out-stream (cdr p)))
    11941215                    (when (fd-is-set in-fd in-fd-set)
    1195                       (%stack-block ((buf 1024))
    1196                         (let* ((n (fd-read in-fd buf 1024)))
    1197                           (declare (fixnum n))
    1198                           (if (<= n 0)
    1199                             (without-interrupts
    1200                               (decf (car token))
    1201                               (fd-close in-fd)
    1202                               (setf (car p) nil changed t))
    1203                             (let* ((string (make-string 1024)))
    1204                               (declare (dynamic-extent string))
    1205                               (%str-from-ptr buf n string)
    1206                               (write-sequence string out-stream :end n))))))))))
     1216                      (let* ((buf (make-string 1024))
     1217                             (n (ignore-errors (read-sequence buf in-stream))))
     1218                        (declare (dynamic-extent buf))
     1219                        (if (or (null n) (eql n 0))
     1220                          (without-interrupts
     1221                           (decf (car token))
     1222                           (close in-stream)
     1223                           (setf (car p) nil changed t))
     1224                          (write-sequence buf out-stream :end n))))))))
    12071225            (let* ((statusflags (check-pid (external-process-pid p)
    12081226                                           (logior
     
    12901308                              env
    12911309                              (sharing :private)
     1310                              (external-format `(:character-encoding ,*terminal-character-encoding-name*))
    12921311                              (silently-ignore-catastrophic-failures
    12931312                               *silently-ignore-catastrophic-failure-in-run-program*))
     
    13191338             :error nil
    13201339             :token token
    1321              :status-hook status-hook)))
     1340             :status-hook status-hook
     1341             :external-format (setq external-format (normalize-external-format t external-format)))))
    13221342      (unwind-protect
    13231343           (progn
     
    13261346                                   :if-does-not-exist if-input-does-not-exist
    13271347                                   :element-type element-type
    1328                                    :sharing sharing))
     1348                                   :sharing sharing
     1349                                   :external-format external-format))
    13291350             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    13301351               (get-descriptor-for output proc close-in-parent close-on-error
     
    13321353                                   :if-exists if-output-exists
    13331354                                   :element-type element-type
    1334                                    :sharing sharing))
     1355                                   :sharing sharing
     1356                                   :external-format external-format))
    13351357             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    13361358               (if (eq error :output)
     
    13401362                                     :if-exists if-error-exists
    13411363                                     :sharing sharing
    1342                                      :element-type element-type)))
     1364                                     :element-type element-type
     1365                                     :external-format external-format)))
    13431366             (setf (external-process-input proc) in-stream
    13441367                   (external-process-output proc) out-stream
     
    14461469                                    direction (element-type 'character)
    14471470                                    (sharing :private)
     1471                                    external-format
    14481472                                    &allow-other-keys)
    14491473    (etypecase object
     
    14701494                                    :basic t
    14711495                                    :sharing sharing
     1496                                    :encoding (external-format-character-encoding external-format)
     1497                                    :line-termination (external-format-line-termination external-format)
    14721498                                    :auto-close t)
    14731499                    (cons read-pipe close-in-parent)
     
    14811507                                    :basic t
    14821508                                    :sharing sharing
     1509                                    :encoding (external-format-character-encoding external-format)
     1510                                    :line-termination (external-format-line-termination external-format)
    14831511                                    :auto-close t)
    14841512                    (cons write-pipe close-in-parent)
     
    14951523                   (cons fd close-in-parent)
    14961524                   (cons fd close-on-error)))))
    1497       (fd-stream
    1498        (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
    1499          (values fd
    1500                  nil
    1501                  (cons fd close-in-parent)
    1502                  (cons fd close-on-error))))
    15031525      (stream
    15041526       (ecase direction
     
    15081530            (if (< fd 0)
    15091531              (%errno-disp fd))
    1510             (loop
    1511               (multiple-value-bind (line no-newline)
    1512                   (read-line object nil nil)
    1513                 (unless line
    1514                   (return))
    1515                 (let* ((len (length line)))
    1516                   (%stack-block ((buf (1+ len)))
    1517                     (%cstr-pointer line buf)
    1518                     (fd-write fd buf len)
    1519                     (if no-newline
    1520                       (return))
    1521                     (setf (%get-byte buf) (char-code #\newline))
    1522                     (fd-write fd buf 1)))))
     1532            (let* ((out (make-fd-stream (fd-dup fd)
     1533                                        :direction :output
     1534                                        :encoding (external-format-character-encoding external-format)
     1535                                        :line-termination (external-format-line-termination external-format))))           
     1536              (loop
     1537                (multiple-value-bind (line no-newline)
     1538                    (read-line object nil nil)
     1539                  (unless line
     1540                    (return))
     1541                  (if no-newline
     1542                    (write-string line out)
     1543                    (write-line line out))
     1544                  ))
     1545              (close out))
    15231546            (fd-lseek fd 0 #$SEEK_SET)
    15241547            (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     
    15501573    watched-fds
    15511574    watched-streams
     1575    external-format
    15521576    )
    15531577
     
    15711595                              status-hook (element-type 'character)
    15721596                              (sharing :private)
     1597                              (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf))
    15731598                              env)
    15741599    "Invoke an external program as an OS subprocess of lisp."
     
    15951620             :error nil
    15961621             :token token
     1622             :external-format (setq external-format (normalize-external-format t external-format))
    15971623             :status-hook status-hook)))
    15981624      (unwind-protect
     
    16021628                                   :if-does-not-exist if-input-does-not-exist
    16031629                                   :sharing sharing
    1604                                    :element-type element-type))
     1630                                   :element-type element-type
     1631                                   :external-format external-format))
    16051632             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    16061633               (get-descriptor-for output proc close-in-parent close-on-error
     
    16081635                                   :if-exists if-output-exists
    16091636                                   :sharing sharing
    1610                                    :element-type element-type))
     1637                                   :element-type element-type
     1638                                   :external-format external-format))
    16111639             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    16121640               (if (eq error :output)
     
    16161644                                     :if-exists if-error-exists
    16171645                                     :sharing sharing
    1618                                      :element-type element-type)))
     1646                                     :element-type element-type
     1647                                     :external-format external-format)))
    16191648             (setf (external-process-input proc) in-stream
    16201649                   (external-process-output proc) out-stream
     
    17431772           (terminated)
    17441773           (changed)
    1745            (pairs (pairlis in-fds out-streams))
     1774           (pairs (pairlis (mapcar (lambda (fd)
     1775                                     (cons fd
     1776                                           (make-fd-stream fd
     1777                                                           :direction :input
     1778                                                           :sharing :private
     1779                                                           :encoding encoding
     1780                                                           :line-termination line-termination)))
     1781                                   in-fds)
     1782                           out-streams))
    17461783           )
    17471784      (loop
     
    17681805           (return)))
    17691806        (dolist (p pairs)
    1770           (let* ((in-fd (car p))
     1807          (let* ((in-fd (caar p))
     1808                 (in-stream (cdar p))
    17711809                 (out-stream (cdr p)))
    17721810            (when (or terminated (data-available-on-pipe-p in-fd))
    1773               (%stack-block ((buf 1024))
    1774                 (let* ((n (fd-read in-fd buf 1024)))
    1775                   (declare (fixnum n))
    1776                   (if (<= n 0)
     1811              (let* ((buf (make-string 1024)))
     1812                (declare (dynamic-extent buf))
     1813                (let* ((n (ignore-errors (read-sequence buf in-stream))))
     1814                  (if (or (null n) (eql n 0))
    17771815                    (progn
    17781816                      (without-interrupts
     
    17801818                       (fd-close in-fd)
    17811819                       (setf (car p) nil changed t)))
    1782 
    1783                     (let* ((string (make-string n))
    1784                            (m 0))
    1785                       (declare (dynamic-extent string)
    1786                                (fixnum m))
    1787                       ;; Not quite right: we really want to map
    1788                       ;; CRLF to #\Newline, but stripping #\Return
    1789                       ;; is usually the same thing and easier.
    1790                       (dotimes (i n)
    1791                         (let* ((code (%get-unsigned-byte buf i)))
    1792                           (unless (eql code (char-code #\Return))
    1793                             (setf (schar string m) (code-char code))
    1794                             (incf m))))
    1795                       (write-sequence string out-stream :end m)
    1796                       (force-output out-stream))))))))
     1820                    (progn
     1821                      (write-sequence buf out-stream :end n)
     1822                      (force-output out-stream))))))))
    17971823        (unless terminated
    17981824          (setq terminated (eql (#_WaitForSingleObjectEx
Note: See TracChangeset for help on using the changeset viewer.