Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[2fb9cd]: contrib / sb-simple-streams / file.lisp Maximize Restore History

Download this file

file.lisp    291 lines (269 with data), 13.5 kB

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