Skip to content
Snippets Groups Projects
fd-stream.lisp 75.6 KiB
Newer Older
ram's avatar
ram committed
;;; OPEN -- public
;;;
;;;   Open the given file.
;;;
(defun open (filename &rest options
		      &key (direction :input)
			   (element-type 'base-char element-type-given)
			   (if-exists nil if-exists-given)
			   (if-does-not-exist nil if-does-not-exist-given)
			   (external-format :default)
			   class mapped input-handle output-handle
		      &allow-other-keys
		      &aux ; Squelch assignment warning.
		      (direction direction)
		      (if-does-not-exist if-does-not-exist)
		      (if-exists if-exists))
ram's avatar
ram committed
  "Return a stream which reads from or writes to Filename.
  Defined keywords:
   :direction - one of :input, :output, :io, or :probe
   :element-type - Type of object to read or write, default BASE-CHAR
ram's avatar
ram committed
   :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
                       :overwrite, :append, :supersede or nil
   :if-does-not-exist - one of :error, :create or nil
   :external-format - an external format name
ram's avatar
ram committed
  See the manual for details."
  (declare (ignore element-type external-format input-handle output-handle))

  ;; OPEN signals a file-error if the filename is wild.
  (when (wild-pathname-p filename)
    (error 'file-error :pathname filename))
ram's avatar
ram committed
  ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
  (setq direction
ram's avatar
ram committed
	(assure-one-of direction
		       '(:input :output :io :probe)
		       :direction))
  (setf (getf options :direction) direction)
ram's avatar
ram committed

  (when (and if-exists-given (member direction '(:output :io)))
    (setq if-exists
	  (assure-one-of if-exists
			 '(:error :new-version :rename
			   :rename-and-delete :overwrite
			   :append :supersede nil)
			 :if-exists))
    (setf (getf options :if-exists) if-exists))

  (when if-does-not-exist-given
    (setq if-does-not-exist
	  (assure-one-of if-does-not-exist
			 '(:error :create nil)
			 :if-does-not-exist))
    (setf (getf options :if-does-not-exist) if-does-not-exist))

  (let ((filespec (pathname filename))
	(options (copy-list options))
	(class (or class 'fd-stream)))
    (cond ((eq class 'fd-stream)
	   (remf options :class)
           (remf options :mapped)
           (remf options :input-handle)
           (remf options :output-handle)
           (apply #'open-fd-stream filespec options))
	  ((eq class 'binary-text-stream)
	   ;; Like fd-stream, but binary and text allowed.  This is
	   ;; indicated by leaving the :class option around for
	   ;; open-fd-stream to see.
           (remf options :mapped)
           (remf options :input-handle)
           (remf options :output-handle)
	   (apply #'open-fd-stream filespec options))
	  ((subtypep class 'stream:simple-stream)
	   (when element-type-given
toy's avatar
toy committed
             (cerror "Do it anyway."
		     "Can't create simple-streams with an element-type."))
           (when (and (eq class 'stream:file-simple-stream) mapped)
             (setq class 'stream:mapped-file-simple-stream)
             (setf (getf options :class) 'stream:mapped-file-simple-stream))
           (when (subtypep class 'stream:file-simple-stream)
             (when (eq direction :probe)
toy's avatar
toy committed
               (setq class 'stream:probe-simple-stream)))
           (apply #'make-instance class :filename filespec options))
	  ((subtypep class 'ext:fundamental-stream)
	   (remf options :class)
           (remf options :mapped)
           (remf options :input-handle)
           (remf options :output-handle)
	   (let ((stream (apply #'open-fd-stream filespec options)))
	     (when stream
	       (make-instance class :lisp-stream stream))))
	  (t
	   (error "Unable to open streams of class ~S." class)))))
ram's avatar
ram committed

;;;; Initialization.

(defvar *tty* nil
  "The stream connected to the controlling terminal or NIL if there is none.")
(defvar *stdin* nil
  "The stream connected to the standard input (file descriptor 0).")
(defvar *stdout* nil
  "The stream connected to the standard output (file descriptor 1).")
(defvar *stderr* nil
  "The stream connected to the standard error output (file descriptor 2).")

;;; STREAM-INIT -- internal interface
;;;
;;; Called when the cold load is first started up.
;;; 
(defun stream-init ()
  (stream-reinit)
  (setf *terminal-io* (make-synonym-stream '*tty*))
  (setf *standard-output* (make-synonym-stream '*stdout*))
  (setf *standard-input*
	(make-two-way-stream (make-synonym-stream '*stdin*)
			     *standard-output*))
ram's avatar
ram committed
  (setf *error-output* (make-synonym-stream '*stderr*))
  (setf *query-io* (make-synonym-stream '*terminal-io*))
pw's avatar
pw committed
  (setf *debug-io* *query-io*)
ram's avatar
ram committed
  (setf *trace-output* *standard-output*)
  nil)

;;; STREAM-REINIT -- internal interface
;;;
;;; Called whenever a saved core is restarted.
;;; 
(defun stream-reinit ()
  (setf *available-buffers* nil)
  (setf *stdin*
rtoy's avatar
rtoy committed
	(make-fd-stream 0 :name "Standard Input" :input t :buffering :line
			:external-format :iso8859-1))
ram's avatar
ram committed
  (setf *stdout*
rtoy's avatar
rtoy committed
	(make-fd-stream 1 :name "Standard Output" :output t :buffering :line
			:external-format :iso8859-1))
ram's avatar
ram committed
  (setf *stderr*
rtoy's avatar
rtoy committed
	(make-fd-stream 2 :name "Standard Error" :output t :buffering :line
			:external-format :iso8859-1))
  (let ((tty (and (not *batch-mode*)
		  (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
    (setf *tty*
	  (if tty
ram's avatar
ram committed
	      (make-fd-stream tty :name "the Terminal" :input t :output t
rtoy's avatar
rtoy committed
			      :buffering :line :auto-close t
			      :external-format :iso8859-1)
	      (make-two-way-stream *stdin* *stdout*))))
ram's avatar
ram committed
  nil)


;;;; Beeping.

(defun default-beep-function (stream)
  (write-char #\bell stream)
  (finish-output stream))

(defvar *beep-function* #'default-beep-function
  "This is called in BEEP to feep the user.  It takes a stream.")

(defun beep (&optional (stream *terminal-io*))
  (funcall *beep-function* stream))


;;; File-Name  --  internal interface
;;;
;;;    Kind of like File-Position, but is an internal hack used by the filesys
;;; stuff to get and set the file name.
;;;
(defun file-name (stream &optional new-name)
  (typecase stream
    (stream:simple-stream
     (if new-name
	 (stream::%file-rename stream new-name)
	 (stream::%file-name stream)))
    (fd-stream
     (cond (new-name
	    (setf (fd-stream-pathname stream) new-name)
	    (setf (fd-stream-file stream)
		  (unix-namestring new-name nil))
	    t)
	   (t
	    (fd-stream-pathname stream))))))
#+unicode
(stream::def-ef-macro ef-strlen (extfmt lisp stream::+ef-max+ stream::+ef-str+)
  (if (= (stream::ef-min-octets (stream::find-external-format extfmt))
	 (stream::ef-max-octets (stream::find-external-format extfmt)))
      `(lambda (stream object)
	 (declare (ignore stream)
		  (type (or character string) object)
		  (optimize (speed 3) (space 0) (safety 0)))
	 (etypecase object
	   (character ,(stream::ef-min-octets (stream::find-external-format extfmt)))
	   (string (* ,(stream::ef-min-octets (stream::find-external-format extfmt))
		      (length object)))))
      `(lambda (stream object &aux (count 0))
	 (declare (type fd-stream stream)
		  (type (or character string) object)
rtoy's avatar
rtoy committed
		  #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
	    `(labels ((eflen (char)
		       (stream::char-to-octets ,extfmt char
					       ;;@@ FIXME: don't alter state!
					       (fd-stream-co-state stream)
					       (lambda (byte)
						 (declare (ignore byte))
						 (incf count)))))
	       (etypecase object
		 (character (eflen object))
		 (string (dovector (ch object) (eflen ch))))
	       count))))


(defun file-string-length (stream object)
  (declare (type (or string character) object)
rtoy's avatar
rtoy committed
	   (type (or file-stream broadcast-stream stream:simple-stream) stream))
  "Return the delta in Stream's FILE-POSITION that would be caused by writing
   Object to Stream.  Non-trivial only in implementations that support
   international character sets."
  (typecase stream
    (stream:simple-stream (stream::%file-string-length stream object))
rtoy's avatar
rtoy committed
    (broadcast-stream
     ;; CLHS says we must return 1 in this case
     1)
    #+unicode
    (t (funcall (ef-strlen (fd-stream-external-format stream))
		stream object))
    #-unicode
    (t (etypecase object
	 (character 1)
	 (string (length object))))))