Newer
Older
(setq version (max version (1+ v)))))))))
(unix:close-dir dir)))
(concatenate 'string base
match (quick-integer-to-string version) "~")))))
;;; 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~}")
(format (the stream *query-io*) (intl:gettext "Enter new value for ~S: ") what)
(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.
;;;
(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)
(cerror (intl:gettext "Use :SUPERSEDE instead.")
(intl:gettext "Could not rename ~S to ~S: ~A.")
;;; 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))
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
;; 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)))))
(let ((original (cond ((and name (eq if-exists :new-version))
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
(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")
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
: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
: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.
: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.
(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
(make-fd-stream 1 :name "Standard Output" :output t :buffering :line
(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
(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)))