Suppress warnings about possible slot name conflicts with slots from SB-PCL.
[sbcl.git] / contrib / sb-simple-streams / file.lisp
1 ;;; -*- lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
5 ;;; domain.
6 ;;;
7
8 ;;; Sbcl port by Rudi Schlatte.
9
10 (in-package "SB-SIMPLE-STREAMS")
11
12 ;;;
13 ;;; **********************************************************************
14 ;;;
15 ;;; Definition of File-Simple-Stream and relations
16
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)))
22
23 (def-stream-class mapped-file-simple-stream (file-simple-stream
24                                              direct-simple-stream)
25   ())
26
27 (def-stream-class probe-simple-stream (simple-stream)
28   ((pathname :initform nil :initarg :pathname)))
29
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)))))
39
40
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)
49       (ecase direction
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)
61              ;; set up buffers
62              stream)
63             (t
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)
67                (when fd
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
78                    (lambda ()
79                      (sb-unix:unix-close fd)
80                      (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
81                              namestring fd)
82                      (when original
83                        (revert-file namestring original)))
84                    :dont-save t)
85                  stream)))))))
86
87 (defmethod device-open ((stream file-simple-stream) options)
88   (with-stream-class (file-simple-stream stream)
89     (when (open-file-stream stream options)
90       ;; Franz says:
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
100       ;;   issue."
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))
111       stream)))
112
113 ;;;   Revert a file, if possible; otherwise just delete it.  Used during
114 ;;; CLOSE when the abort flag is set.
115 ;;;
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.
124   (if original
125       (multiple-value-bind (okay err) (sb-unix:unix-rename original filename)
126         (unless okay
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)
132         (unless okay
133           (cerror "Go on as if nothing bad happened."
134                   "Could not remove ~S: ~A"
135                   filename (sb-int:strerror err))))))
136
137 ;;; DELETE-ORIGINAL -- internal
138 ;;;
139 ;;;   Delete a backup file.  Used during CLOSE.
140 ;;;
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))
146   (when original
147     (multiple-value-bind (okay err) (sb-unix:unix-unlink original)
148       (unless okay
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))))))
152
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           (closed nil))
157       (when (integerp fd)
158         (cond (abort
159                (when (any-stream-instance-flags stream :output)
160                  #+win32 (progn (sb-unix:unix-close fd) (setf closed t))
161                  (revert-file (sm filename stream) (sm original stream))))
162               (t
163                (when (sm delete-original stream)
164                  (delete-original (sm filename stream) (sm original stream)))))
165         (unless closed
166           (sb-unix:unix-close fd)))
167       (when (sm buffer stream)
168         (free-buffer (sm buffer stream))
169         (setf (sm buffer stream) nil))))
170   t)
171
172 (defmethod device-file-position ((stream file-simple-stream))
173   (with-stream-class (file-simple-stream stream)
174     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
175       (if (integerp fd)
176           (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
177           (file-position fd)))))
178
179 (defmethod (setf device-file-position) (value (stream file-simple-stream))
180   (declare (type fixnum value))
181   (with-stream-class (file-simple-stream stream)
182     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
183       (if (integerp fd)
184           (values (sb-unix:unix-lseek fd
185                                       (if (minusp value) (1+ value) value)
186                                       (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
187           (file-position fd value)))))
188
189 (defmethod device-file-length ((stream file-simple-stream))
190   (with-stream-class (file-simple-stream stream)
191     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
192       (if (integerp fd)
193           (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
194               (sb-unix:unix-fstat (sm input-handle stream))
195             (declare (ignore dev ino mode nlink uid gid rdev))
196             (if okay size nil))
197           (file-length fd)))))
198
199 (defmethod device-open ((stream mapped-file-simple-stream) options)
200   (with-stream-class (mapped-file-simple-stream stream)
201     (when (open-file-stream stream options)
202       (let* ((input (any-stream-instance-flags stream :input))
203              (output (any-stream-instance-flags stream :output))
204              (prot (logior (if input sb-posix::PROT-READ 0)
205                            (if output sb-posix::PROT-WRITE 0)))
206              (fd (or (sm input-handle stream) (sm output-handle stream))))
207         (unless (integerp fd)
208           (error "Can't memory-map an encapsulated stream."))
209         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
210             (sb-unix:unix-fstat fd)
211           (declare (ignore ino mode nlink uid gid rdev))
212           (unless okay
213             (sb-unix:unix-close fd)
214             (sb-ext:cancel-finalization stream)
215             (error "Error fstating ~S: ~A" stream
216                    (sb-int:strerror dev)))
217           (when (>= size most-positive-fixnum)
218             ;; Or else BUF-LEN has to be a general integer, or
219             ;; maybe (unsigned-byte 32).  In any case, this means
220             ;; BUF-MAX and BUF-PTR have to be the same, which means
221             ;; number-consing every time BUF-PTR moves...
222             ;; Probably don't have the address space available to map
223             ;; bigger files, anyway.  Maybe DEVICE-READ can adjust
224             ;; the mapped portion of the file when necessary?
225             (warn "Unable to memory-map entire file.")
226             (setf size (1- most-positive-fixnum)))
227           (let ((buffer
228                  #-win32
229                  (handler-case
230                      (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
231                    (sb-posix:syscall-error nil))
232                  #+win32
233                  (let ((mapping
234                         (sb-win32:create-file-mapping
235                          (sb-win32:get-osfhandle fd) nil 2 0 size nil)))
236                    (typecase mapping
237                      ((integer -1 0) nil)
238                      (t (let ((sap (prog1 (sb-win32:map-view-of-file
239                                            mapping 4 0 0 size)
240                                      (sb-win32:close-handle mapping))))
241                           (and (not (zerop (sb-sys:sap-int sap))) sap)))))))
242             (when (null buffer)
243               (sb-unix:unix-close fd)
244               (sb-ext:cancel-finalization stream)
245               (error "Unable to map file."))
246             (setf (sm buffer stream) buffer
247                   (sm buffpos stream) 0
248                   (sm buffer-ptr stream) size
249                   (sm buf-len stream) size)
250             (when (any-stream-instance-flags stream :output)
251               (setf (sm control-out stream) *std-control-out-table*))
252             (let ((efmt (getf options :external-format :default)))
253               (compose-encapsulating-streams stream efmt)
254               (setf (stream-external-format stream) efmt)
255               ;; overwrite the strategy installed in :after method of
256               ;; (setf stream-external-format)
257               (install-single-channel-character-strategy
258                (melding-stream stream) efmt 'mapped))
259             (sb-ext:finalize stream
260               (lambda ()
261                 #+win32 (sb-win32:unmap-view-of-file buffer)
262                 #-win32 (sb-posix:munmap buffer size)
263                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer))
264               :dont-save t))))
265       stream)))
266
267
268 (defmethod device-close ((stream mapped-file-simple-stream) abort)
269   (with-stream-class (mapped-file-simple-stream stream)
270     (when (sm buffer stream)
271       #+win32 (sb-win32:unmap-view-of-file (sm buffer stream))
272       #-win32 (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
273       (setf (sm buffer stream) nil))
274     (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
275   t)
276
277 (defmethod device-write ((stream mapped-file-simple-stream) buffer
278                          start end blocking)
279   (assert (eq buffer :flush) (buffer)) ; finish/force-output
280   (with-stream-class (mapped-file-simple-stream stream)
281     (sb-posix:msync (sm buffer stream) (sm buf-len stream)
282                     (if blocking sb-posix::ms-sync sb-posix::ms-async))))
283
284 (defmethod device-open ((stream probe-simple-stream) options)
285   (let ((pathname (getf options :filename)))
286     (with-stream-class (probe-simple-stream stream)
287       (add-stream-instance-flags stream :simple)
288       (when (sb-unix:unix-access (file-namestring pathname) sb-unix:f_ok)
289         (setf (sm pathname stream) pathname)
290         t))))