/[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.82 by rtoy, Mon Feb 21 17:14:28 2005 UTC revision 1.83 by rtoy, Mon Apr 4 14:33:17 2005 UTC
# Line 21  Line 21 
21    
22  (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream  (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
23            io-timeout beep *beep-function* output-raw-bytes            io-timeout beep *beep-function* output-raw-bytes
24            *tty* *stdin* *stdout* *stderr*))            *tty* *stdin* *stdout* *stderr*
25              binary-text-stream))
26    
27    
28  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
# Line 122  Line 123 
123    (format stream "#<Stream for ~A>"    (format stream "#<Stream for ~A>"
124            (fd-stream-name fd-stream)))            (fd-stream-name fd-stream)))
125    
126    ;; CMUCL extension.  This is a FD-STREAM, but it allows reading and
127    ;; writing of 8-bit characters and unsigned bytes from the stream.
128    (defstruct (binary-text-stream
129                 (:print-function %print-binary-text-stream)
130                 (:constructor %make-binary-text-stream)
131                 (:include fd-stream)))
132    
133    (defun %print-binary-text-stream (fd-stream stream depth)
134      (declare (ignore depth) (stream stream))
135      (format stream "#<Binary-text Stream for ~A>"
136              (fd-stream-name fd-stream)))
137    
138  (define-condition io-timeout (stream-error)  (define-condition io-timeout (stream-error)
139    ((direction :reader io-timeout-direction :initarg :direction))    ((direction :reader io-timeout-direction :initarg :direction))
# Line 979  Line 991 
991  ;;; to calling this routine.  ;;; to calling this routine.
992  ;;;  ;;;
993    
994  ;;; Hack to enable fd-streams to be opened for both character and binary input.  (defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p)
 ;;; Set this to T to enable.  When there is confidence that this doesn't break anything,  
 ;;; remove this global and the change the test in set-routines to just (eql size 1).  
 (defvar *fd-stream-enable-character-and-binary-input* nil)  
   
 (defun set-routines (stream type input-p output-p buffer-p)  
995    (let ((target-type (case type    (let ((target-type (case type
996                         ((:default unsigned-byte)                         ((:default unsigned-byte)
997                          '(unsigned-byte 8))                          '(unsigned-byte 8))
# Line 1016  Line 1023 
1023          (if (subtypep type 'character)          (if (subtypep type 'character)
1024              (setf (fd-stream-in stream) routine              (setf (fd-stream-in stream) routine
1025                    (fd-stream-bin stream) #'ill-bin)                    (fd-stream-bin stream) #'ill-bin)
1026              (setf (fd-stream-in stream) (if (and *fd-stream-enable-character-and-binary-input*              (setf (fd-stream-in stream) (if (and binary-stream-p
1027                                                   (eql size 1))                                                   (eql size 1))
1028                                              (pick-input-routine 'character)                                              (pick-input-routine 'character)
1029                                              #'ill-in)                                              #'ill-in)
# Line 1332  Line 1339 
1339                         (name (if file                         (name (if file
1340                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1341                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
1342                         auto-close)                         auto-close
1343                           binary-stream-p)
1344    (declare (type index fd) (type (or index null) timeout)    (declare (type index fd) (type (or index null) timeout)
1345             (type (member :none :line :full) buffering))             (type (member :none :line :full) buffering))
1346    "Create a stream for the given unix file descriptor.    "Create a stream for the given unix file descriptor.
# Line 1349  Line 1357 
1357           (setf input t))           (setf input t))
1358          ((not (or input output))          ((not (or input output))
1359           (error "File descriptor must be opened either for input or output.")))           (error "File descriptor must be opened either for input or output.")))
1360    (let ((stream (%make-fd-stream :fd fd    (let ((stream (if binary-stream-p
1361                                   :name name                      (%make-binary-text-stream :fd fd
1362                                   :file file                                                :name name
1363                                   :original original                                                :file file
1364                                   :delete-original delete-original                                                :original original
1365                                   :pathname pathname                                                :delete-original delete-original
1366                                   :buffering buffering                                                :pathname pathname
1367                                   :timeout timeout)))                                                :buffering buffering
1368      (set-routines stream element-type input output input-buffer-p)                                                :timeout timeout)
1369                        (%make-fd-stream :fd fd
1370                                         :name name
1371                                         :file file
1372                                         :original original
1373                                         :delete-original delete-original
1374                                         :pathname pathname
1375                                         :buffering buffering
1376                                         :timeout timeout))))
1377        (set-routines stream element-type input output input-buffer-p
1378                      :binary-stream-p binary-stream-p)
1379      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1380        (finalize stream        (finalize stream
1381                  #'(lambda ()                  #'(lambda ()
# Line 1624  Line 1642 
1642                                  (element-type 'base-char)                                  (element-type 'base-char)
1643                                  (if-exists nil if-exists-given)                                  (if-exists nil if-exists-given)
1644                                  (if-does-not-exist nil if-does-not-exist-given)                                  (if-does-not-exist nil if-does-not-exist-given)
1645                                  (external-format :default))                                  (external-format :default)
1646                                    class)
1647    (declare (type pathname pathname)    (declare (type pathname pathname)
1648             (type (member :input :output :io :probe) direction)             (type (member :input :output :io :probe) direction)
1649             (type (member :error :new-version :rename :rename-and-delete             (type (member :error :new-version :rename :rename-and-delete
# Line 1637  Line 1656 
1656      (when fd      (when fd
1657        (case direction        (case direction
1658          ((:input :output :io)          ((:input :output :io)
1659             ;; We use the :class option to tell us if we want a
1660             ;; binary-text stream or not.
1661           (make-fd-stream fd           (make-fd-stream fd
1662                           :input (member direction '(:input :io))                           :input (member direction '(:input :io))
1663                           :output (member direction '(:output :io))                           :output (member direction '(:output :io))
# Line 1646  Line 1667 
1667                           :delete-original delete-original                           :delete-original delete-original
1668                           :pathname pathname                           :pathname pathname
1669                           :input-buffer-p t                           :input-buffer-p t
1670                           :auto-close t))                           :auto-close t
1671                             :binary-stream-p class))
1672          (:probe          (:probe
1673           (let ((stream (%make-fd-stream :name namestring :fd fd           (let ((stream (%make-fd-stream :name namestring :fd fd
1674                                          :pathname pathname                                          :pathname pathname
# Line 1717  Line 1739 
1739             (remf options :input-handle)             (remf options :input-handle)
1740             (remf options :output-handle)             (remf options :output-handle)
1741             (apply #'open-fd-stream filespec options))             (apply #'open-fd-stream filespec options))
1742              ((eq class 'binary-text-stream)
1743               ;; Like fd-stream, but binary and text allowed.  This is
1744               ;; indicated by leaving the :class option around for
1745               ;; open-fd-stream to see.
1746               (remf options :mapped)
1747               (remf options :input-handle)
1748               (remf options :output-handle)
1749               (apply #'open-fd-stream filespec options))
1750            ((subtypep class 'stream:simple-stream)            ((subtypep class 'stream:simple-stream)
1751             (when element-type-given             (when element-type-given
1752               (cerror "Do it anyway."               (cerror "Do it anyway."

Legend:
Removed from v.1.82  
changed lines
  Added in v.1.83

  ViewVC Help
Powered by ViewVC 1.1.5