1.0.10.19: Check also for MIPS foreign_function_call lossage
[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                  stream)))))))
85
86 (defmethod device-open ((stream file-simple-stream) options)
87   (with-stream-class (file-simple-stream stream)
88     (when (open-file-stream stream options)
89       ;; Franz says:
90       ;;  "The device-open method must be prepared to recognize resource
91       ;;   and change-class situations. If no filename is specified in
92       ;;   the options list, and if no input-handle or output-handle is
93       ;;   given, then the input-handle and output-handle slots should
94       ;;   be examined; if non-nil, that means the stream is still open,
95       ;;   and thus the operation being requested of device-open is a
96       ;;   change-class. Also, a device-open method need not allocate a
97       ;;   buffer every time it is called, but may instead reuse a
98       ;;   buffer it finds in a stream, if it does not become a security
99       ;;   issue."
100       (unless (sm buffer stream)
101         (let ((length (device-buffer-length stream)))
102           (setf (sm buffer stream) (allocate-buffer length)
103                 (sm buffpos stream) 0
104                 (sm buffer-ptr stream) 0
105                 (sm buf-len stream) length)))
106       (when (any-stream-instance-flags stream :output)
107         (setf (sm control-out stream) *std-control-out-table*))
108       (setf (stream-external-format stream)
109             (getf options :external-format :default))
110       stream)))
111
112 ;;;   Revert a file, if possible; otherwise just delete it.  Used during
113 ;;; CLOSE when the abort flag is set.
114 ;;;
115 ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
116 ;;; as well, snarf error reporting from there.
117 (defun revert-file (filename original)
118   (declare (type simple-string filename)
119            (type (or simple-string null) original))
120   ;; We can't do anything unless we know what file were
121   ;; dealing with, and we don't want to do anything
122   ;; strange unless we were writing to the file.
123   (if original
124       (multiple-value-bind (okay err) (sb-unix:unix-rename original filename)
125         (unless okay
126           (cerror "Go on as if nothing bad happened."
127                   "Could not restore ~S to its original contents: ~A"
128                   filename (sb-int:strerror err))))
129       ;; We can't restore the original, so nuke that puppy.
130       (multiple-value-bind (okay err) (sb-unix:unix-unlink filename)
131         (unless okay
132           (cerror "Go on as if nothing bad happened."
133                   "Could not remove ~S: ~A"
134                   filename (sb-int:strerror err))))))
135
136 ;;; DELETE-ORIGINAL -- internal
137 ;;;
138 ;;;   Delete a backup file.  Used during CLOSE.
139 ;;;
140 ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
141 ;;; as well, snarf error reporting from there.
142 (defun delete-original (filename original)
143   (declare (type simple-string filename)
144            (type (or simple-string null) original))
145   (when original
146     (multiple-value-bind (okay err) (sb-unix:unix-unlink original)
147       (unless okay
148         (cerror "Go on as if nothing bad happened."
149                 "Could not delete ~S during close of ~S: ~A"
150                 original filename (sb-int:strerror err))))))
151
152 (defmethod device-close ((stream file-simple-stream) abort)
153   (with-stream-class (file-simple-stream stream)
154     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
155       (when (sb-int:fixnump fd)
156         (cond (abort
157                (when (any-stream-instance-flags stream :output)
158                  (revert-file (sm filename stream) (sm original stream))))
159               (t
160                (when (sm delete-original stream)
161                  (delete-original (sm filename stream) (sm original stream)))))
162         (sb-unix:unix-close fd))
163       (when (sm buffer stream)
164         (free-buffer (sm buffer stream))
165         (setf (sm buffer stream) nil))))
166   t)
167
168 (defmethod device-file-position ((stream file-simple-stream))
169   (with-stream-class (file-simple-stream stream)
170     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
171       (if (sb-int:fixnump fd)
172           (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
173           (file-position fd)))))
174
175 (defmethod (setf device-file-position) (value (stream file-simple-stream))
176   (declare (type fixnum value))
177   (with-stream-class (file-simple-stream stream)
178     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
179       (if (sb-int:fixnump fd)
180           (values (sb-unix:unix-lseek fd
181                                       (if (minusp value) (1+ value) value)
182                                       (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
183           (file-position fd value)))))
184
185 (defmethod device-file-length ((stream file-simple-stream))
186   (with-stream-class (file-simple-stream stream)
187     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
188       (if (sb-int:fixnump fd)
189           (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
190               (sb-unix:unix-fstat (sm input-handle stream))
191             (declare (ignore dev ino mode nlink uid gid rdev))
192             (if okay size nil))
193           (file-length fd)))))
194
195 (defmethod device-open ((stream mapped-file-simple-stream) options)
196   (with-stream-class (mapped-file-simple-stream stream)
197     (when (open-file-stream stream options)
198       (let* ((input (any-stream-instance-flags stream :input))
199              (output (any-stream-instance-flags stream :output))
200              (prot (logior (if input sb-posix::PROT-READ 0)
201                            (if output sb-posix::PROT-WRITE 0)))
202              (fd (or (sm input-handle stream) (sm output-handle stream))))
203         (unless (sb-int:fixnump fd)
204           (error "Can't memory-map an encapsulated stream."))
205         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
206             (sb-unix:unix-fstat fd)
207           (declare (ignore ino mode nlink uid gid rdev))
208           (unless okay
209             (sb-unix:unix-close fd)
210             (sb-ext:cancel-finalization stream)
211             (error "Error fstating ~S: ~A" stream
212                    (sb-int:strerror dev)))
213           (when (>= size most-positive-fixnum)
214             ;; Or else BUF-LEN has to be a general integer, or
215             ;; maybe (unsigned-byte 32).  In any case, this means
216             ;; BUF-MAX and BUF-PTR have to be the same, which means
217             ;; number-consing every time BUF-PTR moves...
218             ;; Probably don't have the address space available to map
219             ;; bigger files, anyway.  Maybe DEVICE-READ can adjust
220             ;; the mapped portion of the file when necessary?
221             (warn "Unable to memory-map entire file.")
222             (setf size (1- most-positive-fixnum)))
223           (let ((buffer
224                  (handler-case
225                   (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
226                   (sb-posix:syscall-error nil))))
227             (when (null buffer)
228               (sb-unix:unix-close fd)
229               (sb-ext:cancel-finalization stream)
230               (error "Unable to map file."))
231             (setf (sm buffer stream) buffer
232                   (sm buffpos stream) 0
233                   (sm buffer-ptr stream) size
234                   (sm buf-len stream) size)
235             (when (any-stream-instance-flags stream :output)
236               (setf (sm control-out stream) *std-control-out-table*))
237             (let ((efmt (getf options :external-format :default)))
238               (compose-encapsulating-streams stream efmt)
239               (setf (stream-external-format stream) efmt)
240               ;; overwrite the strategy installed in :after method of
241               ;; (setf stream-external-format)
242               (install-single-channel-character-strategy
243                (melding-stream stream) efmt 'mapped))
244             (sb-ext:finalize stream
245               (lambda ()
246                 (sb-posix:munmap buffer size)
247                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer))))))
248       stream)))
249
250
251 (defmethod device-close ((stream mapped-file-simple-stream) abort)
252   (with-stream-class (mapped-file-simple-stream stream)
253     (when (sm buffer stream)
254       (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
255       (setf (sm buffer stream) nil))
256     (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
257   t)
258
259 (defmethod device-write ((stream mapped-file-simple-stream) buffer
260                          start end blocking)
261   (assert (eq buffer :flush) (buffer)) ; finish/force-output
262   (with-stream-class (mapped-file-simple-stream stream)
263     (sb-posix:msync (sm buffer stream) (sm buf-len stream)
264                     (if blocking sb-posix::ms-sync sb-posix::ms-async))))
265
266 (defmethod device-open ((stream probe-simple-stream) options)
267   (let ((pathname (getf options :filename)))
268     (with-stream-class (probe-simple-stream stream)
269       (add-stream-instance-flags stream :simple)
270       (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok)
271         (setf (sm pathname stream) pathname)
272         t))))