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