Newer
Older
(t
(error 'simple-file-error
:pathname pathname
:format-control _"Cannot find ~S: ~A"
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
: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 _"Return NIL."
'simple-file-error
:pathname pathname
:format-control _"Error opening ~S, ~A."
:format-arguments
(list pathname
(unix:get-unix-error-msg errno))))
(:create
(cerror _"Return NIL."
'simple-file-error
:pathname pathname
:format-control
_"Error creating ~S, path does not exist."
:format-arguments (list pathname))))
(return nil))
((eql errno unix:eexist)
(unless (eq nil if-exists)
(cerror _"Return NIL."
'simple-file-error
:pathname pathname
:format-control _"Error opening ~S, ~A."
:format-arguments
(list pathname
(unix:get-unix-error-msg errno))))
(return nil))
((eql errno unix:eacces)
(cerror _"Try again."
'simple-file-error
:pathname pathname
:format-control _"Error opening ~S, ~A."
:format-arguments
(list pathname
(unix:get-unix-error-msg errno))))
(t
(cerror _"Return NIL."
'simple-file-error
:pathname pathname
:format-control _"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)
(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))
(: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))
"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)))))
"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+)
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
;; 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)))