io.streams/zeta/file-unix.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- File devices.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Classes and Types
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defclass file-device (device)
  13   ((filename :initarg :filename
  14              :accessor filename-of)
  15    (flags :initarg flags
  16           :accessor flags-of)
  17    (mode :initarg mode
  18          :accessor mode-of)
  19    (delete-if-exists :initarg :delete-if-exists
  20                      :accessor delete-if-exists-p)))
  21
  22 (defclass memory-mapped-file-device (file-device direct-device) ())
  23
  24 (defvar *default-open-mode* #o666)
  25 \f
  26
  27 ;;;-------------------------------------------------------------------------
  28 ;;; PRINT-OBJECT
  29 ;;;-------------------------------------------------------------------------
  30
  31 (defmethod print-object ((file file-device) stream)
  32   (print-unreadable-object (file stream :identity t :type nil)
  33     (format stream "File device for ~S" (filename-of file))))
  34 \f
  35
  36 ;;;-------------------------------------------------------------------------
  37 ;;; Generic functions
  38 ;;;-------------------------------------------------------------------------
  39
  40 (defgeneric open-file (filename &key direction if-exists if-does-not-exist
  41                       truncate append extra-flags mode synchronized
  42                       buffering buffer-size external-format))
  43 \f
  44
  45 ;;;-------------------------------------------------------------------------
  46 ;;; Constructors
  47 ;;;-------------------------------------------------------------------------
  48
  49 (defmethod initialize-instance :after
  50     ((device file-device) &key handle filename flags
  51      (mode *default-open-mode*) delete-if-exists)
  52   (setf (filename-of device) (copy-seq filename))
  53   (with-device (device)
  54     (device-open device :handle handle :filename filename :flags flags
  55                  :mode mode :delete-if-exists delete-if-exists)))
  56 \f
  57
  58 ;;;-------------------------------------------------------------------------
  59 ;;; DEVICE-OPEN
  60 ;;;-------------------------------------------------------------------------
  61
  62 (defmethod device-open ((device file-device)
  63                         &key handle filename flags mode delete-if-exists)
  64   (labels ((handle-error (c)
  65              (posix-file-error c filename "opening"))
  66            (try-delete ()
  67              (handler-case
  68                  (%sys-unlink filename)
  69                (posix-error (c) (handle-error c))))
  70            (try-open (&optional (retry-on-delete t))
  71              (handler-case
  72                  (%sys-open filename flags mode)
  73                (eexist (c)
  74                  (cond ((and retry-on-delete delete-if-exists)
  75                         (try-delete) (try-open nil))
  76                        (t (handle-error c))))
  77                (posix-error (c)
  78                  (handle-error c))
  79                (:no-error (fd) fd))))
  80     (let ((fd (or handle (try-open))))
  81       (%set-fd-nonblock fd)
  82       (setf (handle-of device) fd)))
  83   (values device))
  84 \f
  85
  86 ;;;-------------------------------------------------------------------------
  87 ;;; RELINQUISH
  88 ;;;-------------------------------------------------------------------------
  89
  90 (defmethod relinquish ((device file-device) &key abort)
  91   (declare (ignore abort))
  92   (%sys-close (handle-of device))
  93   (setf (handle-of device) nil)
  94   (values device))
  95 \f
  96
  97 ;;;-------------------------------------------------------------------------
  98 ;;; DEVICE-POSITION
  99 ;;;-------------------------------------------------------------------------
 100
 101 (defmethod device-position ((device file-device))
 102   (handler-case
 103       (%sys-lseek (handle-of device) 0 seek-cur)
 104     (posix-error (err)
 105       (posix-file-error err device "seeking on"))))
 106
 107 (defmethod (setf device-position)
 108     (position (device file-device) &optional (from :start))
 109   (handler-case
 110       (%sys-lseek (handle-of device) position
 111                   (ecase from
 112                     (:start seek-set)
 113                     (:current seek-cur)
 114                     (:end seek-end)))
 115     (posix-error (err)
 116       (posix-file-error err device "seeking on"))))
 117 \f
 118
 119 ;;;-------------------------------------------------------------------------
 120 ;;; DEVICE-LENGTH
 121 ;;;-------------------------------------------------------------------------
 122
 123 (defmethod device-length ((device file-device))
 124   (handler-case
 125       (%sys-fstat (handle-of device))
 126     (posix-error (err)
 127       (posix-file-error err device "getting status of"))))
 128 \f
 129
 130 ;;;-------------------------------------------------------------------------
 131 ;;; I/O WAIT
 132 ;;;-------------------------------------------------------------------------
 133
 134 (defmethod device-poll-input ((device file-device) &key timeout)
 135   (poll-fd (handle-of device) :input timeout))
 136
 137 (defmethod device-poll-output ((device file-device) &key timeout)
 138   (poll-fd (handle-of device) :output timeout))
 139 \f
 140
 141 ;;;-------------------------------------------------------------------------
 142 ;;; DEVICE-READ
 143 ;;;-------------------------------------------------------------------------
 144
 145 (defmethod device-read/non-blocking ((device file-device) vector start end)
 146   (with-device (device)
 147     (%read-octets/non-blocking (handle-of device) vector start end)))
 148
 149 (defmethod device-read/timeout ((device file-device) vector
 150                                 start end timeout)
 151   (with-device (device)
 152     (%read-octets/timeout (handle-of device) vector start end timeout)))
 153 \f
 154
 155 ;;;-------------------------------------------------------------------------
 156 ;;; DEVICE-WRITE
 157 ;;;-------------------------------------------------------------------------
 158
 159 (defmethod device-write/non-blocking ((device file-device) vector start end)
 160   (with-device (device)
 161     (%write-octets/non-blocking (handle-of device) vector start end)))
 162
 163 (defmethod device-write/timeout ((device file-device) vector
 164                                  start end timeout)
 165   (with-device (device)
 166     (%write-octets/timeout (handle-of device) vector start end timeout)))
 167 \f
 168
 169 ;;;-------------------------------------------------------------------------
 170 ;;; OPEN-FILE
 171 ;;;-------------------------------------------------------------------------
 172
 173 (defmethod open-file :around
 174     (filename &key (direction :input) (if-exists :default)
 175      (if-does-not-exist :default) truncate append (extra-flags 0)
 176      (mode *default-open-mode*) synchronized (buffering :full) buffer-size
 177      (external-format :default))
 178   (check-type direction file-direction)
 179   (check-type extra-flags file-flags)
 180   (check-type mode file-mode)
 181   (check-type buffering io-buffering)
 182   (when (or (and (null if-exists)
 183                  (null if-does-not-exist))
 184             (and (eql :error if-exists)
 185                  (eql :error if-does-not-exist)))
 186     (error 'program-error))
 187   (call-next-method filename :direction direction :if-exists if-exists
 188                     :if-does-not-exist if-does-not-exist
 189                     :truncate truncate :append append
 190                     :extra-flags extra-flags :mode mode
 191                     :synchronized synchronized
 192                     :buffering buffering :buffer-size buffer-size
 193                     :external-format external-format))
 194
 195 (defmethod open-file (filename &key direction if-exists if-does-not-exist
 196                       truncate append extra-flags mode synchronized
 197                       buffering buffer-size external-format)
 198   ;; FIXME: check for file type TTY and adjust buffering
 199   (let ((file-device
 200          (%open-file filename direction if-exists if-does-not-exist
 201                      truncate append extra-flags mode)))
 202     (if (null buffering)
 203         (values file-device)
 204         (let ((buffer
 205                (make-instance 'single-channel-buffer
 206                               :device file-device
 207                               :synchronized synchronized
 208                               :size buffer-size)))
 209           (if (null external-format)
 210               (values buffer)
 211               ;; FIXME: make a stream
 212               (error "Streams are unavailable ATM."))))))
 213
 214 (defun %open-file (filename direction if-exists if-does-not-exist
 215                    truncate append extra-flags mode)
 216   (let ((flags 0))
 217     (setf (values flags if-exists if-does-not-exist)
 218           (process-file-direction direction flags
 219                                   if-exists if-does-not-exist))
 220     (setf (values flags if-exists if-does-not-exist)
 221           (process-file-flags direction flags if-exists if-does-not-exist
 222                               truncate append extra-flags))
 223     (handler-case
 224         (make-instance 'file-device
 225                        :filename (namestring filename)
 226                        :flags (logior flags extra-flags)
 227                        :mode mode
 228                        :delete-if-exists (eql :delete if-exists))
 229       (posix-file-error (error)
 230         (case (identifier-of error)
 231           (:enoent
 232            (if (null if-does-not-exist) nil (error error)))
 233           (:eexist
 234            (if (null if-exists) nil (error error)))
 235           (t (error error))))
 236       (:no-error (file) file))))
 237
 238 (defun process-file-direction (direction flags if-exists if-does-not-exist)
 239   (macrolet ((add-flags (&rest %flags)
 240                `(setf flags (logior flags ,@%flags))))
 241     (when (eql :default if-exists) (setf if-exists :overwrite))
 242     (ecase direction
 243       (:input
 244        (add-flags o-rdonly)
 245        (check-type if-exists (member :overwrite :error-if-symlink))
 246        (check-type if-does-not-exist (member :default :error))
 247        (when (eql :default if-does-not-exist)
 248          (setf if-does-not-exist :error)))
 249       ((:output :io)
 250        (add-flags (if (eql :io direction) o-rdwr o-wronly))
 251        (check-type if-exists file-if-exists)
 252        (check-type if-does-not-exist file-if-does-not-exist)
 253        (when (eql :default if-does-not-exist)
 254          (setf if-does-not-exist :create))))
 255     (values flags if-exists if-does-not-exist)))
 256
 257 (defun process-file-flags (direction flags if-exists if-does-not-exist
 258                            truncate append extra-flags)
 259   (macrolet ((add-flags (&rest %flags)
 260                `(setf flags (logior flags ,@%flags))))
 261     (case if-exists
 262       (:error
 263        (unless (eql :input direction) (add-flags o-excl)))
 264       (:delete
 265        (add-flags o-excl o-creat))
 266       (:error-if-symlink
 267        (add-flags o-nofollow)))
 268     (case if-does-not-exist
 269       (:create (add-flags o-creat)))
 270     (cond
 271       (truncate
 272        (unless (eql :input direction) (add-flags o-trunc)))
 273       (append
 274        (when (eql :output direction) (add-flags o-append)))
 275       (extra-flags
 276        (add-flags extra-flags))))
 277   (values flags if-exists if-does-not-exist))