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