Skip to content
Snippets Groups Projects
fd-stream.lisp 87.8 KiB
Newer Older
			      (setq version (max version (1+ v)))))))))
	    (unix:close-dir dir)))
	(concatenate 'string base
		     match (quick-integer-to-string version) "~")))))

ram's avatar
ram committed
;;; 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 (intl:gettext "Enter new value for ~*~S")
	      (intl:gettext "~S is invalid for ~S. Must be one of~{ ~S~}")
ram's avatar
ram committed
	      item
	      what
	      list)
      (format (the stream *query-io*) (intl:gettext "Enter new value for ~S: ") what)
ram's avatar
ram committed
      (force-output *query-io*)
      (setf item (read *query-io*))
      (when (member item list)
	(return))))
  item)

;;; DO-OLD-RENAME  --  Internal
;;;
;;;    Rename Namestring to Original.  First, check if we have write access,
;;; since we don't want to trash unwritable files even if we technically can.
toy's avatar
toy committed
;;; We return true if we succeed in renaming.
;;;
(defun do-old-rename (namestring original)
  (unless (unix:unix-access namestring unix:w_ok)
    (cerror (intl:gettext "Try to rename it anyway.") (intl:gettext "File ~S is not writable.") namestring))
  (multiple-value-bind
      (okay err)
      (unix:unix-rename namestring original)
	   (cerror (intl:gettext "Use :SUPERSEDE instead.")
		   (intl:gettext "Could not rename ~S to ~S: ~A.")
		   (unix:get-unix-error-msg err))
;;; FD-OPEN  --  Internal
;;;
;;;    Open a file.
;;;
(defun fd-open (pathname direction if-exists if-exists-given
                          if-does-not-exist if-does-not-exist-given)
  (declare (type pathname pathname)
           (type (member :input :output :io :probe) direction)
           (type (member :error :new-version :rename :rename-and-delete
                         :overwrite :append :supersede nil) if-exists)
           (type (member :error :create nil) if-does-not-exist))
  (multiple-value-bind (input output mask)
      (ecase direction
        (:input (values t nil unix:o_rdonly))
        (:output (values nil t unix:o_wronly))
        (:io (values t t unix:o_rdwr))
        (:probe (values t nil unix:o_rdonly)))
    (declare (type index mask))
emarsden's avatar
 
emarsden committed
    ;; 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)))
           (case if-exists
             ((:error nil)
              (setf mask (logior mask unix:o_excl)))
             ((:new-version :rename :rename-and-delete)
              (setf mask (logior mask unix:o_creat)))
             (:supersede
              (setf mask (logior mask unix:o_trunc)))))
          (t
           (setf if-exists nil)))     ; :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))))
    (if (eq if-does-not-exist :create)
        (setf mask (logior mask unix:o_creat)))
    
    (let ((name (cond ((unix-namestring pathname input))
                      ((and input (eq if-does-not-exist :create))
                       (unix-namestring pathname nil)))))
rtoy's avatar
rtoy committed
      (let ((original (cond ((and name (eq if-exists :new-version))
			     (next-version name))
			    ((member if-exists '(:rename :rename-and-delete))
			     (pick-backup-name name))))
            (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
                 (and name
                      (multiple-value-bind
                            (okay err/dev inode orig-mode)
                          (unix:unix-stat name)
                        (declare (ignore inode)
                                 (type (or index null) orig-mode))
                        (cond
                          (okay
                           (when (and output (= (logand orig-mode #o170000)
                                                #o40000))
                             (error 'simple-file-error
                                 :pathname pathname
                                 :format-control
                                 (intl:gettext "Cannot open ~S for output: Is a directory.")
                                 :format-arguments (list name)))
                           (setf mode (logand orig-mode #o777))
                           t)
                          ((eql err/dev unix:enoent)
                           nil)
                          (t
                           (error 'simple-file-error
                                  :pathname pathname
                                  :format-control (intl:gettext "Cannot find ~S: ~A")
                                  :format-arguments
                                    (list name
                                      (unix:get-unix-error-msg err/dev)))))))))
            (unless (and exists
                         (do-old-rename name original))
              (setf original nil)
              (setf delete-original nil)
              ;; In order to use SUPERSEDE instead, we have
              ;; to make sure unix:o_creat corresponds to
              ;; if-does-not-exist.  unix:o_creat was set
              ;; before because of if-exists being :rename.
              (unless (eq if-does-not-exist :create)
                (setf mask (logior (logandc2 mask unix:o_creat)
                                   unix:o_trunc)))
              (setf if-exists :supersede))))
        
        ;; Okay, now we can try the actual open.
        (loop
          (multiple-value-bind (fd errno)
              (if name
                  (unix:unix-open name mask mode)
                  (values nil unix:enoent))
            (cond ((fixnump fd)
toy's avatar
toy committed
		   (when (eq if-exists :append)
		     (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
                   (return (values fd name original delete-original)))
                  ((eql errno unix:enoent)
                   (case if-does-not-exist
                     (:error
                       (cerror (intl:gettext "Return NIL.")
                               'simple-file-error
                               :pathname pathname
                               :format-control (intl:gettext "Error opening ~S, ~A.")
                               :format-arguments
                                   (list pathname
                                         (unix:get-unix-error-msg errno))))
                     (:create
                       (cerror (intl:gettext "Return NIL.")
                               'simple-file-error
                               :pathname pathname
                               :format-control
                                   (intl:gettext "Error creating ~S, path does not exist.")
                               :format-arguments (list pathname))))
                   (return nil))
                  ((eql errno unix:eexist)
                   (unless (eq nil if-exists)
                     (cerror (intl:gettext "Return NIL.")
                             'simple-file-error
                             :pathname pathname
                             :format-control (intl:gettext "Error opening ~S, ~A.")
                             :format-arguments
                                 (list pathname
                                       (unix:get-unix-error-msg errno))))
                   (return nil))
                  ((eql errno unix:eacces)
                   (cerror (intl:gettext "Try again.")
                           'simple-file-error
                           :pathname pathname
                           :format-control (intl:gettext "Error opening ~S, ~A.")
                           :format-arguments
                               (list pathname
                                     (unix:get-unix-error-msg errno))))
                  (t
                   (cerror (intl:gettext "Return NIL.")
                           'simple-file-error
                           :pathname pathname
                           :format-control (intl:gettext "Error opening ~S, ~A.")
                           :format-arguments
                               (list pathname
                                     (unix:get-unix-error-msg errno)))
                   (return nil)))))))))

;;; OPEN-FD-STREAM  --  Internal
;;;
;;;    Open an fd-stream connected to a file.
;;;
(defun open-fd-stream (pathname &key (direction :input)
				(element-type 'base-char)
				(if-exists nil if-exists-given)
				(if-does-not-exist nil if-does-not-exist-given)
		                class
		                decoding-error encoding-error)
  (declare (type pathname pathname)
           (type (member :input :output :io :probe) direction)
           (type (member :error :new-version :rename :rename-and-delete
                         :overwrite :append :supersede nil) if-exists)
           (type (member :error :create nil) if-does-not-exist))
  (multiple-value-bind (fd namestring original delete-original)
      (fd-open pathname direction if-exists if-exists-given
	       if-does-not-exist if-does-not-exist-given)
    (when fd
      (case direction
	((:input :output :io)
	 ;; We use the :class option to tell us if we want a
	 ;; binary-text stream or not.
	 (make-fd-stream fd
			 :input (member direction '(:input :io))
			 :output (member direction '(:output :io))
			 :element-type element-type
			 :file namestring
			 :original original
			 :delete-original delete-original
			 :pathname pathname
			 :input-buffer-p t
			 :external-format external-format
			 :binary-stream-p class
			 :decoding-error decoding-error
			 :encoding-error encoding-error))
	(:probe
	 (let ((stream (%make-fd-stream :name namestring :fd fd
					:pathname pathname
					:element-type element-type)))
	   (close stream)
	   stream))))))
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
rtoy's avatar
rtoy committed
	                   decoding-error encoding-error
		      &allow-other-keys
		      &aux ; Squelch assignment warning.
		      (direction direction)
		      (if-does-not-exist if-does-not-exist)
rtoy's avatar
rtoy committed
		      (if-exists if-exists))
  "Return a stream which reads from or writes to Filename.
ram's avatar
ram committed
  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
rtoy's avatar
rtoy committed
   :decoding-error - How to handle decoding errors from the external format.
                       If a character, then that character is used as
                       the replacment character for all errors.  If T,
                       then a continuable error is signaled.  If
                       continued, the Unicode replacement character is
                       used.  Otherwise, it should be a symbol or
                       function of 3 arguments.  If it returns, it
                       should return a code point to use as the
                       replacment.  The function arguments are a
                       format message string, the offending octet, and
                       the number of octets read in the current
                       encoding.
rtoy's avatar
rtoy committed
   :encoding-error - Like :decoding-error, but for errors when encoding the
                       stream.  If a character, that character is used
                       as the replacment code point.  Otherwise, it
                       should be a symbol or function oof two
                       arguments: a format message string and the
                       incorrect codepoint.
rtoy's avatar
rtoy committed

ram's avatar
ram committed
  See the manual for details."
  (declare (ignore element-type external-format input-handle output-handle
		   decoding-error encoding-error))

  ;; 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))

rtoy's avatar
rtoy committed
  (let ((filespec (merge-pathnames 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
             (cerror (intl:gettext "Do it anyway.")
		     (intl:gettext "Can't create simple-streams with an element-type.")))
toy's avatar
toy committed
           (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 (intl:gettext "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.")
ram's avatar
ram committed
(defvar *stdin* nil
  "The stream connected to the standard input (file descriptor 0).")
ram's avatar
ram committed
(defvar *stdout* nil
  "The stream connected to the standard output (file descriptor 1).")
ram's avatar
ram committed
(defvar *stderr* nil
  "The stream connected to the standard error output (file descriptor 2).")
ram's avatar
ram committed

;;; 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 :utf-8))
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 :utf-8))
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 :utf-8)
	      (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.")
ram's avatar
ram committed

(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+)
  ;; While it would be nice not to have to call CHAR-TO-OCTETS to
  ;; figure out the length when the external format has fixed size
  ;; outputs, we can't.  For example, utf16 will output a BOM, which
  ;; wouldn't be reflected in the count if we don't call
  ;; CHAR-TO-OCTETS.
  `(lambda (stream object &aux (count 0))
     (declare (type fd-stream stream)
	      (type (or character string) object)
              (type (and fixnum unsigned-byte) count)
	      #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
     (labels ((efstate (state)
		(stream::copy-state ,extfmt state))
	      (eflen (char)
		(stream::char-to-octets ,extfmt char
					(fd-stream-co-state stream)
					(lambda (byte)
					  (declare (ignore byte))
rtoy's avatar
rtoy committed
					  (incf count))
					(fd-stream-char-to-octets-erroor stream))))
       (let* ((co-state (fd-stream-co-state stream))
	      (old-ef-state (efstate (cdr (fd-stream-co-state stream))))
	      (old-state (cons (car co-state) old-ef-state)))
	   (character (eflen object))
	   (string (dovector (ch object) (eflen ch))))
	 ;; Restore state
	 (setf (fd-stream-co-state stream) old-state)
	 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))))))

#+unicode
(stream::def-ef-macro ef-copy-state (extfmt lisp stream::+ef-max+ stream::+ef-copy-state+)
  ;; Return a copy of the state of an external format.
  `(lambda (state)
     (declare (ignorable state))
     (stream::copy-state ,extfmt state)))