/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Diff of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.90.2.6 by rtoy, Thu Sep 3 16:57:54 2009 UTC revision 1.125 by rtoy, Wed Jun 29 00:55:04 2011 UTC
# Line 19  Line 19 
19    
20  (in-package "SYSTEM")  (in-package "SYSTEM")
21    
22    (intl:textdomain "cmucl")
23    
24  (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream  (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
25            io-timeout beep *beep-function* output-raw-bytes            io-timeout beep *beep-function* output-raw-bytes
26            *tty* *stdin* *stdout* *stderr*            *tty* *stdin* *stdout* *stderr*
# Line 41  Line 43 
43    "List of available buffers.  Each buffer is an sap pointing to    "List of available buffers.  Each buffer is an sap pointing to
44    bytes-per-buffer of memory.")    bytes-per-buffer of memory.")
45    
46    (defvar lisp::*enable-stream-buffer-p* nil)
47    
48  (defconstant bytes-per-buffer (* 4 1024)  (defconstant bytes-per-buffer (* 4 1024)
49    "Number of bytes per buffer.")    "Number of bytes per buffer.")
50    
# Line 250  Line 254 
254    #+unicode    #+unicode
255    (co-state nil)    (co-state nil)
256    #+unicode    #+unicode
257    (last-char-read-size 0 :type index))    (last-char-read-size 0 :type index)
258      ;;
259      ;; The number of octets in in-buffer.  Normally equal to
260      ;; in-buffer-length, but could be less if we reached the
261      ;; end-of-file.
262      #+unicode
263      (in-length 0 :type index)
264      ;;
265      ;; Indicates how to handle errors when converting octets to
266      ;; characters.  If NIL, then the external format should handle it
267      ;; itself, doing whatever is deemed appropriate.  If non-NIL, this
268      ;; should be a function (or symbol) that the external format can
269      ;; funcall to deal with the error.  The function should take three
270      ;; arguments: a message string, the offending octet, and the number
271      ;; of octets read so far in decoding; if the function returns it
272      ;; should return the codepoint of the desired replacement character.
273      (octets-to-char-error nil :type (or null symbol function))
274      ;;
275      ;; Like OCTETS-TO-CHAR-ERROR, but for converting characters to
276      ;; octets for output.  The function takes two arguments: a message
277      ;; string and the codepoint that cannot be converted.  The function
278      ;; should return the octet that should be output.
279      (char-to-octets-error nil :type (or null symbol function)))
280    
281  (defun %print-fd-stream (fd-stream stream depth)  (defun %print-fd-stream (fd-stream stream depth)
282    (declare (ignore depth) (stream stream))    (declare (ignore depth) (stream stream))
# Line 274  Line 300 
300    (:report    (:report
301     (lambda (condition stream)     (lambda (condition stream)
302       (declare (stream stream))       (declare (stream stream))
303       (format stream "Timeout ~(~A~)ing ~S."       (format stream (intl:gettext "Timeout ~(~A~)ing ~S.")
304               (io-timeout-direction condition)               (io-timeout-direction condition)
305               (stream-error-stream condition)))))               (stream-error-stream condition)))))
306    
# Line 308  Line 334 
334                           length)                           length)
335        (cond ((not count)        (cond ((not count)
336               (if (= errno unix:ewouldblock)               (if (= errno unix:ewouldblock)
337                   (error "Write would have blocked, but SERVER told us to go.")                   (error (intl:gettext "Write would have blocked, but SERVER told us to go."))
338                   (error "While writing ~S: ~A"                   (error (intl:gettext "While writing ~S: ~A")
339                          stream (unix:get-unix-error-msg errno))))                          stream (unix:get-unix-error-msg errno))))
340              ((eql count length) ; Hot damn, it worked.              ((eql count length) ; Hot damn, it worked.
341               (when reuse-sap               (when reuse-sap
# Line 383  Line 409 
409         (declare (type index tail))         (declare (type index tail))
410         (cond         (cond
411           ((stream::ef-flush-state ,(stream::find-external-format extfmt))           ((stream::ef-flush-state ,(stream::find-external-format extfmt))
412            (stream::flush-state ,extfmt            (let* ((sap (fd-stream-obuf-sap stream))
413                                 (fd-stream-co-state stream)                   (len (fd-stream-obuf-length stream)))
414                                 (lambda (byte)              (declare (type sys:system-area-pointer sap)
415                                   (when (= tail len)                       (type index len)
416                                     (do-output stream sap 0 tail t)                       (ignorable sap len))
417                                     (setq sap (fd-stream-obuf-sap stream)              (stream::flush-state ,extfmt
418                                           tail 0))                                   (fd-stream-co-state stream)
419                                   (setf (bref sap (1- (incf tail))) byte)))                                   (lambda (byte)
420            (setf (fd-stream-obuf-tail stream) tail))                                     (when (= tail len)
421                                         (do-output stream sap 0 tail t)
422                                         (setq sap (fd-stream-obuf-sap stream)
423                                               tail 0))
424                                       (setf (bref sap (1- (incf tail))) byte))
425                                     (fd-stream-char-to-octets-error stream))
426                (setf (fd-stream-obuf-tail stream) tail)))
427           (t           (t
428            ;; No flush-state function, so just output a replacement            ;; No flush-state function, so just output a replacement
429            ;; character.  We hack the co-state to what we need for this            ;; character (or signal an error).  We hack the co-state to
430            ;; to work.  This should be ok because we're closing the            ;; what we need for this to work.  This should be ok because
431            ;; file anyway.            ;; we're closing the file anyway.
432            (let ((state (fd-stream-co-state stream)))            (let* ((state (fd-stream-co-state stream))
433              (when (and state (car state))                   (c (car state)))
434                (when (and state c)
435                (setf (fd-stream-co-state stream)                (setf (fd-stream-co-state stream)
436                      (cons nil (cdr state)))                      (cons nil (cdr state)))
437                (funcall (ef-cout (fd-stream-external-format stream))                (funcall (ef-cout (fd-stream-external-format stream))
438                         stream (code-char stream::+replacement-character-code+))))))                         stream
439                           ;; Handle bare surrogates or use the
440                           ;; replacement character.
441                           (if (lisp::surrogatep c)
442                               (if (fd-stream-char-to-octets-error stream)
443                                   (funcall (fd-stream-char-to-octets-error stream)
444                                            "Flushing bare surrogate #x~4,0X is illegal"
445                                            (char-code c))
446                                   (code-char stream:+replacement-character-code+))
447                               c))))))
448         (values))))         (values))))
449    
450  ;;; FLUSH-OUTPUT-BUFFER -- internal  ;;; FLUSH-OUTPUT-BUFFER -- internal
# Line 558  Line 600 
600                                     (do-output stream sap 0 tail t)                                     (do-output stream sap 0 tail t)
601                                     (setq sap (fd-stream-obuf-sap stream)                                     (setq sap (fd-stream-obuf-sap stream)
602                                           tail 0))                                           tail 0))
603                                   (setf (bref sap (1- (incf tail))) byte)))                                   (setf (bref sap (1- (incf tail))) byte))
604                                   (fd-stream-char-to-octets-error stream))
605         (setf (fd-stream-obuf-tail stream) tail))         (setf (fd-stream-obuf-tail stream) tail))
606      (if (char= char #\Newline)      (if (char= char #\Newline)
607          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
# Line 597  Line 640 
640             (bytes (- end start))             (bytes (- end start))
641             (newtail (+ tail bytes)))             (newtail (+ tail bytes)))
642        (cond ((minusp bytes) ; Error case        (cond ((minusp bytes) ; Error case
643               (cerror "Just go on as if nothing happened..."               (cerror (intl:gettext "Just go on as if nothing happened...")
644                       "~S called with :END before :START!"                       (intl:gettext "~S called with :END before :START!")
645                       'output-raw-bytes))                       'output-raw-bytes))
646              ((zerop bytes)) ; Easy case              ((zerop bytes)) ; Easy case
647              ((<= bytes space)              ((<= bytes space)
# Line 672  Line 715 
715                                       (do-output stream sap 0 tail t)                                       (do-output stream sap 0 tail t)
716                                       (setq sap (fd-stream-obuf-sap stream)                                       (setq sap (fd-stream-obuf-sap stream)
717                                             tail 0))                                             tail 0))
718                                     (setf (bref sap (1- (incf tail))) byte))))                                     (setf (bref sap (1- (incf tail))) byte))
719                                     (fd-stream-char-to-octets-error stream)))
720         (setf (fd-stream-obuf-tail stream) tail))))         (setf (fd-stream-obuf-tail stream) tail))))
721    
722    
# Line 878  Line 922 
922                             :format-arguments (list (unix:get-unix-error-msg errno))                             :format-arguments (list (unix:get-unix-error-msg errno))
923                             :errno errno))                             :errno errno))
924                     (t                     (t
925                      (error "Error reading ~S: ~A"                      (error (intl:gettext "Error reading ~S: ~A")
926                             stream                             stream
927                             (unix:get-unix-error-msg errno)))))                             (unix:get-unix-error-msg errno)))))
928              ((zerop count)              ((zerop count)
# Line 1268  Line 1312 
1312                                    now-needed)                                    now-needed)
1313                  (declare (type (or index null) count))                  (declare (type (or index null) count))
1314                  (unless count                  (unless count
1315                    (error "Error reading ~S: ~A" stream                    (error (intl:gettext "Error reading ~S: ~A") stream
1316                           (unix:get-unix-error-msg err)))                           (unix:get-unix-error-msg err)))
1317                  (decf now-needed count)                  (decf now-needed count)
1318                  (if eof-error-p                  (if eof-error-p
# Line 1288  Line 1332 
1332                  (unix:unix-read (fd-stream-fd stream) sap len)                  (unix:unix-read (fd-stream-fd stream) sap len)
1333                (declare (type (or index null) count))                (declare (type (or index null) count))
1334                (unless count                (unless count
1335                  (error "Error reading ~S: ~A" stream                  (error (intl:gettext "Error reading ~S: ~A") stream
1336                         (unix:get-unix-error-msg err)))                         (unix:get-unix-error-msg err)))
1337                (when (and eof-error-p (zerop count))                (when (and eof-error-p (zerop count))
1338                  (error 'end-of-file :stream stream))                  (error 'end-of-file :stream stream))
# Line 1354  Line 1398 
1398            (routine type size)            (routine type size)
1399            (pick-input-routine target-type)            (pick-input-routine target-type)
1400          (unless routine          (unless routine
1401            (error "Could not find any input routine for ~S" target-type))            (error (intl:gettext "Could not find any input routine for ~S") target-type))
1402          (setf (fd-stream-ibuf-sap stream) (next-available-buffer))          (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
1403          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
1404          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1405    
1406            ;; Set the in and bin methods.  Normally put an illegal input
1407            ;; function in, but if we have a binary text stream, pick an
1408            ;; appropriate input routine.
1409          (if (subtypep type 'character)          (if (subtypep type 'character)
1410              (setf (fd-stream-in stream) routine              (setf (fd-stream-in stream) routine
1411                    (fd-stream-bin stream) #'ill-bin)                    (fd-stream-bin stream) (if (and binary-stream-p
1412                                                      (eql size 1))
1413                                                 (pick-input-routine '(unsigned-byte 8))
1414                                                 #'ill-bin))
1415              (setf (fd-stream-in stream) (if (and binary-stream-p              (setf (fd-stream-in stream) (if (and binary-stream-p
1416                                                   (eql size 1))                                                   (eql size 1))
1417                                              (pick-input-routine 'character)                                              (pick-input-routine 'character)
# Line 1378  Line 1429 
1429                        ;; since we already have size = 1.                        ;; since we already have size = 1.
1430                        (or (eq 'unsigned-byte (and (consp type) (car type)))                        (or (eq 'unsigned-byte (and (consp type) (car type)))
1431                            (eq type :default))                            (eq type :default))
1432                        ;; Character streams with :iso8859-1                        (eq type 'character)))
1433                        (and (eq type 'character)              (when *enable-stream-buffer-p*
1434                             #+unicode                (when (and (not binary-stream-p)
1435                             (eql :iso8859-1 (fd-stream-external-format stream)))))                           (eq type 'character))
1436              ;; We only create this buffer for streams of type                  ;; Create the in-buffer for any character (only)
1437              ;; (unsigned-byte 8) or character streams with an external                  ;; stream.  Don't want one for binary-text-streams!
1438              ;; format of :iso8859-1.  Because there's no buffer, the                  (setf (lisp-stream-in-buffer stream)
1439              ;; other element-types will dispatch to the appropriate                        (make-array in-buffer-length
1440              ;; input (output) routine in fast-read-byte/fast-read-char.                                    :element-type '(unsigned-byte 8))))
1441              (setf (lisp-stream-in-buffer stream)                #+unicode
1442                    (make-array in-buffer-length                (when (and (not binary-stream-p)
1443                                :element-type '(unsigned-byte 8)))))                           (eq type 'character)
1444                             (not (eq :iso8859-1 (fd-stream-external-format stream))))
1445                    ;; For character streams, we create the string-buffer so
1446                    ;; we can convert all available octets at once instead
1447                    ;; of for each character.  The string is one element
1448                    ;; longer than in-buffer-length to leave room for
1449                    ;; unreading.
1450                    ;;
1451                    ;; For ISO8859-1, we don't want this because it's very
1452                    ;; easy and quick to convert octets to iso8859-1.  (See
1453                    ;; FAST-READ-CHAR.)
1454    
1455                    (setf (lisp-stream-string-buffer stream)
1456                          (make-string (1+ in-buffer-length)))
1457                    (setf (fd-stream-octet-count stream)
1458                          (make-array in-buffer-length :element-type '(unsigned-byte 8)))
1459                    (setf (lisp-stream-string-buffer-len stream) 0)
1460                    (setf (lisp-stream-string-index stream) 0)))))
1461          (setf input-size size)          (setf input-size size)
1462          (setf input-type type)))          (setf input-type type)))
1463    
# Line 1398  Line 1466 
1466            (routine type size)            (routine type size)
1467            (pick-output-routine target-type (fd-stream-buffering stream))            (pick-output-routine target-type (fd-stream-buffering stream))
1468          (unless routine          (unless routine
1469            (error "Could not find any output routine for ~S buffered ~S."            (error (intl:gettext "Could not find any output routine for ~S buffered ~S.")
1470                   (fd-stream-buffering stream)                   (fd-stream-buffering stream)
1471                   target-type))                   target-type))
1472          (setf (fd-stream-obuf-sap stream) (next-available-buffer))          (setf (fd-stream-obuf-sap stream) (next-available-buffer))
1473          (setf (fd-stream-obuf-length stream) bytes-per-buffer)          (setf (fd-stream-obuf-length stream) bytes-per-buffer)
1474          (setf (fd-stream-obuf-tail stream) 0)          (setf (fd-stream-obuf-tail stream) 0)
1475            ;; Normally signal errors for reading from a stream with the
1476            ;; wrong element type, but allow binary-text-streams to read
1477            ;; from either.
1478          (if (subtypep type 'character)          (if (subtypep type 'character)
1479            (setf (fd-stream-out stream) routine              (setf (fd-stream-out stream) routine
1480                  (fd-stream-bout stream) #'ill-bout)                    (fd-stream-bout stream)
1481            (setf (fd-stream-out stream)                      (if (and binary-stream-p
1482                  (or (if (eql size 1)                               (eql size 1))
1483                            (pick-output-routine '(unsigned-byte 8)
1484                                                 (fd-stream-buffering stream))
1485                            #'ill-bout))
1486                (setf (fd-stream-out stream)
1487                      (if (and binary-stream-p (eql size 1))
1488                        (pick-output-routine 'base-char                        (pick-output-routine 'base-char
1489                                             (fd-stream-buffering stream)))                                             (fd-stream-buffering stream))
1490                      #'ill-out)                        #'ill-out)
1491                  (fd-stream-bout stream) routine))                    (fd-stream-bout stream) routine))
1492          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
1493                (if (eql size 1) #'fd-sout #'ill-out))                (if (eql size 1) #'fd-sout #'ill-out))
1494          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
# Line 1421  Line 1497 
1497    
1498      (when (and input-size output-size      (when (and input-size output-size
1499                 (not (eql input-size output-size)))                 (not (eql input-size output-size)))
1500        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"        (error (intl:gettext "Element sizes for input (~S:~S) and output (~S:~S) differ?")
1501               input-type input-size               input-type input-size
1502               output-type output-size))               output-type output-size))
1503      (setf (fd-stream-element-size stream)      (setf (fd-stream-element-size stream)
# Line 1439  Line 1515 
1515                  ((subtypep output-type input-type)                  ((subtypep output-type input-type)
1516                   output-type)                   output-type)
1517                  (t                  (t
1518                   (error "Input type (~S) and output type (~S) are unrelated?"                   (error (intl:gettext "Input type (~S) and output type (~S) are unrelated?")
1519                          input-type                          input-type
1520                          output-type))))))                          output-type))))))
1521    
# Line 1455  Line 1531 
1531      (multiple-value-bind (okay err)      (multiple-value-bind (okay err)
1532          (unix:unix-rename original filename)          (unix:unix-rename original filename)
1533        (unless okay        (unless okay
1534            (cerror "Go on as if nothing bad happened."            (cerror (intl:gettext "Go on as if nothing bad happened.")
1535                    "Could not restore ~S to its original contents: ~A"                    (intl:gettext "Could not restore ~S to its original contents: ~A")
1536                    filename (unix:get-unix-error-msg err))))))                    filename (unix:get-unix-error-msg err))))))
1537    
1538  ;;; DELETE-ORIGINAL -- internal  ;;; DELETE-ORIGINAL -- internal
# Line 1496  Line 1572 
1572       #-unicode       #-unicode
1573       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
1574       #+unicode       #+unicode
1575       (if (zerop (fd-stream-last-char-read-size stream))       (cond ((lisp-stream-string-buffer stream)
1576           (setf (fd-stream-unread stream) arg1)              (if (zerop (lisp-stream-string-index stream))
1577           (decf (fd-stream-ibuf-head stream)                  (setf (fd-stream-unread stream) arg1)
1578                 (fd-stream-last-char-read-size stream)))                  (decf (lisp-stream-string-index stream))))
1579               (t
1580                (if (zerop (fd-stream-last-char-read-size stream))
1581                    (setf (fd-stream-unread stream) arg1)
1582                    (decf (fd-stream-ibuf-head stream)
1583                          (fd-stream-last-char-read-size stream)))))
1584       ;; Paul says:       ;; Paul says:
1585       ;;       ;;
1586       ;; Not needed for unicode when unreading is implemented by backing up in       ;; Not needed for unicode when unreading is implemented by backing up in
# Line 1585  Line 1666 
1666         (error 'simple-type-error         (error 'simple-type-error
1667                :datum stream                :datum stream
1668                :expected-type 'file-stream                :expected-type 'file-stream
1669                :format-control "~s is not a stream associated with a file."                :format-control (intl:gettext "~s is not a stream associated with a file.")
1670                :format-arguments (list stream)))                :format-arguments (list stream)))
1671       (multiple-value-bind       (multiple-value-bind
1672           (okay dev ino mode nlink uid gid rdev size           (okay dev ino mode nlink uid gid rdev size
# Line 1595  Line 1676 
1676                          atime mtime ctime blksize blocks))                          atime mtime ctime blksize blocks))
1677         (unless okay         (unless okay
1678           (error 'simple-file-error           (error 'simple-file-error
1679                  :format-control "Error fstating ~S: ~A"                  :format-control (intl:gettext "Error fstating ~S: ~A")
1680                  :format-arguments (list stream (unix:get-unix-error-msg dev))))                  :format-arguments (list stream (unix:get-unix-error-msg dev))))
1681         (if (zerop mode)         (if (zerop mode)
1682             nil             nil
# Line 1626  Line 1707 
1707                     (incf posn (- (the index (caddr later))                     (incf posn (- (the index (caddr later))
1708                                   (the index (cadr later)))))                                   (the index (cadr later)))))
1709                   (incf posn (fd-stream-obuf-tail stream))                   (incf posn (fd-stream-obuf-tail stream))
1710    
1711                   ;; Adjust for unread input:                   ;; Adjust for unread input:
1712                   ;;  If there is any input read from UNIX but not supplied to                   ;;  If there is any input read from UNIX but not supplied to
1713                   ;; the user of the stream, the *real* file position will                   ;; the user of the stream, the *real* file position will
# Line 1633  Line 1715 
1715                   ;; unread stuff is still available.                   ;; unread stuff is still available.
1716                   (decf posn (- (fd-stream-ibuf-tail stream)                   (decf posn (- (fd-stream-ibuf-tail stream)
1717                                 (fd-stream-ibuf-head stream)))                                 (fd-stream-ibuf-head stream)))
1718    
1719                     #+unicode
1720                     (when (fd-stream-string-buffer stream)
1721                       ;; The string buffer contains Lisp characters,
1722                       ;; not octets!  To figure out how many octets
1723                       ;; have not been already supplied, we need to
1724                       ;; count how many octets were consumed for all
1725                       ;; the characters in the string bbuffer that have
1726                       ;; not been supplied.
1727                       (let ((ocount (fd-stream-octet-count stream)))
1728                         (when ocount
1729                           ;; Note: string-index starts at 1 (because
1730                           ;; index 0 is for the unread-char), but
1731                           ;; octet-count doesn't use that.  Hence,
1732                           ;; subtract one from string-index and
1733                           ;; string-buffer-len.
1734                           #+nil
1735                           (progn
1736                             (format t "~&ocount = ~D~%" ocount)
1737                             (format t "posn = ~D~%" posn))
1738                           (loop for k of-type fixnum from (1- (fd-stream-string-index stream))
1739                                   below (1- (fd-stream-string-buffer-len stream))
1740                                 do (decf posn (aref ocount k)))
1741                           #+nil
1742                           (progn
1743                             (format t "new posn = ~D~%" posn)
1744                             (format t "in-buffer-length = ~D~%" in-buffer-length)
1745                             (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream))))))
1746                     (when (fd-stream-in-buffer stream)
1747                       ;; When we have an in-buffer (whether we have a
1748                       ;; string-buffer or not!), we need to adjust for
1749                       ;; the octets that have not yet been supplied.
1750                       ;; (This case happens with string-buffer when the
1751                       ;; in-buffer does not have enough octets to form a
1752                       ;; complete character.)  If there's no
1753                       ;; string-buffer and no in-buffer, then the ibuf
1754                       ;; tail and head pointers contain all the
1755                       ;; information needed.
1756                       #+nil
1757                       (progn
1758                         (format t "in-buffer-length = ~D~%" in-buffer-length)
1759                         (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream)))
1760                       (decf posn (- in-buffer-length
1761                                     (fd-stream-in-index stream))))
1762                     #+nil
1763                     (format t "fd-stream-unread = ~S~%" (fd-stream-unread stream))
1764                   (when (fd-stream-unread stream) ;;@@                   (when (fd-stream-unread stream) ;;@@
1765                     (decf posn))                     (decf posn))
1766                   ;; Divide bytes by element size.                   ;; Divide bytes by element size.
# Line 1641  Line 1769 
1769                   nil)                   nil)
1770                  (t                  (t
1771                   (system:with-interrupts                   (system:with-interrupts
1772                     (error "Error lseek'ing ~S: ~A"                     (error (intl:gettext "Error lseek'ing ~S: ~A")
1773                            stream                            stream
1774                            (unix:get-unix-error-msg errno)))))))                            (unix:get-unix-error-msg errno)))))))
1775        (let ((offset 0)        (let ((offset 0)
# Line 1657  Line 1785 
1785          ;; Clear out any pending input to force the next read to go to the          ;; Clear out any pending input to force the next read to go to the
1786          ;; disk.          ;; disk.
1787          (setf (fd-stream-unread stream) nil) ;;@@          (setf (fd-stream-unread stream) nil) ;;@@
1788          #+unicode (setf (fd-stream-last-char-read-size stream) 0)          #+unicode
1789            (progn
1790              (setf (fd-stream-last-char-read-size stream) 0)
1791              (setf (fd-stream-string-index stream)
1792                    (fd-stream-string-buffer-len stream)))
1793          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1794          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1795          ;; Trash cached value for listen, so that we check next time.          ;; Trash cached value for listen, so that we check next time.
# Line 1673  Line 1805 
1805                 (setf offset (* newpos (fd-stream-element-size stream))                 (setf offset (* newpos (fd-stream-element-size stream))
1806                       origin unix:l_set))                       origin unix:l_set))
1807                (t                (t
1808                 (error "Invalid position given to file-position: ~S" newpos)))                 (error (intl:gettext "Invalid position given to file-position: ~S") newpos)))
1809          (multiple-value-bind          (multiple-value-bind
1810              (posn errno)              (posn errno)
1811              (unix:unix-lseek (fd-stream-fd stream) offset origin)              (unix:unix-lseek (fd-stream-fd stream) offset origin)
# Line 1682  Line 1814 
1814                  ((eq errno unix:espipe)                  ((eq errno unix:espipe)
1815                   nil)                   nil)
1816                  (t                  (t
1817                   (error "Error lseek'ing ~S: ~A"                   (error (intl:gettext "Error lseek'ing ~S: ~A")
1818                          stream                          stream
1819                          (unix:get-unix-error-msg errno))))))))                          (unix:get-unix-error-msg errno))))))))
1820    
# Line 1706  Line 1838 
1838                         delete-original                         delete-original
1839                         pathname                         pathname
1840                         input-buffer-p                         input-buffer-p
1841                           ;; DO NOT translate these!  It causes an
1842                           ;; infinite loop.  We need to open a file for
1843                           ;; the translations, but if you translate
1844                           ;; these, then we need to do a lookup which
1845                           ;; wants to open the mo file which calls this
1846                           ;; to name which causes a lookup ....
1847                         (name (if file                         (name (if file
1848                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1849                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
1850                         auto-close                         auto-close
1851                         (external-format :default)                         (external-format :default)
1852                         binary-stream-p)                         binary-stream-p
1853                           decoding-error
1854                           encoding-error)
1855    (declare (type index fd) (type (or index null) timeout)    (declare (type index fd) (type (or index null) timeout)
1856             (type (member :none :line :full) buffering))             (type (member :none :line :full) buffering))
1857    "Create a stream for the given unix file descriptor.    "Create a stream for the given unix file descriptor.
# Line 1723  Line 1863 
1863    Timeout (if true) is the number of seconds to wait for input.  If NIL (the    Timeout (if true) is the number of seconds to wait for input.  If NIL (the
1864      default), then wait forever.  When we time out, we signal IO-TIMEOUT.      default), then wait forever.  When we time out, we signal IO-TIMEOUT.
1865    File is the name of the file (will be returned by PATHNAME).    File is the name of the file (will be returned by PATHNAME).
1866    Name is used to identify the stream when printed."    Name is used to identify the stream when printed.
1867      External-format is the external format to use for the stream.
1868      Decoding-error and Encoding-error indicate how decoding/encoding errors on
1869        the stream should be handled.  The default is to use a replacement character."
1870    (cond ((not (or input-p output-p))    (cond ((not (or input-p output-p))
1871           (setf input t))           (setf input t))
1872          ((not (or input output))          ((not (or input output))
1873           (error "File descriptor must be opened either for input or output.")))           (error (intl:gettext "File descriptor must be opened either for input or output."))))
1874    (let ((stream (if binary-stream-p    (let ((stream (if binary-stream-p
1875                      (%make-binary-text-stream :fd fd                      (%make-binary-text-stream :fd fd
1876                                                :name name                                                :name name
# Line 1737  Line 1880 
1880                                                :pathname pathname                                                :pathname pathname
1881                                                :buffering buffering                                                :buffering buffering
1882                                                :timeout timeout)                                                :timeout timeout)
1883                      (%make-fd-stream :fd fd                      (let ((e (cond ((characterp encoding-error)
1884                                       :name name                                      (constantly (char-code encoding-error)))
1885                                       :file file                                     (t
1886                                       :original original                                      encoding-error)))
1887                                       :delete-original delete-original                            (d (cond ((characterp decoding-error)
1888                                       :pathname pathname                                      (constantly (char-code decoding-error)))
1889                                       :buffering buffering                                     ((eq t decoding-error)
1890                                       :timeout timeout))))                                      #'(lambda (&rest args)
1891                                            (apply 'cerror
1892                                                   #+unicode _"Use Unicode replacement character instead"
1893                                                   #-unicode _"Use question mark character instead"
1894                                                   args)
1895                                            #+unicode
1896                                            stream:+replacement-character-code+
1897                                            #-unicode
1898                                            #\?))
1899                                       (t
1900                                        decoding-error))))
1901                          (%make-fd-stream :fd fd
1902                                           :name name
1903                                           :file file
1904                                           :original original
1905                                           :delete-original delete-original
1906                                           :pathname pathname
1907                                           :buffering buffering
1908                                           :timeout timeout
1909                                           :char-to-octets-error e
1910                                           :octets-to-char-error d)))))
1911        ;; Set the lisp-stream flags appropriately for the kind of stream
1912        ;; we have (character, binary, binary-text-stream).
1913        (cond ((typep stream 'binary-text-stream)
1914               (setf (fd-stream-flags stream) #b100))
1915              ((subtypep element-type 'character)
1916               (setf (fd-stream-flags stream) #b001))
1917              (t
1918               (setf (fd-stream-flags stream) #b010)))
1919    
1920      ;; FIXME: setting the external format here should be better      ;; FIXME: setting the external format here should be better
1921      ;; integrated into set-routines.  We do it before so that      ;; integrated into set-routines.  We do it before so that
1922      ;; set-routines can create an in-buffer if appropriate.  But we      ;; set-routines can create an in-buffer if appropriate.  But we
# Line 1753  Line 1925 
1925      ;;      ;;
1926      ;;#-unicode-bootstrap ; fails in stream-reinit otherwise      ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1927      #+(and unicode (not unicode-bootstrap))      #+(and unicode (not unicode-bootstrap))
1928      (setf (stream-external-format stream) external-format)      (%set-fd-stream-external-format stream external-format nil)
1929      (set-routines stream element-type input output input-buffer-p      (set-routines stream element-type input output input-buffer-p
1930                    :binary-stream-p binary-stream-p)                    :binary-stream-p binary-stream-p)
1931      #+(and unicode (not unicode-bootstrap))      #+(and unicode (not unicode-bootstrap))
1932      (setf (stream-external-format stream) external-format)      (%set-fd-stream-external-format stream external-format nil)
1933      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1934        (finalize stream        (finalize stream
1935                  #'(lambda ()                  #'(lambda ()
1936                      (unix:unix-close fd)                      (unix:unix-close fd)
1937                      (format *terminal-io* "** Closed ~A~%" name)                      (format *terminal-io* (intl:gettext "** Closed ~A~%") name)
1938                      (when original                      (when original
1939                        (revert-file file original)))))                        (revert-file file original)))))
1940      stream))      stream))
# Line 1791  Line 1963 
1963  ;;;  ;;;
1964  (defun next-version (name)  (defun next-version (name)
1965    (declare (type simple-string name))    (declare (type simple-string name))
1966    (let* ((sep (position #\/ name :from-end t))    (let* ((*ignore-wildcards* t)
1967             (sep (position #\/ name :from-end t))
1968           (base (if sep (subseq name 0 (1+ sep)) ""))           (base (if sep (subseq name 0 (1+ sep)) ""))
1969           (dir (unix:open-dir base)))           (dir (unix:open-dir base)))
1970      (multiple-value-bind (name type version)      (multiple-value-bind (name type version)
# Line 1826  Line 1999 
1999  (defun assure-one-of (item list what)  (defun assure-one-of (item list what)
2000    (unless (member item list)    (unless (member item list)
2001      (loop      (loop
2002        (cerror "Enter new value for ~*~S"        (cerror (intl:gettext "Enter new value for ~*~S")
2003                "~S is invalid for ~S. Must be one of~{ ~S~}"                (intl:gettext "~S is invalid for ~S. Must be one of~{ ~S~}")
2004                item                item
2005                what                what
2006                list)                list)
2007        (format (the stream *query-io*) "Enter new value for ~S: " what)        (format (the stream *query-io*) (intl:gettext "Enter new value for ~S: ") what)
2008        (force-output *query-io*)        (force-output *query-io*)
2009        (setf item (read *query-io*))        (setf item (read *query-io*))
2010        (when (member item list)        (when (member item list)
# Line 1846  Line 2019 
2019  ;;;  ;;;
2020  (defun do-old-rename (namestring original)  (defun do-old-rename (namestring original)
2021    (unless (unix:unix-access namestring unix:w_ok)    (unless (unix:unix-access namestring unix:w_ok)
2022      (cerror "Try to rename it anyway." "File ~S is not writable." namestring))      (cerror (intl:gettext "Try to rename it anyway.") (intl:gettext "File ~S is not writable.") namestring))
2023    (multiple-value-bind    (multiple-value-bind
2024        (okay err)        (okay err)
2025        (unix:unix-rename namestring original)        (unix:unix-rename namestring original)
2026      (cond (okay t)      (cond (okay t)
2027            (t            (t
2028             (cerror "Use :SUPERSEDE instead."             (cerror (intl:gettext "Use :SUPERSEDE instead.")
2029                     "Could not rename ~S to ~S: ~A."                     (intl:gettext "Could not rename ~S to ~S: ~A.")
2030                     namestring                     namestring
2031                     original                     original
2032                     (unix:get-unix-error-msg err))                     (unix:get-unix-error-msg err))
# Line 1910  Line 2083 
2083      (let ((name (cond ((unix-namestring pathname input))      (let ((name (cond ((unix-namestring pathname input))
2084                        ((and input (eq if-does-not-exist :create))                        ((and input (eq if-does-not-exist :create))
2085                         (unix-namestring pathname nil)))))                         (unix-namestring pathname nil)))))
2086        (let ((original (cond ((eq if-exists :new-version)        (let ((original (cond ((and name (eq if-exists :new-version))
2087                               (next-version name))                               (next-version name))
2088                              ((member if-exists '(:rename :rename-and-delete))                              ((member if-exists '(:rename :rename-and-delete))
2089                               (pick-backup-name name))))                               (pick-backup-name name))))
# Line 1934  Line 2107 
2107                               (error 'simple-file-error                               (error 'simple-file-error
2108                                   :pathname pathname                                   :pathname pathname
2109                                   :format-control                                   :format-control
2110                                   "Cannot open ~S for output: Is a directory."                                   (intl:gettext "Cannot open ~S for output: Is a directory.")
2111                                   :format-arguments (list name)))                                   :format-arguments (list name)))
2112                             (setf mode (logand orig-mode #o777))                             (setf mode (logand orig-mode #o777))
2113                             t)                             t)
# Line 1943  Line 2116 
2116                            (t                            (t
2117                             (error 'simple-file-error                             (error 'simple-file-error
2118                                    :pathname pathname                                    :pathname pathname
2119                                    :format-control "Cannot find ~S: ~A"                                    :format-control (intl:gettext "Cannot find ~S: ~A")
2120                                    :format-arguments                                    :format-arguments
2121                                      (list name                                      (list name
2122                                        (unix:get-unix-error-msg err/dev)))))))))                                        (unix:get-unix-error-msg err/dev)))))))))
# Line 1973  Line 2146 
2146                    ((eql errno unix:enoent)                    ((eql errno unix:enoent)
2147                     (case if-does-not-exist                     (case if-does-not-exist
2148                       (:error                       (:error
2149                         (cerror "Return NIL."                         (cerror (intl:gettext "Return NIL.")
2150                                 'simple-file-error                                 'simple-file-error
2151                                 :pathname pathname                                 :pathname pathname
2152                                 :format-control "Error opening ~S, ~A."                                 :format-control (intl:gettext "Error opening ~S, ~A.")
2153                                 :format-arguments                                 :format-arguments
2154                                     (list pathname                                     (list pathname
2155                                           (unix:get-unix-error-msg errno))))                                           (unix:get-unix-error-msg errno))))
2156                       (:create                       (:create
2157                         (cerror "Return NIL."                         (cerror (intl:gettext "Return NIL.")
2158                                 'simple-file-error                                 'simple-file-error
2159                                 :pathname pathname                                 :pathname pathname
2160                                 :format-control                                 :format-control
2161                                     "Error creating ~S, path does not exist."                                     (intl:gettext "Error creating ~S, path does not exist.")
2162                                 :format-arguments (list pathname))))                                 :format-arguments (list pathname))))
2163                     (return nil))                     (return nil))
2164                    ((eql errno unix:eexist)                    ((eql errno unix:eexist)
2165                     (unless (eq nil if-exists)                     (unless (eq nil if-exists)
2166                       (cerror "Return NIL."                       (cerror (intl:gettext "Return NIL.")
2167                               'simple-file-error                               'simple-file-error
2168                               :pathname pathname                               :pathname pathname
2169                               :format-control "Error opening ~S, ~A."                               :format-control (intl:gettext "Error opening ~S, ~A.")
2170                               :format-arguments                               :format-arguments
2171                                   (list pathname                                   (list pathname
2172                                         (unix:get-unix-error-msg errno))))                                         (unix:get-unix-error-msg errno))))
2173                     (return nil))                     (return nil))
2174                    ((eql errno unix:eacces)                    ((eql errno unix:eacces)
2175                     (cerror "Try again."                     (cerror (intl:gettext "Try again.")
2176                             'simple-file-error                             'simple-file-error
2177                             :pathname pathname                             :pathname pathname
2178                             :format-control "Error opening ~S, ~A."                             :format-control (intl:gettext "Error opening ~S, ~A.")
2179                             :format-arguments                             :format-arguments
2180                                 (list pathname                                 (list pathname
2181                                       (unix:get-unix-error-msg errno))))                                       (unix:get-unix-error-msg errno))))
2182                    (t                    (t
2183                     (cerror "Return NIL."                     (cerror (intl:gettext "Return NIL.")
2184                             'simple-file-error                             'simple-file-error
2185                             :pathname pathname                             :pathname pathname
2186                             :format-control "Error opening ~S, ~A."                             :format-control (intl:gettext "Error opening ~S, ~A.")
2187                             :format-arguments                             :format-arguments
2188                                 (list pathname                                 (list pathname
2189                                       (unix:get-unix-error-msg errno)))                                       (unix:get-unix-error-msg errno)))
# Line 2025  Line 2198 
2198                                  (if-exists nil if-exists-given)                                  (if-exists nil if-exists-given)
2199                                  (if-does-not-exist nil if-does-not-exist-given)                                  (if-does-not-exist nil if-does-not-exist-given)
2200                                  (external-format :default)                                  (external-format :default)
2201                                  class)                                  class
2202                                    decoding-error encoding-error)
2203    (declare (type pathname pathname)    (declare (type pathname pathname)
2204             (type (member :input :output :io :probe) direction)             (type (member :input :output :io :probe) direction)
2205             (type (member :error :new-version :rename :rename-and-delete             (type (member :error :new-version :rename :rename-and-delete
# Line 2050  Line 2224 
2224                           :input-buffer-p t                           :input-buffer-p t
2225                           :auto-close t                           :auto-close t
2226                           :external-format external-format                           :external-format external-format
2227                           :binary-stream-p class))                           :binary-stream-p class
2228                             :decoding-error decoding-error
2229                             :encoding-error encoding-error))
2230          (:probe          (:probe
2231           (let ((stream (%make-fd-stream :name namestring :fd fd           (let ((stream (%make-fd-stream :name namestring :fd fd
2232                                          :pathname pathname                                          :pathname pathname
# Line 2069  Line 2245 
2245                             (if-does-not-exist nil if-does-not-exist-given)                             (if-does-not-exist nil if-does-not-exist-given)
2246                             (external-format :default)                             (external-format :default)
2247                             class mapped input-handle output-handle                             class mapped input-handle output-handle
2248                               decoding-error encoding-error
2249                        &allow-other-keys                        &allow-other-keys
2250                        &aux ; Squelch assignment warning.                        &aux ; Squelch assignment warning.
2251                        (options options)                        (options options)
# Line 2083  Line 2260 
2260                         :overwrite, :append, :supersede or nil                         :overwrite, :append, :supersede or nil
2261     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
2262     :external-format - an external format name     :external-format - an external format name
2263       :decoding-error - How to handle decoding errors from the external format.
2264                           If a character, then that character is used as
2265                           the replacment character for all errors.  If T,
2266                           then a continuable error is signaled.  If
2267                           continued, the Unicode replacement character is
2268                           used.  Otherwise, it should be a symbol or
2269                           function of 3 arguments.  If it returns, it
2270                           should return a code point to use as the
2271                           replacment.  The function arguments are a
2272                           format message string, the offending octet, and
2273                           the number of octets read in the current
2274                           encoding.
2275       :encoding-error - Like :decoding-error, but for errors when encoding the
2276                           stream.  If a character, that character is used
2277                           as the replacment code point.  Otherwise, it
2278                           should be a symbol or function oof two
2279                           arguments: a format message string and the
2280                           incorrect codepoint.
2281    
2282    See the manual for details."    See the manual for details."
2283    (declare (ignore element-type external-format input-handle output-handle))    (declare (ignore element-type external-format input-handle output-handle
2284                       decoding-error encoding-error))
2285    
2286    ;; OPEN signals a file-error if the filename is wild.    ;; OPEN signals a file-error if the filename is wild.
2287    (when (wild-pathname-p filename)    (when (wild-pathname-p filename)
# Line 2113  Line 2310 
2310                           :if-does-not-exist))                           :if-does-not-exist))
2311      (setf (getf options :if-does-not-exist) if-does-not-exist))      (setf (getf options :if-does-not-exist) if-does-not-exist))
2312    
2313    (let ((filespec (pathname filename))    (let ((filespec (merge-pathnames filename))
2314          (options (copy-list options))          (options (copy-list options))
2315          (class (or class 'fd-stream)))          (class (or class 'fd-stream)))
2316      (cond ((eq class 'fd-stream)      (cond ((eq class 'fd-stream)
# Line 2132  Line 2329 
2329             (apply #'open-fd-stream filespec options))             (apply #'open-fd-stream filespec options))
2330            ((subtypep class 'stream:simple-stream)            ((subtypep class 'stream:simple-stream)
2331             (when element-type-given             (when element-type-given
2332               (cerror "Do it anyway."               (cerror (intl:gettext "Do it anyway.")
2333                       "Can't create simple-streams with an element-type."))                       (intl:gettext "Can't create simple-streams with an element-type.")))
2334             (when (and (eq class 'stream:file-simple-stream) mapped)             (when (and (eq class 'stream:file-simple-stream) mapped)
2335               (setq class 'stream:mapped-file-simple-stream)               (setq class 'stream:mapped-file-simple-stream)
2336               (setf (getf options :class) 'stream:mapped-file-simple-stream))               (setf (getf options :class) 'stream:mapped-file-simple-stream))
# Line 2150  Line 2347 
2347               (when stream               (when stream
2348                 (make-instance class :lisp-stream stream))))                 (make-instance class :lisp-stream stream))))
2349            (t            (t
2350             (error "Unable to open streams of class ~S." class)))))             (error (intl:gettext "Unable to open streams of class ~S.") class)))))
2351    
2352  ;;;; Initialization.  ;;;; Initialization.
2353    
# Line 2260  Line 2457 
2457                                          (fd-stream-co-state stream)                                          (fd-stream-co-state stream)
2458                                          (lambda (byte)                                          (lambda (byte)
2459                                            (declare (ignore byte))                                            (declare (ignore byte))
2460                                            (incf count)))))                                            (incf count))
2461                                            (fd-stream-char-to-octets-erroor stream))))
2462         (let* ((co-state (fd-stream-co-state stream))         (let* ((co-state (fd-stream-co-state stream))
2463                (old-ef-state (efstate (cdr (fd-stream-co-state stream))))                (old-ef-state (efstate (cdr (fd-stream-co-state stream))))
2464                (old-state (cons (car co-state) old-ef-state)))                (old-state (cons (car co-state) old-ef-state)))
# Line 2290  Line 2488 
2488      (t (etypecase object      (t (etypecase object
2489           (character 1)           (character 1)
2490           (string (length object))))))           (string (length object))))))
2491    
2492    #+unicode
2493    (stream::def-ef-macro ef-copy-state (extfmt lisp stream::+ef-max+ stream::+ef-copy-state+)
2494      ;; Return a copy of the state of an external format.
2495      `(lambda (state)
2496         (declare (ignorable state))
2497         (stream::copy-state ,extfmt state)))

Legend:
Removed from v.1.90.2.6  
changed lines
  Added in v.1.125

  ViewVC Help
Powered by ViewVC 1.1.5