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   (;; XXX: I can't tell if it's part of the external API that we call
  19    ;; the name used to open the file the "filename", but this is at
  20    ;; variance with other uses of the term "filename" around SBCL,
  21    ;; where we mostly mean "string suitable for system calls".  --
  22    ;; RMK, 2008-01-04.
  23    (filename :initform nil :initarg :filename)
  24    (truename :initform nil :initarg :truename)
  25    (altname :initform nil :initarg :altname)
  26    (after-close :initform nil :initarg :after-close)
  27    (owner-pid :initform nil :initarg :owner-pid)
  28    ;; SB-SIMPLE-STREAMS seems to have its own custom instance
  29    ;; initialization protocols and to permit the user to call
  30    ;; MAKE-INSTANCE directly to get a stream, with the consequence
  31    ;; that we have to have this useless datum in FILE-STREAM classes
  32    ;; in order to ensure that we have a file mode to pass down to
  33    ;; SB-IMPL::OPEN-FILE.  Also, there's another use of the word
  34    ;; "mode" higher up in the class hierarchy.  Feh.
  35    (unix-mode :initform #o0666 :initarg :unix-mode)))
  36
  37 (sb-ext:with-unlocked-packages ("SB-IMPL" "SB-EXT")
  38   (fmakunbound 'sb-impl::stream-pathname)
  39   (defgeneric sb-impl::stream-pathname (stream)
  40     (:method ((stream sb-sys:fd-stream))
  41       (sb-impl::fd-stream-pathname stream))
  42     (:method ((stream file-simple-stream))
  43       (with-stream-class (file-simple-stream stream)
  44         (sm filename stream))))
  45
  46   (fmakunbound 'sb-impl::stream-truename)
  47   (defgeneric sb-impl::stream-truename (stream)
  48     (:method ((stream sb-sys:fd-stream))
  49       (let ((truename (sb-impl::fd-stream-truename stream)))
  50         (if truename
  51             truename
  52             ;; This is a flaw in our system: not all FD-STREAMs should be
  53             ;; FILE-STREAMs, Unix propaganda notwithstanding.
  54             (error 'type-error :datum stream :expected-type 'file-stream))))
  55     (:method ((stream file-simple-stream))
  56       (with-stream-class (file-simple-stream stream)
  57         (sm truename stream))))
  58
  59   (fmakunbound '(setf sb-impl::stream-truename))
  60   (defgeneric (setf sb-impl::stream-truename) (new-value stream)
  61     (:method  (new-name (stream sb-sys:fd-stream))
  62       (setf (sb-impl::fd-stream-truename stream) new-name))
  63     (:method (new-name (stream file-simple-stream))
  64       (with-stream-class (file-simple-stream stream)
  65         (setf (sm truename stream) new-name))))
  66
  67   (fmakunbound 'sb-impl::stream-altname)
  68   (defgeneric sb-impl::stream-altname (stream)
  69     (:method ((stream sb-sys:fd-stream))
  70       (sb-impl::fd-stream-altname stream))
  71     (:method ((stream file-simple-stream))
  72       (with-stream-class (file-simple-stream stream)
  73         (sm altname stream))))
  74
  75   (fmakunbound '(setf sb-impl::stream-altname))
  76   (defgeneric (setf sb-impl::stream-altname) (new-value stream)
  77     (:method  (new-name (stream sb-sys:fd-stream))
  78       (setf (sb-impl::fd-stream-altname stream) new-name))
  79     (:method (new-name (stream file-simple-stream))
  80       (with-stream-class (file-simple-stream stream)
  81         (setf (sm altname stream) new-name))))
  82
  83   (fmakunbound 'sb-impl::stream-owner-pid)
  84   (defgeneric sb-impl::stream-owner-pid (stream)
  85     (:method ((stream sb-sys:fd-stream))
  86       (sb-impl::fd-stream-owner-pid stream))
  87     (:method ((stream file-simple-stream))
  88       (with-stream-class (file-simple-stream stream)
  89         (sm owner-pid stream))))
  90
  91   (fmakunbound '(setf sb-impl::stream-owner-pid))
  92   (defgeneric (setf sb-impl::stream-owner-pid) (new-value stream)
  93     (:method  (new-name (stream sb-sys:fd-stream))
  94       (setf (sb-impl::fd-stream-owner-pid stream) new-name))
  95     (:method (new-name (stream file-simple-stream))
  96       (with-stream-class (file-simple-stream stream)
  97         (setf (sm owner-pid stream) new-name))))
  98
  99   (fmakunbound 'sb-impl::stream-after-close)
 100   (defgeneric sb-impl::stream-after-close (stream)
 101     (:method ((stream sb-sys:fd-stream))
 102       (sb-impl::fd-stream-after-close stream))
 103     (:method ((stream file-simple-stream))
 104       (with-stream-class (file-simple-stream stream)
 105         (sm after-close stream))))
 106
 107   (fmakunbound '(setf sb-impl::stream-after-close))
 108   (defgeneric (setf sb-impl::stream-after-close) (new-value stream)
 109     (:method  (new-name (stream sb-sys:fd-stream))
 110       (setf (sb-impl::fd-stream-after-close stream) new-name))
 111     (:method (new-name (stream file-simple-stream))
 112       (with-stream-class (file-simple-stream stream)
 113         (setf (sm after-close stream) new-name)))))
 114
 115 (def-stream-class mapped-file-simple-stream (file-simple-stream
 116                                              direct-simple-stream)
 117   ())
 118
 119 (def-stream-class probe-simple-stream (simple-stream)
 120   ((pathname :initform nil :initarg :pathname)))
 121
 122 (defmethod print-object ((object file-simple-stream) stream)
 123   (print-unreadable-object (object stream :type nil :identity nil)
 124     (with-stream-class (file-simple-stream object)
 125       (cond ((not (any-stream-instance-flags object :simple))
 126              (princ "Invalid " stream))
 127             ((not (any-stream-instance-flags object :input :output))
 128              (princ "Closed " stream)))
 129       (format stream "~:(~A~) for ~S"
 130               (type-of object) (sm filename object)))))
 131
 132
 133 (defun open-file-stream (stream options)
 134   (let ((direction (getf options :direction :input))
 135         (if-exists (getf options :if-exists))
 136         (if-exists-given (not (eql (getf options :if-exists t) t)))
 137         (if-does-not-exist (getf options :if-does-not-exist))
 138         (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
 139     (with-stream-class (file-simple-stream stream)
 140       (ecase direction
 141         (:input (add-stream-instance-flags stream :input))
 142         (:output (add-stream-instance-flags stream :output))
 143         (:io (add-stream-instance-flags stream :input :output)))
 144       (cond ((and (sm input-handle stream) (sm output-handle stream)
 145                   (not (eql (sm input-handle stream)
 146                             (sm output-handle stream))))
 147              (error "Input-Handle and Output-Handle can't be different."))
 148             ((or (sm input-handle stream) (sm output-handle stream))
 149              (add-stream-instance-flags stream :simple)
 150              ;; get namestring, etc., from handle, if possible
 151              ;;    (i.e., if it's a stream)
 152              ;; set up buffers
 153              stream)
 154             (t
 155              (multiple-value-bind
 156                  (fd
 157                   pathname truename altname input output
 158                   init-func close-func)
 159                  (sb-impl::open-file
 160                   (getf options :filename)
 161                   direction
 162                   (if if-does-not-exist-given
 163                       if-does-not-exist
 164                       'sb-impl::default)
 165                   (if if-exists-given
 166                       (case if-exists
 167                         ;; KLUDGE: circa 1.0.13, SB-SIMPLE-STREAMS
 168                         ;; did :APPEND as an O_RDWR opening followed
 169                         ;; by a reposition, but FD-STREAMS opened
 170                         ;; with O_APPEND.
 171                                         ;(:append :overwrite)
 172                         (otherwise if-exists))
 173                       'sb-impl::default)
 174                   ;; FIXME: SIMPLE-STREAMS ignores ELEMENT-TYPE, and
 175                   ;; OPEN-FILE doesn't care about the ELEMENT-TYPE,
 176                   ;; but in principle we might have to care about it
 177                   ;; eventually on Windows.
 178                   '(unsigned-byte 8)
 179                   (or (getf options :unix-mode) (sm unix-mode stream)))
 180                (declare (ignore input output))
 181                (unwind-protect
 182                    (when fd
 183                      (add-stream-instance-flags stream :simple)
 184                      (setf (sm filename stream) pathname
 185                            (sm truename stream) truename
 186                            (sm altname stream) altname
 187                            (sm after-close stream) close-func
 188                            (sm owner-pid stream) (sb-posix:getpid))
 189                      (when (any-stream-instance-flags stream :input)
 190                        (setf (sm input-handle stream) fd))
 191                      (when (any-stream-instance-flags stream :output)
 192                        (setf (sm output-handle stream) fd))
 193                      (sb-ext:finalize stream
 194                                       (lambda ()
 195                                         (sb-posix:close fd)
 196                                         (format *terminal-io*
 197                                                 "~&;;; ** closed ~A (fd ~D)~%"
 198                                                 pathname fd)))
 199                      (when init-func
 200                        (funcall init-func stream))
 201                      (setf fd nil)
 202                      stream)
 203                  (when fd
 204                    (sb-posix:close fd)))))))))
 205
 206 (defmethod device-open ((stream file-simple-stream) options)
 207   (with-stream-class (file-simple-stream stream)
 208     (when (open-file-stream stream options)
 209       ;; Franz says:
 210       ;;  "The device-open method must be prepared to recognize resource
 211       ;;   and change-class situations. If no filename is specified in
 212       ;;   the options list, and if no input-handle or output-handle is
 213       ;;   given, then the input-handle and output-handle slots should
 214       ;;   be examined; if non-nil, that means the stream is still open,
 215       ;;   and thus the operation being requested of device-open is a
 216       ;;   change-class. Also, a device-open method need not allocate a
 217       ;;   buffer every time it is called, but may instead reuse a
 218       ;;   buffer it finds in a stream, if it does not become a security
 219       ;;   issue."
 220       (unless (sm buffer stream)
 221         (let ((length (device-buffer-length stream)))
 222           (setf (sm buffer stream) (allocate-buffer length)
 223                 (sm buffpos stream) 0
 224                 (sm buffer-ptr stream) 0
 225                 (sm buf-len stream) length)))
 226       (when (any-stream-instance-flags stream :output)
 227         (setf (sm control-out stream) *std-control-out-table*))
 228       (setf (stream-external-format stream)
 229             (getf options :external-format :default))
 230       stream)))
 231
 232 (defmethod device-close ((stream file-simple-stream) abort)
 233   (when (open-stream-p stream)
 234     (with-stream-class (file-simple-stream stream)
 235       (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 236         (when (sb-int:fixnump fd)
 237           (sb-unix:unix-close fd)
 238           (sb-impl::do-after-close-actions stream abort))
 239         (when (sm buffer stream)
 240           (free-buffer (sm buffer stream))
 241           (setf (sm buffer stream) nil)))))
 242   t)
 243
 244 (defmethod device-file-position ((stream file-simple-stream))
 245   (with-stream-class (file-simple-stream stream)
 246     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 247       (if (sb-int:fixnump fd)
 248           (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
 249           (file-position fd)))))
 250
 251 (defmethod (setf device-file-position) (value (stream file-simple-stream))
 252   (declare (type fixnum value))
 253   (with-stream-class (file-simple-stream stream)
 254     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 255       (if (sb-int:fixnump fd)
 256           (values (sb-unix:unix-lseek fd
 257                                       (if (minusp value) (1+ value) value)
 258                                       (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
 259           (file-position fd value)))))
 260
 261 (defmethod device-file-length ((stream file-simple-stream))
 262   (with-stream-class (file-simple-stream stream)
 263     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
 264       (if (sb-int:fixnump fd)
 265           (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 266               (sb-unix:unix-fstat (sm input-handle stream))
 267             (declare (ignore dev ino mode nlink uid gid rdev))
 268             (if okay size nil))
 269           (file-length fd)))))
 270
 271 (defmethod device-open ((stream mapped-file-simple-stream) options)
 272   (with-stream-class (mapped-file-simple-stream stream)
 273     (when (open-file-stream stream options)
 274       (let* ((input (any-stream-instance-flags stream :input))
 275              (output (any-stream-instance-flags stream :output))
 276              (prot (logior (if input sb-posix::PROT-READ 0)
 277                            (if output sb-posix::PROT-WRITE 0)))
 278              (fd (or (sm input-handle stream) (sm output-handle stream))))
 279         (unless (sb-int:fixnump fd)
 280           (error "Can't memory-map an encapsulated stream."))
 281         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 282             (sb-unix:unix-fstat fd)
 283           (declare (ignore ino mode nlink uid gid rdev))
 284           (unless okay
 285             (sb-unix:unix-close fd)
 286             (sb-ext:cancel-finalization stream)
 287             (error "Error fstating ~S: ~A" stream
 288                    (sb-int:strerror dev)))
 289           (when (>= size most-positive-fixnum)
 290             ;; Or else BUF-LEN has to be a general integer, or
 291             ;; maybe (unsigned-byte 32).  In any case, this means
 292             ;; BUF-MAX and BUF-PTR have to be the same, which means
 293             ;; number-consing every time BUF-PTR moves...
 294             ;; Probably don't have the address space available to map
 295             ;; bigger files, anyway.  Maybe DEVICE-READ can adjust
 296             ;; the mapped portion of the file when necessary?
 297             (warn "Unable to memory-map entire file.")
 298             (setf size (1- most-positive-fixnum)))
 299           (let ((buffer
 300                  (handler-case
 301                   (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
 302                   (sb-posix:syscall-error nil))))
 303             (when (null buffer)
 304               (sb-unix:unix-close fd)
 305               (sb-ext:cancel-finalization stream)
 306               (error "Unable to map file."))
 307             (setf (sm buffer stream) buffer
 308                   (sm buffpos stream) 0
 309                   (sm buffer-ptr stream) size
 310                   (sm buf-len stream) size)
 311             (when (any-stream-instance-flags stream :output)
 312               (setf (sm control-out stream) *std-control-out-table*))
 313             (let ((efmt (getf options :external-format :default)))
 314               (compose-encapsulating-streams stream efmt)
 315               (setf (stream-external-format stream) efmt)
 316               ;; overwrite the strategy installed in :after method of
 317               ;; (setf stream-external-format)
 318               (install-single-channel-character-strategy
 319                (melding-stream stream) efmt 'mapped))
 320             (sb-ext:finalize stream
 321               (lambda ()
 322                 (sb-posix:munmap buffer size)
 323                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer))))))
 324       stream)))
 325
 326
 327 (defmethod device-close ((stream mapped-file-simple-stream) abort)
 328   (with-stream-class (mapped-file-simple-stream stream)
 329     (when (sm buffer stream)
 330       (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
 331       (setf (sm buffer stream) nil))
 332     (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
 333   t)
 334
 335 (defmethod device-write ((stream mapped-file-simple-stream) buffer
 336                          start end blocking)
 337   (assert (eq buffer :flush) (buffer)) ; finish/force-output
 338   (with-stream-class (mapped-file-simple-stream stream)
 339     (sb-posix:msync (sm buffer stream) (sm buf-len stream)
 340                     (if blocking sb-posix::ms-sync sb-posix::ms-async))))
 341
 342 (defmethod device-open ((stream probe-simple-stream) options)
 343   (let ((pathname (getf options :filename)))
 344     (with-stream-class (probe-simple-stream stream)
 345       (add-stream-instance-flags stream :simple)
 346       (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok)
 347         (setf (sm filename stream) pathname)
 348         t))))