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))))