3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
8 ;;; Sbcl port by Rudi Schlatte.
10 (in-package "SB-SIMPLE-STREAMS")
13 ;;; **********************************************************************
15 ;;; Definition of File-Simple-Stream and relations
17 (def-stream-class file-simple-stream (single-channel-simple-stream file-stream)
18 ((pathname :initform nil :initarg :pathname)
19 (filename :initform nil :initarg :filename)
20 (original :initform nil :initarg :original)
21 (delete-original :initform nil :initarg :delete-original)))
23 (def-stream-class mapped-file-simple-stream (file-simple-stream
27 (def-stream-class probe-simple-stream (simple-stream)
28 ((pathname :initform nil :initarg :pathname)))
30 (defmethod print-object ((object file-simple-stream) stream)
31 (print-unreadable-object (object stream :type nil :identity nil)
32 (with-stream-class (file-simple-stream object)
33 (cond ((not (any-stream-instance-flags object :simple))
34 (princ "Invalid " stream))
35 ((not (any-stream-instance-flags object :input :output))
36 (princ "Closed " stream)))
37 (format stream "~:(~A~) for ~S"
38 (type-of object) (sm filename object)))))
41 (defun open-file-stream (stream options)
42 (let ((filename (pathname (getf options :filename)))
43 (direction (getf options :direction :input))
44 (if-exists (getf options :if-exists))
45 (if-exists-given (not (eql (getf options :if-exists t) t)))
46 (if-does-not-exist (getf options :if-does-not-exist))
47 (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
48 (with-stream-class (file-simple-stream stream)
50 (:input (add-stream-instance-flags stream :input))
51 (:output (add-stream-instance-flags stream :output))
52 (:io (add-stream-instance-flags stream :input :output)))
53 (cond ((and (sm input-handle stream) (sm output-handle stream)
54 (not (eql (sm input-handle stream)
55 (sm output-handle stream))))
56 (error "Input-Handle and Output-Handle can't be different."))
57 ((or (sm input-handle stream) (sm output-handle stream))
58 (add-stream-instance-flags stream :simple)
59 ;; get namestring, etc., from handle, if possible
60 ;; (i.e., if it's a stream)
64 (multiple-value-bind (fd namestring original delete-original)
65 (%fd-open filename direction if-exists if-exists-given
66 if-does-not-exist if-does-not-exist-given)
68 (add-stream-instance-flags stream :simple)
69 (setf (sm pathname stream) filename
70 (sm filename stream) namestring
71 (sm original stream) original
72 (sm delete-original stream) delete-original)
73 (when (any-stream-instance-flags stream :input)
74 (setf (sm input-handle stream) fd))
75 (when (any-stream-instance-flags stream :output)
76 (setf (sm output-handle stream) fd))
77 (sb-ext:finalize stream
79 (sb-unix:unix-close fd)
80 (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
83 (revert-file namestring original)))
87 (defmethod device-open ((stream file-simple-stream) options)
88 (with-stream-class (file-simple-stream stream)
89 (when (open-file-stream stream options)
91 ;; "The device-open method must be prepared to recognize resource
92 ;; and change-class situations. If no filename is specified in
93 ;; the options list, and if no input-handle or output-handle is
94 ;; given, then the input-handle and output-handle slots should
95 ;; be examined; if non-nil, that means the stream is still open,
96 ;; and thus the operation being requested of device-open is a
97 ;; change-class. Also, a device-open method need not allocate a
98 ;; buffer every time it is called, but may instead reuse a
99 ;; buffer it finds in a stream, if it does not become a security
101 (unless (sm buffer stream)
102 (let ((length (device-buffer-length stream)))
103 (setf (sm buffer stream) (allocate-buffer length)
104 (sm buffpos stream) 0
105 (sm buffer-ptr stream) 0
106 (sm buf-len stream) length)))
107 (when (any-stream-instance-flags stream :output)
108 (setf (sm control-out stream) *std-control-out-table*))
109 (setf (stream-external-format stream)
110 (getf options :external-format :default))
113 ;;; Revert a file, if possible; otherwise just delete it. Used during
114 ;;; CLOSE when the abort flag is set.
116 ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
117 ;;; as well, snarf error reporting from there.
118 (defun revert-file (filename original)
119 (declare (type simple-string filename)
120 (type (or simple-string null) original))
121 ;; We can't do anything unless we know what file were
122 ;; dealing with, and we don't want to do anything
123 ;; strange unless we were writing to the file.
125 (multiple-value-bind (okay err) (sb-unix:unix-rename original filename)
127 (cerror "Go on as if nothing bad happened."
128 "Could not restore ~S to its original contents: ~A"
129 filename (sb-int:strerror err))))
130 ;; We can't restore the original, so nuke that puppy.
131 (multiple-value-bind (okay err) (sb-unix:unix-unlink filename)
133 (cerror "Go on as if nothing bad happened."
134 "Could not remove ~S: ~A"
135 filename (sb-int:strerror err))))))
137 ;;; DELETE-ORIGINAL -- internal
139 ;;; Delete a backup file. Used during CLOSE.
141 ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
142 ;;; as well, snarf error reporting from there.
143 (defun delete-original (filename original)
144 (declare (type simple-string filename)
145 (type (or simple-string null) original))
147 (multiple-value-bind (okay err) (sb-unix:unix-unlink original)
149 (cerror "Go on as if nothing bad happened."
150 "Could not delete ~S during close of ~S: ~A"
151 original filename (sb-int:strerror err))))))
153 (defmethod device-close ((stream file-simple-stream) abort)
154 (with-stream-class (file-simple-stream stream)
155 (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
156 (when (sb-int:fixnump fd)
158 (when (any-stream-instance-flags stream :output)
159 (revert-file (sm filename stream) (sm original stream))))
161 (when (sm delete-original stream)
162 (delete-original (sm filename stream) (sm original stream)))))
163 (sb-unix:unix-close fd))
164 (when (sm buffer stream)
165 (free-buffer (sm buffer stream))
166 (setf (sm buffer stream) nil))))
169 (defmethod device-file-position ((stream file-simple-stream))
170 (with-stream-class (file-simple-stream stream)
171 (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
172 (if (sb-int:fixnump fd)
173 (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
174 (file-position fd)))))
176 (defmethod (setf device-file-position) (value (stream file-simple-stream))
177 (declare (type fixnum value))
178 (with-stream-class (file-simple-stream stream)
179 (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
180 (if (sb-int:fixnump fd)
181 (values (sb-unix:unix-lseek fd
182 (if (minusp value) (1+ value) value)
183 (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
184 (file-position fd value)))))
186 (defmethod device-file-length ((stream file-simple-stream))
187 (with-stream-class (file-simple-stream stream)
188 (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
189 (if (sb-int:fixnump fd)
190 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
191 (sb-unix:unix-fstat (sm input-handle stream))
192 (declare (ignore dev ino mode nlink uid gid rdev))
196 (defmethod device-open ((stream mapped-file-simple-stream) options)
197 (with-stream-class (mapped-file-simple-stream stream)
198 (when (open-file-stream stream options)
199 (let* ((input (any-stream-instance-flags stream :input))
200 (output (any-stream-instance-flags stream :output))
201 (prot (logior (if input sb-posix::PROT-READ 0)
202 (if output sb-posix::PROT-WRITE 0)))
203 (fd (or (sm input-handle stream) (sm output-handle stream))))
204 (unless (sb-int:fixnump fd)
205 (error "Can't memory-map an encapsulated stream."))
206 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
207 (sb-unix:unix-fstat fd)
208 (declare (ignore ino mode nlink uid gid rdev))
210 (sb-unix:unix-close fd)
211 (sb-ext:cancel-finalization stream)
212 (error "Error fstating ~S: ~A" stream
213 (sb-int:strerror dev)))
214 (when (>= size most-positive-fixnum)
215 ;; Or else BUF-LEN has to be a general integer, or
216 ;; maybe (unsigned-byte 32). In any case, this means
217 ;; BUF-MAX and BUF-PTR have to be the same, which means
218 ;; number-consing every time BUF-PTR moves...
219 ;; Probably don't have the address space available to map
220 ;; bigger files, anyway. Maybe DEVICE-READ can adjust
221 ;; the mapped portion of the file when necessary?
222 (warn "Unable to memory-map entire file.")
223 (setf size (1- most-positive-fixnum)))
226 (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
227 (sb-posix:syscall-error nil))))
229 (sb-unix:unix-close fd)
230 (sb-ext:cancel-finalization stream)
231 (error "Unable to map file."))
232 (setf (sm buffer stream) buffer
233 (sm buffpos stream) 0
234 (sm buffer-ptr stream) size
235 (sm buf-len stream) size)
236 (when (any-stream-instance-flags stream :output)
237 (setf (sm control-out stream) *std-control-out-table*))
238 (let ((efmt (getf options :external-format :default)))
239 (compose-encapsulating-streams stream efmt)
240 (setf (stream-external-format stream) efmt)
241 ;; overwrite the strategy installed in :after method of
242 ;; (setf stream-external-format)
243 (install-single-channel-character-strategy
244 (melding-stream stream) efmt 'mapped))
245 (sb-ext:finalize stream
247 (sb-posix:munmap buffer size)
248 (format *terminal-io* "~&;;; ** unmapped ~S" buffer))
253 (defmethod device-close ((stream mapped-file-simple-stream) abort)
254 (with-stream-class (mapped-file-simple-stream stream)
255 (when (sm buffer stream)
256 (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
257 (setf (sm buffer stream) nil))
258 (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
261 (defmethod device-write ((stream mapped-file-simple-stream) buffer
263 (assert (eq buffer :flush) (buffer)) ; finish/force-output
264 (with-stream-class (mapped-file-simple-stream stream)
265 (sb-posix:msync (sm buffer stream) (sm buf-len stream)
266 (if blocking sb-posix::ms-sync sb-posix::ms-async))))
268 (defmethod device-open ((stream probe-simple-stream) options)
269 (let ((pathname (getf options :filename)))
270 (with-stream-class (probe-simple-stream stream)
271 (add-stream-instance-flags stream :simple)
272 (when (sb-unix:unix-access (file-namestring pathname) sb-unix:f_ok)
273 (setf (sm pathname stream) pathname)