Newer
Older
(t
:create))))
(if (eq if-does-not-exist :create)
(setf mask (logior mask unix:o_creat)))
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
(let ((name (cond ((unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
(unix-namestring pathname nil)))))
(let ((original (cond ((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")
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
: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)
"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+)
;; 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))
(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)
(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)))