Newer
Older
;;; 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))
"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))
;; 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))
(let ((filespec (pathname filename))
(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 "Do it anyway."
"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 "Unable to open streams of class ~S." class)))))
;;;; 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-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*))))
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
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+)
(if (= (stream::ef-min-octets (stream::find-external-format extfmt))
(stream::ef-max-octets (stream::find-external-format extfmt)))
`(lambda (stream object)
(declare (ignore stream)
(type (or character string) object)
(optimize (speed 3) (space 0) (safety 0)))
(etypecase object
(character ,(stream::ef-min-octets (stream::find-external-format extfmt)))
(string (* ,(stream::ef-min-octets (stream::find-external-format extfmt))
(length object)))))
`(lambda (stream object &aux (count 0))
(declare (type fd-stream stream)
(type (or character string) object)
#|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
`(labels ((eflen (char)
(stream::char-to-octets ,extfmt char
;;@@ FIXME: don't alter state!
(fd-stream-co-state stream)
(lambda (byte)
(declare (ignore byte))
(incf count)))))
(etypecase object
(character (eflen object))
(string (dovector (ch object) (eflen ch))))
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)