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