1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
6 (in-package :io.zeta-streams
)
8 ;;;-------------------------------------------------------------------------
10 ;;;-------------------------------------------------------------------------
12 (defclass file-device
(device)
13 ((filename :initarg
:filename
14 :accessor filename-of
)
19 (delete-if-exists :initarg
:delete-if-exists
20 :accessor delete-if-exists-p
)))
22 (defclass memory-mapped-file-device
(file-device direct-device
) ())
24 (defvar *default-open-mode
* #o666
)
27 ;;;-------------------------------------------------------------------------
29 ;;;-------------------------------------------------------------------------
31 (defmethod print-object ((file file-device
) stream
)
32 (print-unreadable-object (file stream
:identity t
:type nil
)
33 (format stream
"File device for ~S" (filename-of file
))))
36 ;;;-------------------------------------------------------------------------
38 ;;;-------------------------------------------------------------------------
40 (defgeneric open-file
(filename &key direction if-exists if-does-not-exist
41 truncate append extra-flags mode synchronized
42 buffering buffer-size external-format
))
45 ;;;-------------------------------------------------------------------------
47 ;;;-------------------------------------------------------------------------
49 (defmethod initialize-instance :after
50 ((device file-device
) &key handle filename flags
51 (mode *default-open-mode
*) delete-if-exists
)
52 (setf (filename-of device
) (copy-seq filename
))
54 (device-open device
:handle handle
:filename filename
:flags flags
55 :mode mode
:delete-if-exists delete-if-exists
)))
58 ;;;-------------------------------------------------------------------------
60 ;;;-------------------------------------------------------------------------
62 (defmethod device-open ((device file-device
)
63 &key handle filename flags mode delete-if-exists
)
64 (labels ((handle-error (c)
65 (posix-file-error c filename
"opening"))
68 (%sys-unlink filename
)
69 (posix-error (c) (handle-error c
))))
70 (try-open (&optional
(retry-on-delete t
))
72 (%sys-open filename flags mode
)
74 (cond ((and retry-on-delete delete-if-exists
)
75 (try-delete) (try-open nil
))
76 (t (handle-error c
))))
79 (:no-error
(fd) fd
))))
80 (let ((fd (or handle
(try-open))))
82 (setf (handle-of device
) fd
)))
86 ;;;-------------------------------------------------------------------------
88 ;;;-------------------------------------------------------------------------
90 (defmethod relinquish ((device file-device
) &key abort
)
91 (declare (ignore abort
))
92 (%sys-close
(handle-of device
))
93 (setf (handle-of device
) nil
)
97 ;;;-------------------------------------------------------------------------
99 ;;;-------------------------------------------------------------------------
101 (defmethod device-position ((device file-device
))
103 (%sys-lseek
(handle-of device
) 0 seek-cur
)
105 (posix-file-error err device
"seeking on"))))
107 (defmethod (setf device-position
)
108 (position (device file-device
) &optional
(from :start
))
110 (%sys-lseek
(handle-of device
) position
116 (posix-file-error err device
"seeking on"))))
119 ;;;-------------------------------------------------------------------------
121 ;;;-------------------------------------------------------------------------
123 (defmethod device-length ((device file-device
))
125 (%sys-fstat
(handle-of device
))
127 (posix-file-error err device
"getting status of"))))
130 ;;;-------------------------------------------------------------------------
132 ;;;-------------------------------------------------------------------------
134 (defmethod device-poll-input ((device file-device
) &key timeout
)
135 (poll-fd (handle-of device
) :input timeout
))
137 (defmethod device-poll-output ((device file-device
) &key timeout
)
138 (poll-fd (handle-of device
) :output timeout
))
141 ;;;-------------------------------------------------------------------------
143 ;;;-------------------------------------------------------------------------
145 (defmethod device-read/non-blocking
((device file-device
) vector start end
)
146 (with-device (device)
147 (%read-octets
/non-blocking
(handle-of device
) vector start end
)))
149 (defmethod device-read/timeout
((device file-device
) vector
151 (with-device (device)
152 (%read-octets
/timeout
(handle-of device
) vector start end timeout
)))
155 ;;;-------------------------------------------------------------------------
157 ;;;-------------------------------------------------------------------------
159 (defmethod device-write/non-blocking
((device file-device
) vector start end
)
160 (with-device (device)
161 (%write-octets
/non-blocking
(handle-of device
) vector start end
)))
163 (defmethod device-write/timeout
((device file-device
) vector
165 (with-device (device)
166 (%write-octets
/timeout
(handle-of device
) vector start end timeout
)))
169 ;;;-------------------------------------------------------------------------
171 ;;;-------------------------------------------------------------------------
173 (defmethod open-file :around
174 (filename &key
(direction :input
) (if-exists :default
)
175 (if-does-not-exist :default
) truncate append
(extra-flags 0)
176 (mode *default-open-mode
*) synchronized
(buffering :full
) buffer-size
177 (external-format :default
))
178 (check-type direction file-direction
)
179 (check-type extra-flags file-flags
)
180 (check-type mode file-mode
)
181 (check-type buffering io-buffering
)
182 (when (or (and (null if-exists
)
183 (null if-does-not-exist
))
184 (and (eql :error if-exists
)
185 (eql :error if-does-not-exist
)))
186 (error 'program-error
))
187 (call-next-method filename
:direction direction
:if-exists if-exists
188 :if-does-not-exist if-does-not-exist
189 :truncate truncate
:append append
190 :extra-flags extra-flags
:mode mode
191 :synchronized synchronized
192 :buffering buffering
:buffer-size buffer-size
193 :external-format external-format
))
195 (defmethod open-file (filename &key direction if-exists if-does-not-exist
196 truncate append extra-flags mode synchronized
197 buffering buffer-size external-format
)
198 ;; FIXME: check for file type TTY and adjust buffering
200 (%open-file filename direction if-exists if-does-not-exist
201 truncate append extra-flags mode
)))
205 (make-instance 'single-channel-buffer
207 :synchronized synchronized
209 (if (null external-format
)
211 ;; FIXME: make a stream
212 (error "Streams are unavailable ATM."))))))
214 (defun %open-file
(filename direction if-exists if-does-not-exist
215 truncate append extra-flags mode
)
217 (setf (values flags if-exists if-does-not-exist
)
218 (process-file-direction direction flags
219 if-exists if-does-not-exist
))
220 (setf (values flags if-exists if-does-not-exist
)
221 (process-file-flags direction flags if-exists if-does-not-exist
222 truncate append extra-flags
))
224 (make-instance 'file-device
225 :filename
(namestring filename
)
226 :flags
(logior flags extra-flags
)
228 :delete-if-exists
(eql :delete if-exists
))
229 (posix-file-error (error)
230 (case (identifier-of error
)
232 (if (null if-does-not-exist
) nil
(error error
)))
234 (if (null if-exists
) nil
(error error
)))
236 (:no-error
(file) file
))))
238 (defun process-file-direction (direction flags if-exists if-does-not-exist
)
239 (macrolet ((add-flags (&rest %flags
)
240 `(setf flags
(logior flags
,@%flags
))))
241 (when (eql :default if-exists
) (setf if-exists
:overwrite
))
245 (check-type if-exists
(member :overwrite
:error-if-symlink
))
246 (check-type if-does-not-exist
(member :default
:error
))
247 (when (eql :default if-does-not-exist
)
248 (setf if-does-not-exist
:error
)))
250 (add-flags (if (eql :io direction
) o-rdwr o-wronly
))
251 (check-type if-exists file-if-exists
)
252 (check-type if-does-not-exist file-if-does-not-exist
)
253 (when (eql :default if-does-not-exist
)
254 (setf if-does-not-exist
:create
))))
255 (values flags if-exists if-does-not-exist
)))
257 (defun process-file-flags (direction flags if-exists if-does-not-exist
258 truncate append extra-flags
)
259 (macrolet ((add-flags (&rest %flags
)
260 `(setf flags
(logior flags
,@%flags
))))
263 (unless (eql :input direction
) (add-flags o-excl
)))
265 (add-flags o-excl o-creat
))
267 (add-flags o-nofollow
)))
268 (case if-does-not-exist
269 (:create
(add-flags o-creat
)))
272 (unless (eql :input direction
) (add-flags o-trunc
)))
274 (when (eql :output direction
) (add-flags o-append
)))
276 (add-flags extra-flags
))))
277 (values flags if-exists if-does-not-exist
))