Skip to content
Snippets Groups Projects
fd-stream.lisp 39.5 KiB
Newer Older
ram's avatar
ram committed
   namestring.")
;;;
(defun pick-backup-name (name)
  (etypecase *backup-extension*
    (string (concatenate 'simple-string name *backup-extension*))
    (function (funcall *backup-extension* name))))

;;; ASSURE-ONE-OF -- internal
;;;
;;; Assure that the given arg is one of the given list of valid things.
;;; Allow the user to fix any problems.
;;; 
(defun assure-one-of (item list what)
  (unless (member item list)
    (loop
      (cerror "Enter new value for ~*~S"
	      "~S is invalid for ~S. Must be one of~{ ~S~}"
	      item
	      what
	      list)
      (format *query-io* "Enter new value for ~S: " what)
      (force-output *query-io*)
      (setf item (read *query-io*))
      (when (member item list)
	(return))))
  item)

;;; OPEN -- public
;;;
;;;   Open the given file.
;;;
(defun open (filename
	     &key
	     (direction :input)
	     (element-type 'string-char)
	     (if-exists nil if-exists-given)
	     (if-does-not-exist nil if-does-not-exist-given))
  "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 STRING-CHAR
   :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
  See the manual for details."
  ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
  (setf direction
	(assure-one-of direction
		       '(:input :output :io :probe)
		       :direction))

  ;; Calculate useful stuff.
  (multiple-value-bind
      (input output mask)
      (case direction
	(:input (values t nil mach:o_rdonly))
	(:output (values nil t mach:o_wronly))
	(:io (values t t mach:o_rdwr))
	(:probe (values nil nil mach:o_rdonly)))
    (let* ((pathname (pathname filename))
	   (namestring (predict-name pathname input)))
      
      ;; Process if-exists argument if we are doing any output.
      (cond (output
	     (unless if-exists-given
	       (setf if-exists
		     (if (eq (pathname-version pathname) :newest)
		       :new-version
		       :error)))
	     (setf if-exists
		   (assure-one-of if-exists
				  '(:error :new-version :rename
				    :rename-and-delete :overwrite
				    :append :supersede nil)
				  :if-exists))
	     (case if-exists
	       ((:error nil)
		(setf mask (logior mask mach:o_excl)))
	       ((:rename :rename-and-delete)
		(setf mask (logior mask mach:o_creat)))
	       ((:new-version :supersede)
		(setf mask (logior mask mach:o_trunc)))
	       (:append
		(setf mask (logior mask mach:o_append)))))
	    (t
	     (setf if-exists :ignore-this-arg)))
      
      (unless if-does-not-exist-given
	(setf if-does-not-exist
	      (cond ((eq direction :input) :error)
		    ((and output
			  (member if-exists '(:overwrite :append)))
		     :error)
		    ((eq direction :probe)
		     nil)
		    (t
		     :create))))
      (setf if-does-not-exist
	    (assure-one-of if-does-not-exist
			   '(:error :create nil)
			   :if-does-not-exist))
      (if (eq if-does-not-exist :create)
	(setf mask (logior mask mach:o_creat)))
       
      (let ((original (if (member if-exists
				  '(:rename :rename-and-delete))
			(pick-backup-name namestring)))
	    (delete-original (eq if-exists :rename-and-delete))
	    (mode #o666))
	(when original
	  ;; We are doing a :rename or :rename-and-delete.
	  ;; Determine if the file already exists, make sure the original
	  ;; file is not a directory and keep the mode
	  (let ((exists
		 (multiple-value-bind
		     (okay err/dev inode orig-mode)
		     (mach:unix-stat namestring)
		   (declare (ignore inode))
		   (cond (okay
			  (when (and output (= (logand orig-mode #o170000)
					       #o40000))
			    (error "Cannot open ~S for output: Is a directory."
				   namestring))
			  (setf mode (logand orig-mode #o777))
			  t)
			 ((eql err/dev mach:enoent)
			  nil)
			 (t
			  (error "Cannot find ~S: ~A"
				 namestring
				 (mach:get-unix-error-msg err/dev)))))))
	    (when (or (not exists)
		      ;; Do the rename.
		      (multiple-value-bind
			  (okay err)
			  (mach:unix-rename namestring original)
			(unless okay
			  (cerror "Use :SUPERSEDE instead."
				  "Could not rename ~S to ~S: ~A."
				  namestring
				  original
				  (mach:get-unix-error-msg err))
			  t)))
	      (setf original nil)
	      (setf delete-original nil)
	      ;; In order to use SUPERSEDE instead, we have
	      ;; to make sure mach:o_creat corresponds to
	      ;; if-does-not-exist.  mach:o_creat was set
	      ;; before because of if-exists being :rename.
	      (unless (eq if-does-not-exist :create)
		(setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
	      (setf if-exists :supersede))))
	
	;; Okay, now we can try the actual open.
	(multiple-value-bind
	    (fd errno)
	    (mach:unix-open namestring mask mode)
	  (cond ((numberp fd)
		 (case direction
		   ((:input :output :io)
		    (make-fd-stream fd
				    :input input
				    :output output
				    :element-type element-type
				    :file namestring
				    :original original
				    :delete-original delete-original))
		   (:probe
		    (let ((stream (%make-fd-stream :name namestring
						   :fd fd
						   :element-type element-type)))
		      (close stream)
		      stream))))
		((eql errno mach:enoent)
		 (case if-does-not-exist
		   (:error
		    (cerror "Return NIL."
			    "Error opening ~S, ~A."
			    pathname
			    (mach:get-unix-error-msg errno)))
		   (:create
		    (cerror "Return NIL."
			    "Error creating ~S, path does not exist."
			    pathname)))
		 nil)
		((eql errno mach:eexist)
		 (unless (eq nil if-exists)
		   (cerror "Return NIL."
			   "Error opening ~S, ~A."
			   pathname
			   (mach:get-unix-error-msg errno)))
		 nil)
		(t
		 (cerror "Return NIL."
			 "Error opening ~S, ~A."
			 pathname
			 (mach:get-unix-error-msg errno))
		 nil)))))))

;;;; 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-input* (make-synonym-stream '*stdin*))
  (setf *standard-output* (make-synonym-stream '*stdout*))
  (setf *error-output* (make-synonym-stream '*stderr*))
  (setf *query-io* (make-synonym-stream '*terminal-io*))
  (setf *debug-io* *query-io*)
  (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*
	(make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
  (setf *stdout*
	(make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
  (setf *stderr*
	(make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
  (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
    (if tty
	(setf *tty*
	      (make-fd-stream tty :name "the Terminal" :input t :output t
			      :buffering :line))
	(setf *tty* (make-two-way-stream *stdin* *stdout*))))
  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 position and file length.

;;; File-Position  --  Public
;;;
;;;    Call the misc method with the :file-position operation.
;;;
(defun file-position (stream &optional position)
  "With one argument returns the current position within the file
  File-Stream is open to.  If the second argument is supplied, then
  this becomes the new file position.  The second argument may also
  be :start or :end for the start and end of the file, respectively."
  (unless (streamp stream)
    (error "Argument ~S is not a stream." stream))
  (funcall (stream-misc stream) stream :file-position position))

;;; File-Length  --  Public
;;;
;;;    Like File-Position, only use :file-length.
;;;
(defun file-length (stream)
  "This function returns the length of the file that File-Stream is open to."
  (unless (streamp stream)
    (error "Argument ~S is not a stream." stream))
  (funcall (stream-misc stream) stream :file-length))

;;; 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)
  (when (fd-stream-p stream)
    (if new-name
	(setf (fd-stream-file stream) new-name)
	(fd-stream-file stream))))