Newer
Older
(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")
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
: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)
(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)
(external-format :default)
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
:auto-close t
: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))))))
;;; 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)
decoding-error encoding-error)
"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
: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
(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))
;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
(assure-one-of direction
'(:input :output :io :probe)
:direction))
(setf (getf options :direction) direction)
(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))
(options (copy-list options))
(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.")))
(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)
(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)))))
"The stream connected to the controlling terminal or NIL if there is none.")
"The stream connected to the standard input (file descriptor 0).")
"The stream connected to the standard output (file descriptor 1).")
"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*))
(setf *error-output* (make-synonym-stream '*stderr*))
(setf *query-io* (make-synonym-stream '*terminal-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
:external-format :iso8859-1))
(make-fd-stream 1 :name "Standard Output" :output t :buffering :line
:external-format :iso8859-1))
(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
:buffering :line :auto-close t
:external-format :iso8859-1)
(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-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+)
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
;; 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))
(incf count)))))
(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)
(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))
(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)))