Changeset 13108
- Timestamp:
- Oct 27, 2009, 5:05:36 PM (15 years ago)
- File:
-
- 1 edited
-
trunk/source/level-1/linux-files.lisp (modified) (29 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/linux-files.lisp
r13067 r13108 1026 1026 watched-fds 1027 1027 watched-streams 1028 external-format 1028 1029 ) 1029 1030 … … 1042 1043 &key direction (element-type 'character) 1043 1044 (sharing :private) 1045 external-format 1044 1046 &allow-other-keys) 1045 1047 (etypecase object … … 1066 1068 :sharing sharing 1067 1069 :basic t 1070 :encoding (external-format-character-encoding external-format) 1071 :line-termination (external-format-line-termination external-format) 1068 1072 :auto-close t) 1069 1073 (cons read-pipe close-in-parent) … … 1077 1081 :basic t 1078 1082 :sharing sharing 1083 :encoding (external-format-character-encoding external-format) 1084 :line-termination (external-format-line-termination external-format) 1079 1085 :auto-close t) 1080 1086 (cons write-pipe close-in-parent) … … 1091 1097 (cons fd close-in-parent) 1092 1098 (cons fd close-on-error))))) 1099 #|| 1100 ;; What's an FD-STREAM ? 1093 1101 (fd-stream 1094 1102 (let ((fd (fd-dup (ioblock-device (stream-ioblock object t))))) … … 1097 1105 (cons fd close-in-parent) 1098 1106 (cons fd close-on-error)))) 1107 ||# 1099 1108 (stream 1100 1109 (ecase direction … … 1105 1114 (%errno-disp fd)) 1106 1115 (#_unlink template) 1107 (l oop1108 (multiple-value-bind (line no-newline)1109 (read-line object nil nil)1110 (unless line1111 (return))1112 ( let* ((len (length line)))1113 (%stack-block ((buf (1+ len)))1114 (%cstr-pointer line buf)1115 ( fd-write fd buf len)1116 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)) 1120 1129 (fd-lseek fd 0 #$SEEK_SET) 1121 1130 (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))) … … 1167 1176 (changed) 1168 1177 (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))) 1170 1190 (%stack-block ((in-fd-set *fd-set-size*)) 1171 1191 (rlet ((tv #>timeval)) … … 1181 1201 (setq maxfd 0) 1182 1202 (dolist (p pairs) 1183 (let* ((fd (ca r p)))1203 (let* ((fd (caar p))) 1184 1204 (when (> fd maxfd) 1185 1205 (setq maxfd fd)) … … 1190 1210 0) 1191 1211 (dolist (p pairs) 1192 (let* ((in-fd (car p)) 1212 (let* ((in-fd (caar p)) 1213 (in-stream (cdar p)) 1193 1214 (out-stream (cdr p))) 1194 1215 (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)))))))) 1207 1225 (let* ((statusflags (check-pid (external-process-pid p) 1208 1226 (logior … … 1290 1308 env 1291 1309 (sharing :private) 1310 (external-format `(:character-encoding ,*terminal-character-encoding-name*)) 1292 1311 (silently-ignore-catastrophic-failures 1293 1312 *silently-ignore-catastrophic-failure-in-run-program*)) … … 1319 1338 :error nil 1320 1339 :token token 1321 :status-hook status-hook))) 1340 :status-hook status-hook 1341 :external-format (setq external-format (normalize-external-format t external-format))))) 1322 1342 (unwind-protect 1323 1343 (progn … … 1326 1346 :if-does-not-exist if-input-does-not-exist 1327 1347 :element-type element-type 1328 :sharing sharing)) 1348 :sharing sharing 1349 :external-format external-format)) 1329 1350 (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) 1330 1351 (get-descriptor-for output proc close-in-parent close-on-error … … 1332 1353 :if-exists if-output-exists 1333 1354 :element-type element-type 1334 :sharing sharing)) 1355 :sharing sharing 1356 :external-format external-format)) 1335 1357 (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) 1336 1358 (if (eq error :output) … … 1340 1362 :if-exists if-error-exists 1341 1363 :sharing sharing 1342 :element-type element-type))) 1364 :element-type element-type 1365 :external-format external-format))) 1343 1366 (setf (external-process-input proc) in-stream 1344 1367 (external-process-output proc) out-stream … … 1446 1469 direction (element-type 'character) 1447 1470 (sharing :private) 1471 external-format 1448 1472 &allow-other-keys) 1449 1473 (etypecase object … … 1470 1494 :basic t 1471 1495 :sharing sharing 1496 :encoding (external-format-character-encoding external-format) 1497 :line-termination (external-format-line-termination external-format) 1472 1498 :auto-close t) 1473 1499 (cons read-pipe close-in-parent) … … 1481 1507 :basic t 1482 1508 :sharing sharing 1509 :encoding (external-format-character-encoding external-format) 1510 :line-termination (external-format-line-termination external-format) 1483 1511 :auto-close t) 1484 1512 (cons write-pipe close-in-parent) … … 1495 1523 (cons fd close-in-parent) 1496 1524 (cons fd close-on-error))))) 1497 (fd-stream1498 (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))1499 (values fd1500 nil1501 (cons fd close-in-parent)1502 (cons fd close-on-error))))1503 1525 (stream 1504 1526 (ecase direction … … 1508 1530 (if (< fd 0) 1509 1531 (%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)) 1523 1546 (fd-lseek fd 0 #$SEEK_SET) 1524 1547 (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) … … 1550 1573 watched-fds 1551 1574 watched-streams 1575 external-format 1552 1576 ) 1553 1577 … … 1571 1595 status-hook (element-type 'character) 1572 1596 (sharing :private) 1597 (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf)) 1573 1598 env) 1574 1599 "Invoke an external program as an OS subprocess of lisp." … … 1595 1620 :error nil 1596 1621 :token token 1622 :external-format (setq external-format (normalize-external-format t external-format)) 1597 1623 :status-hook status-hook))) 1598 1624 (unwind-protect … … 1602 1628 :if-does-not-exist if-input-does-not-exist 1603 1629 :sharing sharing 1604 :element-type element-type)) 1630 :element-type element-type 1631 :external-format external-format)) 1605 1632 (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) 1606 1633 (get-descriptor-for output proc close-in-parent close-on-error … … 1608 1635 :if-exists if-output-exists 1609 1636 :sharing sharing 1610 :element-type element-type)) 1637 :element-type element-type 1638 :external-format external-format)) 1611 1639 (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) 1612 1640 (if (eq error :output) … … 1616 1644 :if-exists if-error-exists 1617 1645 :sharing sharing 1618 :element-type element-type))) 1646 :element-type element-type 1647 :external-format external-format))) 1619 1648 (setf (external-process-input proc) in-stream 1620 1649 (external-process-output proc) out-stream … … 1743 1772 (terminated) 1744 1773 (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)) 1746 1783 ) 1747 1784 (loop … … 1768 1805 (return))) 1769 1806 (dolist (p pairs) 1770 (let* ((in-fd (car p)) 1807 (let* ((in-fd (caar p)) 1808 (in-stream (cdar p)) 1771 1809 (out-stream (cdr p))) 1772 1810 (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)) 1777 1815 (progn 1778 1816 (without-interrupts … … 1780 1818 (fd-close in-fd) 1781 1819 (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)))))))) 1797 1823 (unless terminated 1798 1824 (setq terminated (eql (#_WaitForSingleObjectEx
Note:
See TracChangeset
for help on using the changeset viewer.
