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       (when (sb-int:fixnump fd)
 157         (cond (abort
 158                (when (any-stream-instance-flags stream :output)
 159                  (revert-file (sm filename stream) (sm original stream))))
 160               (t
 161                (when (sm delete-original stream)
 162                  (delete-original (sm filename stream) (sm original stream)))))
 163         (sb-unix:unix-close fd))
 164       (when (sm buffer stream)
 165         (free-buffer (sm buffer stream))
 166         (setf (sm buffer stream) nil))))
 167   t)
 168
 169 (defmethod device-file-position ((stream file-simple-stream))
 170   (with-stream-class (file-simple-stream stream)
 171     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 172       (if (sb-int:fixnump fd)
 173           (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
 174           (file-position fd)))))
 175
 176 (defmethod (setf device-file-position) (value (stream file-simple-stream))
 177   (declare (type fixnum value))
 178   (with-stream-class (file-simple-stream stream)
 179     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 180       (if (sb-int:fixnump fd)
 181           (values (sb-unix:unix-lseek fd
 182                                       (if (minusp value) (1+ value) value)
 183                                       (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
 184           (file-position fd value)))))
 185
 186 (defmethod device-file-length ((stream file-simple-stream))
 187   (with-stream-class (file-simple-stream stream)
 188     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 189       (if (sb-int:fixnump fd)
 190           (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 191               (sb-unix:unix-fstat (sm input-handle stream))
 192             (declare (ignore dev ino mode nlink uid gid rdev))
 193             (if okay size nil))
 194           (file-length fd)))))
 195
 196 (defmethod device-open ((stream mapped-file-simple-stream) options)
 197   (with-stream-class (mapped-file-simple-stream stream)
 198     (when (open-file-stream stream options)
 199       (let* ((input (any-stream-instance-flags stream :input))
 200              (output (any-stream-instance-flags stream :output))
 201              (prot (logior (if input sb-posix::PROT-READ 0)
 202                            (if output sb-posix::PROT-WRITE 0)))
 203              (fd (or (sm input-handle stream) (sm output-handle stream))))
 204         (unless (sb-int:fixnump fd)
 205           (error "Can't memory-map an encapsulated stream."))
 206         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 207             (sb-unix:unix-fstat fd)
 208           (declare (ignore ino mode nlink uid gid rdev))
 209           (unless okay
 210             (sb-unix:unix-close fd)
 211             (sb-ext:cancel-finalization stream)
 212             (error "Error fstating ~S: ~A" stream
 213                    (sb-int:strerror dev)))
 214           (when (>= size most-positive-fixnum)
 215             ;; Or else BUF-LEN has to be a general integer, or
 216             ;; maybe (unsigned-byte 32).  In any case, this means
 217             ;; BUF-MAX and BUF-PTR have to be the same, which means
 218             ;; number-consing every time BUF-PTR moves...
 219             ;; Probably don't have the address space available to map
 220             ;; bigger files, anyway.  Maybe DEVICE-READ can adjust
 221             ;; the mapped portion of the file when necessary?
 222             (warn "Unable to memory-map entire file.")
 223             (setf size (1- most-positive-fixnum)))
 224           (let ((buffer
 225                  (handler-case
 226                   (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
 227                   (sb-posix:syscall-error nil))))
 228             (when (null buffer)
 229               (sb-unix:unix-close fd)
 230               (sb-ext:cancel-finalization stream)
 231               (error "Unable to map file."))
 232             (setf (sm buffer stream) buffer
 233                   (sm buffpos stream) 0
 234                   (sm buffer-ptr stream) size
 235                   (sm buf-len stream) size)
 236             (when (any-stream-instance-flags stream :output)
 237               (setf (sm control-out stream) *std-control-out-table*))
 238             (let ((efmt (getf options :external-format :default)))
 239               (compose-encapsulating-streams stream efmt)
 240               (setf (stream-external-format stream) efmt)
 241               ;; overwrite the strategy installed in :after method of
 242               ;; (setf stream-external-format)
 243               (install-single-channel-character-strategy
 244                (melding-stream stream) efmt 'mapped))
 245             (sb-ext:finalize stream
 246               (lambda ()
 247                 (sb-posix:munmap buffer size)
 248                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer))
 249               :dont-save t))))
 250       stream)))
 251
 252
 253 (defmethod device-close ((stream mapped-file-simple-stream) abort)
 254   (with-stream-class (mapped-file-simple-stream stream)
 255     (when (sm buffer stream)
 256       (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
 257       (setf (sm buffer stream) nil))
 258     (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
 259   t)
 260
 261 (defmethod device-write ((stream mapped-file-simple-stream) buffer
 262                          start end blocking)
 263   (assert (eq buffer :flush) (buffer)) ; finish/force-output
 264   (with-stream-class (mapped-file-simple-stream stream)
 265     (sb-posix:msync (sm buffer stream) (sm buf-len stream)
 266                     (if blocking sb-posix::ms-sync sb-posix::ms-async))))
 267
 268 (defmethod device-open ((stream probe-simple-stream) options)
 269   (let ((pathname (getf options :filename)))
 270     (with-stream-class (probe-simple-stream stream)
 271       (add-stream-instance-flags stream :simple)
 272       (when (sb-unix:unix-access (file-namestring pathname) sb-unix:f_ok)
 273         (setf (sm pathname stream) pathname)
 274         t))))