Skip to content
Snippets Groups Projects
fd-stream.lisp 61.4 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Log: code.log; Package: LISP -*-
ram's avatar
ram committed
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.80 2004/09/23 22:04:34 rtoy Exp $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;; Streams for UNIX file descriptors.
;;;
;;; Written by William Lott, July 1989 - January 1990.
;;; Some tuning by Rob MacLachlan.
ram's avatar
ram committed
;;; 
;;; **********************************************************************


(in-package "SYSTEM")

(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
          io-timeout beep *beep-function* output-raw-bytes
ram's avatar
ram committed
	  *tty* *stdin* *stdout* *stderr*))


(in-package "EXTENSIONS")

(export '(*backup-extension*))


(in-package "LISP")

(export '(file-stream file-string-length))
ram's avatar
ram committed

;;;; Buffer manipulation routines.

(defvar *available-buffers* ()
  "List of available buffers.  Each buffer is an sap pointing to
  bytes-per-buffer of memory.")
ram's avatar
ram committed

(defconstant bytes-per-buffer (* 4 1024)
  "Number of bytes per buffer.")

;; This limit is rather arbitrary
(defconstant max-stream-element-size 1024
  "The maximum supported byte size for a stream element-type.")

ram's avatar
ram committed
;;; NEXT-AVAILABLE-BUFFER -- Internal.
;;;
;;; Returns the next available buffer, creating one if necessary.
ram's avatar
ram committed
;;;
pw's avatar
pw committed
(declaim (inline next-available-buffer))
ram's avatar
ram committed
;;;
(defun next-available-buffer ()
  (if *available-buffers*
      (pop *available-buffers*)
      (allocate-system-memory bytes-per-buffer)))
ram's avatar
ram committed


;;;; The FD-STREAM structure.

moore's avatar
 
moore committed
;;;; Superclass defined by the ANSI Spec
(defstruct (file-stream
	     (:include lisp-stream)
	     (:constructor nil)
	     (:copier nil)))

ram's avatar
ram committed
(defstruct (fd-stream
	    (:print-function %print-fd-stream)
	    (:constructor %make-fd-stream)
moore's avatar
 
moore committed
	    (:include file-stream
ram's avatar
ram committed
		      (misc #'fd-stream-misc-routine)))

  (name nil)		      ; The name of this stream
  (file nil)		      ; The file this stream is for
  ;;
  ;; The backup file namestring for the old file, for :if-exists :rename or
  ;; :rename-and-delete.
  (original nil :type (or simple-string null))
ram's avatar
ram committed
  (delete-original nil)	      ; for :if-exists :rename-and-delete
  ;;
  ;;; Number of bytes per element.
  (element-size 1 :type index)
  (element-type 'base-char)   ; The type of element being transfered.
ram's avatar
ram committed
  (fd -1 :type fixnum)	      ; The file descriptor
  ;;
  ;; Controls when the output buffer is flushed.
  (buffering :full :type (member :full :line :none))
  ;;
  ;; Character position if known.
  (char-pos nil :type (or index null))
  ;;
  ;; T if input is waiting on FD.  :EOF if we hit EOF.
  (listen nil :type (member nil t :eof))
  ;;
ram's avatar
ram committed
  ;; The input buffer.
  (unread nil)
  (ibuf-sap nil :type (or system-area-pointer null))
  (ibuf-length nil :type (or index null))
  (ibuf-head 0 :type index)
  (ibuf-tail 0 :type index)
ram's avatar
ram committed

  ;; The output buffer.
  (obuf-sap nil :type (or system-area-pointer null))
  (obuf-length nil :type (or index null))
  (obuf-tail 0 :type index)
ram's avatar
ram committed

  ;; Output flushed, but not written due to non-blocking io.
  (output-later nil)
  (handler nil)
  ;;
  ;; Timeout specified for this stream, or NIL if none.
  (timeout nil :type (or index null))
  ;;
  ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
  (pathname nil :type (or pathname null)))
ram's avatar
ram committed

(defun %print-fd-stream (fd-stream stream depth)
  (declare (ignore depth) (stream stream))
ram's avatar
ram committed
  (format stream "#<Stream for ~A>"
	  (fd-stream-name fd-stream)))


(define-condition io-timeout (stream-error)
  ((direction :reader io-timeout-direction :initarg :direction))
     (declare (stream stream))
     (format stream "Timeout ~(~A~)ing ~S."
	     (io-timeout-direction condition)
	     (stream-error-stream condition)))))

ram's avatar
ram committed

;;;; Output routines and related noise.

(defvar *output-routines* ()
  "List of all available output routines. Each element is a list of the
  element-type output, the kind of buffering, the function name, and the number
  of bytes per element.")

;;; DO-OUTPUT-LATER -- internal
;;;
;;;   Called by the server when we can write to the given file descriptor.
;;; Attempt to write the data again. If it worked, remove the data from the
ram's avatar
ram committed
;;; output-later list. If it didn't work, something is wrong.
;;;
(defun do-output-later (stream)
  (let* ((stuff (pop (fd-stream-output-later stream)))
	 (base (car stuff))
	 (start (cadr stuff))
	 (end (caddr stuff))
	 (reuse-sap (cadddr stuff))
ram's avatar
ram committed
	 (length (- end start)))
    (declare (type index start end length))
ram's avatar
ram committed
    (multiple-value-bind
	(count errno)
	(unix:unix-write (fd-stream-fd stream)
ram's avatar
ram committed
			 base
			 start
			 length)
      (cond ((not count)
	     (if (= errno unix:ewouldblock)
		 (error "Write would have blocked, but SERVER told us to go.")
		 (error "While writing ~S: ~A"
			stream (unix:get-unix-error-msg errno))))
	    ((eql count length) ; Hot damn, it worked.
	     (when reuse-sap
	       (push base *available-buffers*)))
ram's avatar
ram committed
	    ((not (null count)) ; Sorta worked.
	     (push (list base
			 (the index (+ start count))
		   (fd-stream-output-later stream))))))
ram's avatar
ram committed
  (unless (fd-stream-output-later stream)
    (system:remove-fd-handler (fd-stream-handler stream))
    (setf (fd-stream-handler stream) nil)))

;;; OUTPUT-LATER -- internal
;;;
;;;   Arrange to output the string when we can write on the file descriptor.
ram's avatar
ram committed
;;;
(defun output-later (stream base start end reuse-sap)
ram's avatar
ram committed
  (cond ((null (fd-stream-output-later stream))
	 (setf (fd-stream-output-later stream)
	       (list (list base start end reuse-sap)))
ram's avatar
ram committed
	 (setf (fd-stream-handler stream)
	       (system:add-fd-handler (fd-stream-fd stream)
				      :output
				      #'(lambda (fd)
					  (declare (ignore fd))
					  (do-output-later stream)))))
	(t
	 (nconc (fd-stream-output-later stream)
		(list (list base start end reuse-sap)))))
  (when reuse-sap
ram's avatar
ram committed
    (let ((new-buffer (next-available-buffer)))
      (setf (fd-stream-obuf-sap stream) new-buffer)
      (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) 
ram's avatar
ram committed

;;; DO-OUTPUT -- internal
;;;
;;;   Output the given noise. Check to see if there are any pending writes. If
;;; so, just queue this one. Otherwise, try to write it. If this would block,
;;; queue it.
;;;
(defun do-output (stream base start end reuse-sap)
  (declare (type fd-stream stream)
	   (type (or system-area-pointer (simple-array * (*))) base)
	   (type index start end))
ram's avatar
ram committed
  (if (not (null (fd-stream-output-later stream))) ; something buffered.
      (progn
	(output-later stream base start end reuse-sap)
	;; ### check to see if any of this noise can be output
	)
      (let ((length (- end start)))
	(multiple-value-bind
	    (unix:unix-write (fd-stream-fd stream) base start length)
	  (cond ((not count)
		 (if (= errno unix:ewouldblock)
		     (output-later stream base start end reuse-sap)
emarsden's avatar
 
emarsden committed
		     (error 'simple-stream-error
                            :stream stream
                            :format-control "while writing: ~A"
			    :format-arguments (list (unix:get-unix-error-msg errno)))))
		((not (eql count length))
		 (output-later stream base (the index (+ start count))
			       end reuse-sap)))))))
ram's avatar
ram committed

;;; FLUSH-OUTPUT-BUFFER -- internal
;;;
;;;   Flush any data in the output buffer.
;;;
(defun flush-output-buffer (stream)
  (let ((length (fd-stream-obuf-tail stream)))
    (unless (= length 0)
      (do-output stream (fd-stream-obuf-sap stream) 0 length t)
ram's avatar
ram committed
      (setf (fd-stream-obuf-tail stream) 0))))

;;; DEF-OUTPUT-ROUTINES -- internal
;;;
;;;   Define output routines that output numbers size bytes long for the
;;; given bufferings. Use body to do the actual output.
;;;
(defmacro def-output-routines ((name size &rest bufferings) &body body)
  (declare (optimize (speed 1)))
ram's avatar
ram committed
  (cons 'progn
	(mapcar
	    #'(lambda (buffering)
		(let ((function
		       (intern (let ((*print-case* :upcase))
				 (format nil name (car buffering))))))
		  `(progn
		     (defun ,function (stream byte)
		       ,(unless (eq (car buffering) :none)
			  `(when (< (fd-stream-obuf-length stream)
				    (+ (fd-stream-obuf-tail stream)
				       ,size))
			     (flush-output-buffer stream)))
		       ;;
		       ;; If there is any input read from UNIX but not
		       ;; supplied to the user of the stream, reposition
		       ;; to the real file position as seen from Lisp.
		       ,(unless (eq (car buffering) :none)
			  `(when (> (fd-stream-ibuf-tail stream)
				    (fd-stream-ibuf-head stream))
			     (file-position stream (file-position stream))))
ram's avatar
ram committed
		       ,@body
		       (incf (fd-stream-obuf-tail stream) ,size)
		       ,(ecase (car buffering)
			  (:none
			   `(flush-output-buffer stream))
			  (:line
			   `(when (eq (char-code byte) (char-code #\Newline))
			      (flush-output-buffer stream)))
			  (:full
			   ))
		       (values))
		     (setf *output-routines*
			   (nconc *output-routines*
				  ',(mapcar
					#'(lambda (type)
					    (list type
						  (car buffering)
						  function
						  size))
				      (cdr buffering)))))))
	  bufferings)))

(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
		      1
		      (:none character)
		      (:line character)
		      (:full character))
      (setf (fd-stream-char-pos stream) 0)
      (incf (fd-stream-char-pos stream)))
  (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
	(char-code byte)))

(def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
ram's avatar
ram committed
		      1
		      (:none (unsigned-byte 8))
		      (:full (unsigned-byte 8)))
  (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
	byte))
ram's avatar
ram committed

(def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
		      1
		      (:none (signed-byte 8))
		      (:full (signed-byte 8)))
  (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
			  (fd-stream-obuf-tail stream))
	byte))

(def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
ram's avatar
ram committed
		      2
		      (:none (unsigned-byte 16))
		      (:full (unsigned-byte 16)))
  (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
(def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
		      2
		      (:none (signed-byte 16))
		      (:full (signed-byte 16)))
  (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
			   (fd-stream-obuf-tail stream))
	byte))

(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
ram's avatar
ram committed
		      4
		      (:none (unsigned-byte 32))
		      (:full (unsigned-byte 32)))
  (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
ram's avatar
ram committed

(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
		      4
		      (:none (signed-byte 32))
		      (:full (signed-byte 32)))
  (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
			   (fd-stream-obuf-tail stream))
	byte))


ram's avatar
ram committed
;;; OUTPUT-RAW-BYTES -- public
;;;
;;;   Does the actual output. If there is space to buffer the string, buffer
;;; it. If the string would normally fit in the buffer, but doesn't because
;;; of other stuff in the buffer, flush the old noise out of the buffer and
;;; put the string in it. Otherwise we have a very long string, so just
Loading
Loading full blame...