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