X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Ffile.lisp;fp=contrib%2Fsb-simple-streams%2Ffile.lisp;h=7b71b9dcbd19be84fa2f5830c70517910fcaabca;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=2e20b2a322a0ca8816d84c30726ba8c3190e541e;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp index 2e20b2a..7b71b9d 100644 --- a/contrib/sb-simple-streams/file.lisp +++ b/contrib/sb-simple-streams/file.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -21,7 +21,7 @@ (delete-original :initform nil :initarg :delete-original))) (def-stream-class mapped-file-simple-stream (file-simple-stream - direct-simple-stream) + direct-simple-stream) ()) (def-stream-class probe-simple-stream (simple-stream) @@ -35,53 +35,53 @@ ((not (any-stream-instance-flags object :input :output)) (princ "Closed " stream))) (format stream "~:(~A~) for ~S" - (type-of object) (sm filename object))))) + (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)))) + (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))) + (: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)))) - 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))))))) (defmethod device-open ((stream file-simple-stream) options) (with-stream-class (file-simple-stream stream) @@ -98,15 +98,15 @@ ;; 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))) + (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 (sm control-out stream) *std-control-out-table*)) (setf (stream-external-format stream) - (getf options :external-format :default)) + (getf options :external-format :default)) stream))) ;;; Revert a file, if possible; otherwise just delete it. Used during @@ -116,22 +116,22 @@ ;;; as well, snarf error reporting from there. (defun revert-file (filename original) (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (type (or simple-base-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)))) + (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)))))) + (unless okay + (cerror "Go on as if nothing bad happened." + "Could not remove ~S: ~A" + filename (sb-int:strerror err)))))) ;;; DELETE-ORIGINAL -- internal ;;; @@ -141,110 +141,110 @@ ;;; as well, snarf error reporting from there. (defun delete-original (filename original) (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (type (or simple-base-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)))))) + (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)))) (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)) (when (sm buffer stream) - (free-buffer (sm buffer stream)) - (setf (sm buffer stream) nil)))) + (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 (sb-int:fixnump fd) - (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr)) - (file-position 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 (sb-int:fixnump fd) - (values (sb-unix:unix-lseek 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))))) + (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 (sb-int:fixnump 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))))) + (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 (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 (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0) (sb-posix:syscall-error nil)))) - (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) - (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)))))) stream))) @@ -257,7 +257,7 @@ t) (defmethod device-write ((stream mapped-file-simple-stream) buffer - start end blocking) + 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) @@ -268,5 +268,5 @@ (with-stream-class (probe-simple-stream stream) (add-stream-instance-flags stream :simple) (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok) - (setf (sm pathname stream) pathname) - t)))) + (setf (sm pathname stream) pathname) + t))))