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