((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
((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
- (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))))
+ (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))))
- (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))))
- 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))))
+ 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)))
+ (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)))
;;; 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)
;;; 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)
;; 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)
;; 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)
;;; 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)
;;; 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)
(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))))
(when (sb-int:fixnump fd)
(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))))
(when (sb-int:fixnump fd)
- (cond (abort
- (when (any-stream-instance-flags stream :output)
- (revert-file (sm filename stream) (sm original stream))))
- (t
- (when (sm delete-original stream)
- (delete-original (sm filename stream) (sm original stream)))))
- (sb-unix:unix-close fd))
+ (cond (abort
+ (when (any-stream-instance-flags stream :output)
+ (revert-file (sm filename stream) (sm original stream))))
+ (t
+ (when (sm delete-original stream)
+ (delete-original (sm filename stream) (sm original stream)))))
+ (sb-unix:unix-close 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 (sb-int:fixnump 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 (sb-int:fixnump 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))
(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 (sb-int:fixnump 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
- (handler-case
+ (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 (sb-int:fixnump 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
+ (handler-case
- (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)))
+ (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)
(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 ()
- (sb-posix:munmap buffer size)
- (format *terminal-io* "~&;;; ** unmapped ~S" buffer))))))
+ (install-single-channel-character-strategy
+ (melding-stream stream) efmt 'mapped))
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-posix:munmap buffer size)
+ (format *terminal-io* "~&;;; ** unmapped ~S" buffer))))))